diff options
Diffstat (limited to 'lib')
131 files changed, 39120 insertions, 0 deletions
diff --git a/lib/ocaml_rts/Makefile b/lib/ocaml_rts/Makefile new file mode 100644 index 00000000..eee59dd7 --- /dev/null +++ b/lib/ocaml_rts/Makefile @@ -0,0 +1,61 @@ +########################################################################## +# Sail # +# # +# Copyright (c) 2013-2017 # +# Kathyrn Gray # +# Shaked Flur # +# Stephen Kell # +# Gabriel Kerneis # +# Robert Norton-Wright # +# Christopher Pulte # +# Peter Sewell # +# Alasdair Armstrong # +# # +# All rights reserved. # +# # +# This software was developed by the University of Cambridge Computer # +# Laboratory as part of the Rigorous Engineering of Mainstream Systems # +# (REMS) project, funded by EPSRC grant EP/K008528/1. # +# # +# Redistribution and use in source and binary forms, with or without # +# modification, are permitted provided that the following conditions # +# are met: # +# 1. Redistributions of source code must retain the above copyright # +# notice, this list of conditions and the following disclaimer. # +# 2. Redistributions in binary form must reproduce the above copyright # +# notice, this list of conditions and the following disclaimer in # +# the documentation and/or other materials provided with the # +# distribution. # +# # +# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' # +# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED # +# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A # +# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR # +# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, # +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT # +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF # +# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # +# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, # +# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT # +# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # +# SUCH DAMAGE. # +########################################################################## + +.PHONY: all main import clean + +THIS_MAKEFILE=$(realpath $(lastword $(MAKEFILE_LIST))) +BITBUCKET_ROOT=$(realpath $(dir $(THIS_MAKEFILE))../../..) + +all: main + +import: + rsync -rv --include "*/" --include="*.ml" --include="*.mli" --exclude="*" $(BITBUCKET_ROOT)/linksem/src/ linksem + rsync -rv --include "*/" --include="*.ml" --include="*.mli" --exclude="*" $(BITBUCKET_ROOT)/lem/ocaml-lib/ lem + +main: import + ocamlbuild -pkg uint -pkg zarith main.native + +clean: + rm -r linksem + rm -r lem + ocamlbuild -clean diff --git a/lib/ocaml_rts/_tags b/lib/ocaml_rts/_tags new file mode 100644 index 00000000..5f2586c5 --- /dev/null +++ b/lib/ocaml_rts/_tags @@ -0,0 +1,6 @@ +<main.{byte,native}>: use_nums, use_str, use_unix, debug +<linksem>: include +<linksem/adaptors>: include +<lem>: include +<lem/dependencies/zarith>: -traverse +<linksem/src_lem_library>: -traverse diff --git a/lib/ocaml_rts/elf_loader.ml b/lib/ocaml_rts/elf_loader.ml new file mode 100644 index 00000000..4e35a192 --- /dev/null +++ b/lib/ocaml_rts/elf_loader.ml @@ -0,0 +1,132 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Big_int + +let opt_file_arguments = ref ([] : string list) +let opt_elf_threads = ref 1 + +let options = Arg.align [] + +let usage_msg = "Sail OCaml RTS options:" + +let () = + Arg.parse options (fun s -> opt_file_arguments := !opt_file_arguments @ [s]) usage_msg + +type word8 = int + +let escape_char c = + if int_of_char c <= 31 then '.' + else if int_of_char c >= 127 then '.' + else c + +let hex_line bs = + let hex_char i c = + (if i mod 2 == 0 && i <> 0 then " " else "") ^ Printf.sprintf "%02x" (int_of_char c) + in + String.concat "" (List.mapi hex_char bs) ^ " " ^ String.concat "" (List.map (fun c -> Printf.sprintf "%c" (escape_char c)) bs) + +let rec break n = function + | [] -> [] + | (_ :: _ as xs) -> [Lem_list.take n xs] @ break n (Lem_list.drop n xs) + +let print_segment seg = + let (Byte_sequence.Sequence bs) = seg.Elf_interpreted_segment.elf64_segment_body in + prerr_endline "0011 2233 4455 6677 8899 aabb ccdd eeff 0123456789abcdef"; + List.iter (fun bs -> prerr_endline (hex_line bs)) (break 16 bs) + +let read name = + let info = Sail_interface.populate_and_obtain_global_symbol_init_info name in + + prerr_endline "Elf read:"; + let (elf_file, elf_epi, symbol_map) = + begin match info with + | Error.Fail s -> failwith (Printf.sprintf "populate_and_obtain_global_symbol_init_info: %s" s) + | Error.Success ((elf_file: Elf_file.elf_file), + (elf_epi: Sail_interface.executable_process_image), + (symbol_map: Elf_file.global_symbol_init_info)) + -> + prerr_endline (Sail_interface.string_of_executable_process_image elf_epi); + (elf_file, elf_epi, symbol_map) + end + in + + prerr_endline "\nElf segments:"; + let (segments, e_entry, e_machine) = + begin match elf_epi, elf_file with + | (Sail_interface.ELF_Class_32 _, _) -> failwith "cannot handle ELF_Class_32" + | (_, Elf_file.ELF_File_32 _) -> failwith "cannot handle ELF_File_32" + | (Sail_interface.ELF_Class_64 (segments, e_entry, e_machine), Elf_file.ELF_File_64 f1) -> + (* remove all the auto generated segments (they contain only 0s) *) + let segments = + Lem_list.mapMaybe + (fun (seg, prov) -> if prov = Elf_file.FromELF then Some seg else None) + segments + in + (segments, big_int_of_string (Nat_big_num.to_string e_entry),e_machine) + end + in + (segments, e_entry) + +let load_segment seg = + let open Elf_interpreted_segment in + let (Byte_sequence.Sequence bs) = seg.elf64_segment_body in + let paddr = big_int_of_string (Nat_big_num.to_string (seg.elf64_segment_paddr)) in + let base = big_int_of_string (Nat_big_num.to_string (seg.elf64_segment_base)) in + let offset = big_int_of_string (Nat_big_num.to_string (seg.elf64_segment_offset)) in + prerr_endline "\nLoading Segment"; + prerr_endline ("Segment offset: " ^ string_of_big_int offset); + prerr_endline ("Segment base address: " ^ string_of_big_int base); + prerr_endline ("Segment physical address: " ^ string_of_big_int paddr); + print_segment seg; + List.iteri (fun i byte -> Sail_lib.wram (add_big_int paddr (big_int_of_int i)) byte) (List.map int_of_char bs) + +let load_elf () = + let name = + match !opt_file_arguments with + | (name :: _) -> name + | [] -> failwith "Must provide an elf file" + in + let segments, e_entry = read name in + List.iter load_segment segments; + () diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le.ml new file mode 100644 index 00000000..9b73765a --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le.ml @@ -0,0 +1,82 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_le.lem.*) +(** [abi_aarch64_le] contains top-level definition for the AArch64 ABI (little-endian case). + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Lem_assert_extra +open Error +open Missing_pervasives + +open Elf_header +open Elf_types_native_uint +open Elf_file +open Elf_interpreted_segment +open Elf_interpreted_section + +open Endianness +(* open import Elf_memory_image *) +open Abi_classes +open Memory_image +open Abi_aarch64_relocation +open Abi_aarch64_le_elf_header + +(** [abi_aarch64_le_compute_program_entry_point segs entry] computes the program + * entry point using ABI-specific conventions. On AArch64 the entry point in + * the ELF header ([entry] here) is the real entry point. On other ABIs, e.g. + * PowerPC64, the entry point [entry] is a pointer into one of the segments + * constituting the process image (passed in as [segs] here for a uniform + * interface). + *) +(*val abi_aarch64_le_compute_program_entry_point : list elf64_interpreted_segments -> elf64_addr -> error natural*) +let abi_aarch64_le_compute_program_entry_point segs entry:(Nat_big_num.num)error= + (return (Ml_bindings.nat_big_num_of_uint64 entry)) + +(*val header_is_aarch64_le : elf64_header -> bool*) +let header_is_aarch64_le h:bool= + (is_valid_elf64_header h + && ((Lem.option_equal (=) (Lem_list.list_index h.elf64_ident (Nat_big_num.to_int elf_ii_data)) (Some (Uint32.of_string (Nat_big_num.to_string elf_data_2lsb)))) + && (is_valid_abi_aarch64_le_machine_architecture (Nat_big_num.of_string (Uint32.to_string h.elf64_machine)) + && is_valid_abi_aarch64_le_magic_number h.elf64_ident))) + +type aarch64_le_abi_feature = GOT | PLT (* placeholder / FIXME *) + +(*val abiFeatureCompare : aarch64_le_abi_feature -> aarch64_le_abi_feature -> Basic_classes.ordering*) +let abiFeatureCompare f1 f2:int= + ((match (f1, f2) with + (GOT, GOT) -> 0 + | (GOT, PLT) -> (-1) + | (PLT, PLT) -> 0 + | (PLT, GOT) -> 1 + )) + +(*val abiFeatureTagEq : aarch64_le_abi_feature -> aarch64_le_abi_feature -> bool*) +let abiFeatureTagEq f1 f2:bool= + ((match (f1, f2) with + (GOT, GOT) -> true + | (PLT, PLT) -> true + | (_, _) -> false + )) + +let instance_Basic_classes_Ord_Abi_aarch64_le_aarch64_le_abi_feature_dict:(aarch64_le_abi_feature)ord_class= ({ + + compare_method = abiFeatureCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(abiFeatureCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (abiFeatureCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(abiFeatureCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (abiFeatureCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +let instance_Abi_classes_AbiFeatureTagEquiv_Abi_aarch64_le_aarch64_le_abi_feature_dict:(aarch64_le_abi_feature)abiFeatureTagEquiv_class= ({ + + abiFeatureTagEquiv_method = abiFeatureTagEq}) + +(*val section_is_special : forall 'abifeature. elf64_interpreted_section -> annotated_memory_image 'abifeature -> bool*) +let section_is_special0 s f:bool= + (elf_section_is_special s f || (* FIXME *) false) diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_elf_header.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_elf_header.ml new file mode 100644 index 00000000..72510d38 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_elf_header.ml @@ -0,0 +1,60 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_le_elf_header.lem.*) +(** [abi_aarch64_le_elf_header] contains types and definitions relating to ABI + * specific ELF header functionality for the AArch64 ABI (little-endian). + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Missing_pervasives + +open Elf_header +open Elf_types_native_uint + +open Endianness + +(*val abi_aarch64_le_data_encoding : natural*) +let abi_aarch64_le_data_encoding:Nat_big_num.num= elf_data_2lsb + +(*val abi_aarch64_le_endianness : endianness*) +let abi_aarch64_le_endianness:endianness= Little (* Must match above *) + +(*val abi_aarch64_le_file_class : natural*) +let abi_aarch64_le_file_class:Nat_big_num.num= elf_class_64 + +(*val abi_aarch64_le_file_version : natural*) +let abi_aarch64_le_file_version:Nat_big_num.num= elf_ev_current + +(*val abi_aarch64_le_page_size_min : natural*) +let abi_aarch64_le_page_size_min:Nat_big_num.num= (Nat_big_num.of_int 4096) + +(*val abi_aarch64_le_page_size_max : natural*) +let abi_aarch64_le_page_size_max:Nat_big_num.num= (Nat_big_num.of_int 65536) + +(** [is_valid_abi_aarch64_le_machine_architecture m] checks whether the ELF header's + * machine architecture is valid according to the ABI-specific specification. + * Machine architecture must be AArch64 (pg 60) + *) +(*val is_valid_abi_aarch64_le_machine_architecture : natural -> bool*) +let is_valid_abi_aarch64_le_machine_architecture m:bool= (Nat_big_num.equal + m elf_ma_aarch64) + +(** [is_valid_abi_aarch64_le_magic_number magic] checks whether the ELF header's + * magic number is valid according to the ABI-specific specification. + * File class must be 64-bit (pg 60) + * Data encoding must be little endian (pg 60) + *) +(*val is_valid_abi_aarch64_le_magic_number : list unsigned_char -> bool*) +let is_valid_abi_aarch64_le_magic_number magic:bool= + ((match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_class) with + | None -> false + | Some cls -> + (match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_data) with + | None -> false + | Some data -> + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string cls)) abi_aarch64_le_file_class) && + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string data)) abi_aarch64_le_data_encoding) + ) + )) diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_serialisation.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_serialisation.ml new file mode 100644 index 00000000..6a83784e --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_serialisation.ml @@ -0,0 +1,293 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_le_serialisation.lem.*) +(** [abi_aarch64_le_serialisation], code for producing an AARCH64 conformant + * ELF binary file from executable (machine code) data. + * Used in ongoing experiments with CakeML. + * + * XXX: experimental, and outdated. Commented out for now until attention turns + * to CakeML again. + *) + +open Lem_basic_classes +open Lem_list +open Lem_maybe +open Lem_num + +open Byte_sequence +open Missing_pervasives + +open Memory_image +open Elf_file +open Elf_header +open Elf_interpreted_segment +open Elf_program_header_table +open Elf_section_header_table +open Elf_types_native_uint + +open Abi_aarch64_le_elf_header + +(* +(** [abi_aarch64_le_elf_ident abi_version] produces the ELF identification field for + * the ELF header based on ABI-specific information and the [abi_version] + * argument passed in. + *) +val abi_aarch64_le_elf_ident : natural -> list unsigned_char +let abi_aarch64_le_elf_ident abi_version = + List.map unsigned_char_of_natural + [127; 69; 76; 70; (* 127 E L F *) + abi_aarch64_le_file_class; abi_aarch64_le_data_encoding; abi_aarch64_le_file_version; + elf_osabi_none; abi_version; 0; + 0; 0; 0; + 0; 0; 0] + +(** [abi_aarch64_le_generate_elf_header entry phoff phnum] produces an ELF header for + * 64-bit AArh64 little-endian ELF files. The function expects the [entry] address to start + * execution from, the offset of the program header table in [phoff] and the + * number of entries in the program header table in [phnum]. + *) +val abi_aarch64_le_generate_elf_header : elf64_addr -> elf64_off -> elf64_half -> elf64_header +let abi_aarch64_le_generate_elf_header entry phoff phnum = + <| elf64_ident = abi_aarch64_le_elf_ident 0; + elf64_type = elf64_half_of_natural elf_ft_exec; + elf64_machine = elf64_half_of_natural elf_ma_aarch64; + elf64_version = elf64_word_of_natural elf_ev_current; + elf64_entry = entry; + elf64_phoff = phoff; + elf64_shoff = elf64_off_of_natural 0; + elf64_flags = elf64_word_of_natural 0; + elf64_ehsize = elf64_half_of_natural 64; + elf64_phentsize = elf64_half_of_natural 56; + elf64_phnum = phnum; + elf64_shentsize = elf64_half_of_natural 0; + elf64_shnum = elf64_half_of_natural 0; + elf64_shstrndx = elf64_half_of_natural shn_undef + |> + +(** [elf64_pack_segment_flags bs] packages three boolean segment permission flags + * into a word value. + * TODO: move into elf_program_header_table? + *) +val elf64_pack_segment_flags : (bool * bool * bool) -> elf64_word +let elf64_pack_segment_flags (r, w, x) = + let xflag = 1 * natural_of_bool x in + let wflag = 2 * natural_of_bool w in + let rflag = 4 * natural_of_bool r in + elf64_word_of_natural (xflag + wflag + rflag) + +(** [elf64_header_size], size in bytes of an ELF64 header. + * TODO: move into elf_header? + *) +val elf64_header_size : natural +let elf64_header_size = 64 + +(** [elf64_program_header_table_entry_size], size in bytes of an ELF64 program + * header table entry. + * TODO: more into elf_program_header_table? + *) +val elf64_program_header_table_entry_size : natural +let elf64_program_header_table_entry_size = 56 + +val exec_entry_offset : natural +let exec_entry_offset = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + +val code_heap_entry_offset : natural -> natural +let code_heap_entry_offset exec_size = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + exec_size + +val data_heap_entry_offset : natural -> natural -> natural +let data_heap_entry_offset exec_size code_heap_size = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + exec_size + code_heap_size + +val abi_aarch64_le_generate_program_header_table : elf64_interpreted_segment -> elf64_interpreted_segment -> elf64_interpreted_segment -> elf64_program_header_table +let abi_aarch64_le_generate_program_header_table exec code_heap data_heap = + (* exec segment and then base *) + let exec_header = + <| elf64_p_type = elf64_word_of_natural exec.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags exec.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural exec.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural exec.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural exec.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural exec.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural exec.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural exec.elf64_segment_align |> + in + let code_heap_header = + <| elf64_p_type = elf64_word_of_natural code_heap.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags code_heap.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural code_heap.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural code_heap.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural code_heap.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural code_heap.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural code_heap.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural code_heap.elf64_segment_align |> + in + let data_heap_header = + <| elf64_p_type = elf64_word_of_natural data_heap.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags data_heap.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural data_heap.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural data_heap.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural data_heap.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural data_heap.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural data_heap.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural data_heap.elf64_segment_align |> + in + [exec_header; code_heap_header; data_heap_header] + +val abi_aarch64_le_generate_exec_interpreted_segment : natural -> natural -> byte_sequence -> elf64_interpreted_segment +let abi_aarch64_le_generate_exec_interpreted_segment vma offset exec_code = + let segment_size = Byte_sequence.length exec_code in + <| elf64_segment_body = exec_code; + elf64_segment_size = segment_size; + elf64_segment_memsz = segment_size; + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_aarch64_le_page_size_max; + elf64_segment_flags = (true, false, true); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = offset + |> + +val abi_aarch64_le_generate_code_heap_interpreted_segment : natural -> natural -> natural -> elf64_interpreted_segment +let abi_aarch64_le_generate_code_heap_interpreted_segment vma offset segment_size = + let seg = Byte_sequence.create segment_size Missing_pervasives.null_byte in + <| elf64_segment_body = seg; + elf64_segment_size = segment_size; + elf64_segment_memsz = segment_size; + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_aarch64_le_page_size_max; + elf64_segment_flags = (true, true, true); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = offset + |> + +val abi_aarch64_le_entry_point_addr : natural +let abi_aarch64_le_entry_point_addr = 4194304 (* 0x400000 *) + +val abi_aarch64_le_code_heap_addr : natural +let abi_aarch64_le_code_heap_addr = 67108864 (* 16 * 4194304 *) + +val abi_aarch64_le_data_heap_addr : natural +let abi_aarch64_le_data_heap_addr = 67108864 * 16 + +val quad_le_bytes_of_natural : natural -> byte * byte * byte * byte +let quad_le_bytes_of_natural m = + let conv = elf64_addr_of_natural m in + let b0 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land conv (elf64_addr_of_natural 255))) in + let b1 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 8) (elf64_addr_of_natural 255))) in + let b2 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 16) (elf64_addr_of_natural 255))) in + let b3 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 24) (elf64_addr_of_natural 255))) in + (b0, b1, b2, b3) + +val abi_aarch64_le_generate_data_heap_interpreted_segment : natural -> natural -> natural -> natural -> elf64_interpreted_segment +let abi_aarch64_le_generate_data_heap_interpreted_segment vma off segment_size code_heap_size = + let (d0, d1, d2, d3) = quad_le_bytes_of_natural segment_size in + let (c0, c1, c2, c3) = quad_le_bytes_of_natural abi_aarch64_le_code_heap_addr in + let (sz0, sz1, sz2, sz3) = quad_le_bytes_of_natural code_heap_size in + let (pc0, pc1, pc2, pc3) = quad_le_bytes_of_natural 0 in + let (gc0, gc1, gc2, gc3) = quad_le_bytes_of_natural 0 in + let preamble = Byte_sequence.from_byte_lists [[ + d0; d1; d2; d3; null_byte; null_byte; null_byte; null_byte; + c0; c1; c2; c3; null_byte; null_byte; null_byte; null_byte; + sz0; sz1; sz2; sz3; null_byte; null_byte; null_byte; null_byte; + pc0; pc1; pc2; pc3; null_byte; null_byte; null_byte; null_byte; + gc0; gc1; gc2; gc3; null_byte; null_byte; null_byte; null_byte + ]] in + <| elf64_segment_body = preamble; + elf64_segment_size = Byte_sequence.length preamble; + elf64_segment_memsz = max segment_size (Byte_sequence.length preamble); + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_aarch64_le_page_size_max; + elf64_segment_flags = (true, true, false); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = off + |> + +val init_data_heap_instrs : byte_sequence +let init_data_heap_instrs = + let (b0, b1, b2, b3) = quad_le_bytes_of_natural abi_aarch64_le_data_heap_addr in + Byte_sequence.from_byte_lists + [[ byte_of_natural 72 + ; byte_of_natural 199 + ; byte_of_natural 68 + ; byte_of_natural 36 + ; byte_of_natural 248 + ; b0 + ; b1 + ; b2 + ; b3 + ; byte_of_natural 72 + ; byte_of_natural 139 + ; byte_of_natural 68 + ; byte_of_natural 36 + ; byte_of_natural 248 + ]] + +val exit_syscall_instrs : byte_sequence +let exit_syscall_instrs = + Byte_sequence.from_byte_lists + [[ + byte_of_natural 72; + byte_of_natural 199; + byte_of_natural 192; + byte_of_natural 60; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 15; + byte_of_natural 5 + ]] + +val push_instr : natural -> byte_sequence +let push_instr addr = + let (b0, b1, b2, b3) = quad_le_bytes_of_natural addr in + Byte_sequence.from_byte_lists [[ + byte_of_natural 104; + b0; b1; b2; b3 + ]] + +val setup_return_code_instr : byte_sequence +let setup_return_code_instr = + Byte_sequence.from_byte_lists [[ + byte_of_natural 191; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0 + ]] + +val abi_aarch64_le_generate_executable_file : byte_sequence -> natural -> natural -> elf64_file +let abi_aarch64_le_generate_executable_file exec_code code_heap_size data_heap_size = + let exec_code' = Byte_sequence.concat [ + init_data_heap_instrs; + exec_code + ] in + let pre_entry = 5 + abi_aarch64_le_entry_point_addr + Byte_sequence.length exec_code' in + let exec_code = Byte_sequence.concat [push_instr pre_entry; exec_code'; setup_return_code_instr; exit_syscall_instrs] in + let hdr = abi_aarch64_le_generate_elf_header + (elf64_addr_of_natural abi_aarch64_le_entry_point_addr) + (elf64_off_of_natural 64) (elf64_half_of_natural 3) in + let exec_off_i = 64 + 3 * 56 in + let exec_off_adj = compute_virtual_address_adjustment abi_aarch64_le_page_size_max exec_off_i abi_aarch64_le_entry_point_addr in + let exec_off = exec_off_i + exec_off_adj in + let exec = abi_aarch64_le_generate_exec_interpreted_segment + abi_aarch64_le_entry_point_addr exec_off exec_code in + let code_off_i = exec_off + exec.elf64_segment_size in + let code_off_adj = compute_virtual_address_adjustment abi_aarch64_le_page_size_max code_off_i abi_aarch64_le_code_heap_addr in + let code_off = code_off_i + code_off_adj in + let code_heap = abi_aarch64_le_generate_code_heap_interpreted_segment + abi_aarch64_le_code_heap_addr code_off code_heap_size in + let data_off_i = code_off + code_heap.elf64_segment_size in + let data_off_adj = compute_virtual_address_adjustment abi_aarch64_le_page_size_max data_off_i abi_aarch64_le_data_heap_addr in + let data_off = data_off_i + data_off_adj in + let data_heap = abi_aarch64_le_generate_data_heap_interpreted_segment + abi_aarch64_le_data_heap_addr data_off data_heap_size code_heap_size in + let pht = abi_aarch64_le_generate_program_header_table + exec code_heap data_heap in + <| elf64_file_header = hdr; elf64_file_program_header_table = pht; + elf64_file_interpreted_segments = [exec; code_heap; data_heap]; + elf64_file_interpreted_sections = []; + elf64_file_section_header_table = []; + elf64_file_bits_and_bobs = [] |> +*) diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_program_header_table.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_program_header_table.ml new file mode 100644 index 00000000..53b34757 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_program_header_table.ml @@ -0,0 +1,26 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_program_header_table.lem.*) +(** [abi_aarch64_program_header_table], AARCH64 ABI specific program header + * table related flags, data, etc. + *) + +open Lem_basic_classes +open Lem_num + +(** AARCH64 specific segment types. See Section 5.1 *) + +(** Reserved for architecture compatibility information. *) +let abi_aarch64_pt_archext : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939524096)(Nat_big_num.of_int 2)) (* 0x70000000 *) +(** Reserved for unwind information. *) +let abi_aarch64_pt_unwind : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524096)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (* 0x70000001 *) + +(** [string_of_abi_aarch64_segment_type m] produces a string representation of + * an AARCH64 ABI segment type. + *) +(*val string_of_abi_aarch64_segment_type : natural -> string*) +let string_of_abi_aarch64_segment_type m:string= + (if Nat_big_num.equal m abi_aarch64_pt_archext then + "ARCHEXT" + else if Nat_big_num.equal m abi_aarch64_pt_unwind then + "UNWIND" + else + "Invalid AARCH64 segment type") diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_relocation.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_relocation.ml new file mode 100644 index 00000000..742c233c --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_relocation.ml @@ -0,0 +1,944 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_relocation.lem.*) +(** [abi_aarch64_relocation] contains types and definitions relating to ABI + * specific relocation functionality for the AArch64 ABI (little-endian case). + *) + +open Lem_basic_classes +open Lem_num +open Lem_string +open Lem_maybe +open Missing_pervasives + +open Error + +open Elf_types_native_uint +open Elf_file +open Elf_header +open Elf_relocation +open Elf_symbol_table + +open Abi_utilities +open Memory_image + +(** Relocations *) + +let r_aarch64_none : Nat_big_num.num= (Nat_big_num.of_int 0) +let r_aarch64_withdrawn : Nat_big_num.num= (Nat_big_num.of_int 256) (** Treated as R_AARCH6_NONE *) + +let r_aarch64_abs64 : Nat_big_num.num= (Nat_big_num.of_int 257) +let r_aarch64_abs32 : Nat_big_num.num= (Nat_big_num.of_int 258) +let r_aarch64_abs16 : Nat_big_num.num= (Nat_big_num.of_int 259) +let r_aarch64_prel64 : Nat_big_num.num= (Nat_big_num.of_int 260) +let r_aarch64_prel32 : Nat_big_num.num= (Nat_big_num.of_int 261) +let r_aarch64_prel16 : Nat_big_num.num= (Nat_big_num.of_int 262) + +let r_aarch64_movw_uabs_g0 : Nat_big_num.num= (Nat_big_num.of_int 263) +let r_aarch64_movw_uabs_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 264) +let r_aarch64_movw_uabs_g1 : Nat_big_num.num= (Nat_big_num.of_int 265) +let r_aarch64_movw_uabs_g1_nc : Nat_big_num.num= (Nat_big_num.of_int 266) +let r_aarch64_movw_uabs_g2 : Nat_big_num.num= (Nat_big_num.of_int 267) +let r_aarch64_movw_uabs_g2_nc : Nat_big_num.num= (Nat_big_num.of_int 268) +let r_aarch64_movw_uabs_g3 : Nat_big_num.num= (Nat_big_num.of_int 269) + +let r_aarch64_movw_sabs_g0 : Nat_big_num.num= (Nat_big_num.of_int 270) +let r_aarch64_movw_sabs_g1 : Nat_big_num.num= (Nat_big_num.of_int 271) +let r_aarch64_movw_sabs_g2 : Nat_big_num.num= (Nat_big_num.of_int 272) + +let r_aarch64_ld_prel_lo19 : Nat_big_num.num= (Nat_big_num.of_int 273) +let r_aarch64_adr_prel_lo21 : Nat_big_num.num= (Nat_big_num.of_int 274) +let r_aarch64_adr_prel_pg_hi21 : Nat_big_num.num= (Nat_big_num.of_int 275) +let r_aarch64_adr_prel_pg_hi21_nc : Nat_big_num.num= (Nat_big_num.of_int 276) +let r_aarch64_add_abs_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 277) +let r_aarch64_ldst8_abs_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 278) +let r_aarch64_ldst16_abs_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 284) +let r_aarch64_ldst32_abs_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 285) +let r_aarch64_ldst64_abs_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 286) +let r_aarch64_ldst128_abs_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 299) + +let r_aarch64_tstbr14 : Nat_big_num.num= (Nat_big_num.of_int 279) +let r_aarch64_condbr19 : Nat_big_num.num= (Nat_big_num.of_int 280) +let r_aarch64_jump26 : Nat_big_num.num= (Nat_big_num.of_int 282) +let r_aarch64_call26 : Nat_big_num.num= (Nat_big_num.of_int 283) + +let r_aarch64_movw_prel_g0 : Nat_big_num.num= (Nat_big_num.of_int 287) +let r_aarch64_movw_prel_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 288) +let r_aarch64_movw_prel_g1 : Nat_big_num.num= (Nat_big_num.of_int 289) +let r_aarch64_movw_prel_g1_nc : Nat_big_num.num= (Nat_big_num.of_int 290) +let r_aarch64_movw_prel_g2 : Nat_big_num.num= (Nat_big_num.of_int 291) +let r_aarch64_movw_prel_g2_nc : Nat_big_num.num= (Nat_big_num.of_int 292) +let r_aarch64_movw_prel_g3 : Nat_big_num.num= (Nat_big_num.of_int 293) + +let r_aarch64_movw_gotoff_g0 : Nat_big_num.num= (Nat_big_num.of_int 300) +let r_aarch64_movw_gotoff_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 301) +let r_aarch64_movw_gotoff_g1 : Nat_big_num.num= (Nat_big_num.of_int 302) +let r_aarch64_movw_gotoff_g1_nc : Nat_big_num.num= (Nat_big_num.of_int 303) +let r_aarch64_movw_gotoff_g2 : Nat_big_num.num= (Nat_big_num.of_int 304) +let r_aarch64_movw_gotoff_g2_nc : Nat_big_num.num= (Nat_big_num.of_int 305) +let r_aarch64_movw_gotoff_g3 : Nat_big_num.num= (Nat_big_num.of_int 306) + +let r_aarch64_gotrel64 : Nat_big_num.num= (Nat_big_num.of_int 307) +let r_aarch64_gotrel32 : Nat_big_num.num= (Nat_big_num.of_int 308) + +let r_aarch64_got_ld_prel19 : Nat_big_num.num= (Nat_big_num.of_int 309) +let r_aarch64_got_ld64_gotoff_lo15 : Nat_big_num.num= (Nat_big_num.of_int 310) +let r_aarch64_adr_got_page : Nat_big_num.num= (Nat_big_num.of_int 311) +let r_aarch64_ld64_got_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 312) +let r_aarch64_ld64_gotpage_lo15 : Nat_big_num.num= (Nat_big_num.of_int 313) + +let r_aarch64_tlsgd_adr_prel21 : Nat_big_num.num= (Nat_big_num.of_int 512) +let r_aarch64_tlsgd_adr_page21 : Nat_big_num.num= (Nat_big_num.of_int 513) +let r_aarch64_tlsgd_add_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 514) +let r_aarch64_tlsgd_movw_g1 : Nat_big_num.num= (Nat_big_num.of_int 515) +let r_aarch64_tlsgd_movw_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 516) + +let r_aarch64_tlsld_adr_prel21 : Nat_big_num.num= (Nat_big_num.of_int 517) +let r_aarch64_tlsld_adr_page21 : Nat_big_num.num= (Nat_big_num.of_int 518) +let r_aarch64_tlsld_add_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 519) +let r_aarch64_tlsld_movw_g1 : Nat_big_num.num= (Nat_big_num.of_int 520) +let r_aarch64_tlsld_movw_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 521) +let r_aarch64_tlsld_ld_prel19 : Nat_big_num.num= (Nat_big_num.of_int 522) +let r_aarch64_tlsld_movw_dtprel_g2 : Nat_big_num.num= (Nat_big_num.of_int 523) +let r_aarch64_tlsld_movw_dtprel_g1 : Nat_big_num.num= (Nat_big_num.of_int 524) +let r_aarch64_tlsld_movw_dtprel_g1_nc : Nat_big_num.num= (Nat_big_num.of_int 525) +let r_aarch64_tlsld_movw_dtprel_g0 : Nat_big_num.num= (Nat_big_num.of_int 526) +let r_aarch64_tlsld_movw_dtprel_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 527) +let r_aarch64_tlsld_add_dtprel_hi12 : Nat_big_num.num= (Nat_big_num.of_int 528) +let r_aarch64_tlsld_add_dtprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 529) +let r_aarch64_tlsld_add_dtprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 530) +let r_aarch64_tlsld_ldst8_dtprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 531) +let r_aarch64_tlsld_ldst8_dtprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 532) +let r_aarch64_tlsld_ldst16_dtprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 533) +let r_aarch64_tlsld_ldst16_dtprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 534) +let r_aarch64_tlsld_ldst32_dtprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 535) +let r_aarch64_tlsld_ldst32_dtprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 536) +let r_aarch64_tlsld_ldst64_dtprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 537) +let r_aarch64_tlsld_ldst64_dtprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 538) +let r_aarch64_tlsld_ldst128_dtprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 572) +let r_aarch64_tlsld_ldst128_dtprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 573) + +let r_aarch64_tlsie_movw_gottprel_g1 : Nat_big_num.num= (Nat_big_num.of_int 539) +let r_aarch64_tlsie_movw_gottprel_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 540) +let r_aarch64_tlsie_movw_gottprel_page21 : Nat_big_num.num= (Nat_big_num.of_int 541) +let r_aarch64_tlsie_movw_gottprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 542) +let r_aarch64_tlsie_movw_gottprel_prel19 : Nat_big_num.num= (Nat_big_num.of_int 543) + +let r_aarch64_tlsle_movw_tprel_g2 : Nat_big_num.num= (Nat_big_num.of_int 544) +let r_aarch64_tlsle_movw_tprel_g1 : Nat_big_num.num= (Nat_big_num.of_int 545) +let r_aarch64_tlsle_movw_tprel_g1_nc : Nat_big_num.num= (Nat_big_num.of_int 546) +let r_aarch64_tlsle_movw_tprel_g0 : Nat_big_num.num= (Nat_big_num.of_int 547) +let r_aarch64_tlsle_movw_tprel_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 548) +let r_aarch64_add_tprel_hi12 : Nat_big_num.num= (Nat_big_num.of_int 549) +let r_aarch64_add_tprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 550) +let r_aarch64_add_tprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 551) +let r_aarch64_ldst8_tprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 552) +let r_aarch64_ldst8_tprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 553) +let r_aarch64_ldst16_tprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 554) +let r_aarch64_ldst16_tprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 555) +let r_aarch64_ldst32_tprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 556) +let r_aarch64_ldst32_tprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 557) +let r_aarch64_ldst64_tprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 558) +let r_aarch64_ldst64_tprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 559) +let r_aarch64_ldst128_tprel_lo12 : Nat_big_num.num= (Nat_big_num.of_int 570) +let r_aarch64_ldst128_tprel_lo12_nc : Nat_big_num.num= (Nat_big_num.of_int 571) + +let r_aarch64_tlsdesc_ld_prel19 : Nat_big_num.num= (Nat_big_num.of_int 560) +let r_aarch64_tlsdesc_adr_prel21 : Nat_big_num.num= (Nat_big_num.of_int 561) +let r_aarch64_tlsdesc_adr_page21 : Nat_big_num.num= (Nat_big_num.of_int 562) +let r_aarch64_tlsdesc_ld64_lo12 : Nat_big_num.num= (Nat_big_num.of_int 563) +let r_aarch64_tlsdesc_add_lo12 : Nat_big_num.num= (Nat_big_num.of_int 564) +let r_aarch64_tlsdesc_off_g1 : Nat_big_num.num= (Nat_big_num.of_int 565) +let r_aarch64_tlsdesc_off_g0_nc : Nat_big_num.num= (Nat_big_num.of_int 566) +let r_aarch64_tlsdesc_ldr : Nat_big_num.num= (Nat_big_num.of_int 567) +let r_aarch64_tlsdesc_add : Nat_big_num.num= (Nat_big_num.of_int 568) +let r_aarch64_tlsdesc_call : Nat_big_num.num= (Nat_big_num.of_int 569) + +let r_aarch64_copy : Nat_big_num.num= (Nat_big_num.of_int 1024) +let r_aarch64_glob_dat : Nat_big_num.num= (Nat_big_num.of_int 1025) +let r_aarch64_jump_slot : Nat_big_num.num= (Nat_big_num.of_int 1026) +let r_aarch64_relative : Nat_big_num.num= (Nat_big_num.of_int 1027) +let r_aarch64_tls_dtprel64 : Nat_big_num.num= (Nat_big_num.of_int 1028) +let r_aarch64_tls_dtpmod64 : Nat_big_num.num= (Nat_big_num.of_int 1029) +let r_aarch64_tls_tprel64 : Nat_big_num.num= (Nat_big_num.of_int 1030) +let r_aarch64_tlsdesc : Nat_big_num.num= (Nat_big_num.of_int 1031) +let r_aarch64_irelative : Nat_big_num.num= (Nat_big_num.of_int 1032) + +(** [string_of_aarch64_relocation_type m] produces a string representation of the + * relocation type [m]. + *) +(*val string_of_aarch64_relocation_type : natural -> string*) +let string_of_aarch64_relocation_type rel_type1:string= + (if Nat_big_num.equal rel_type1 r_aarch64_none then + "R_AARCH64_NONE" + else if Nat_big_num.equal rel_type1 r_aarch64_withdrawn then + "R_AARCH64_NONE" + else if Nat_big_num.equal rel_type1 r_aarch64_abs64 then + "R_AARCH64_ABS64" + else if Nat_big_num.equal rel_type1 r_aarch64_abs32 then + "R_AARCH64_ABS32" + else if Nat_big_num.equal rel_type1 r_aarch64_abs16 then + "R_AARCH64_ABS16" + else if Nat_big_num.equal rel_type1 r_aarch64_prel64 then + "R_AARCH64_PREL64" + else if Nat_big_num.equal rel_type1 r_aarch64_prel32 then + "R_AARCH64_PREL32" + else if Nat_big_num.equal rel_type1 r_aarch64_prel16 then + "R_AARCH64_PREL16" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g0 then + "R_AARCH64_MOVW_UABS_G0" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g0_nc then + "R_AARCH64_MOVW_UABS_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g1 then + "R_AARCH64_MOVW_UABS_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g1_nc then + "R_AARCH64_MOVW_UABS_G1_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g2 then + "R_AARCH64_MOVW_UABS_G2" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g2_nc then + "R_AARCH64_MOVW_UABS_G2_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g3 then + "R_AARCH64_MOVW_UABS_G3" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_sabs_g0 then + "R_AARCH64_MOVW_SABS_G0" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_sabs_g1 then + "R_AARCH64_MOVW_SABS_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_sabs_g2 then + "R_AARCH64_MOVW_SABS_G2" + else if Nat_big_num.equal rel_type1 r_aarch64_ld_prel_lo19 then + "R_AARCH64_LD_PREL_LO19" + else if Nat_big_num.equal rel_type1 r_aarch64_adr_prel_lo21 then + "R_AARCH64_ADR_PREL_LO21" + else if Nat_big_num.equal rel_type1 r_aarch64_adr_prel_pg_hi21 then + "R_AARCH64_ADR_PREL_PG_HI21" + else if Nat_big_num.equal rel_type1 r_aarch64_adr_prel_pg_hi21_nc then + "R_AARCH64_ADR_PREL_PG_HI21_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_add_abs_lo12_nc then + "R_AARCH64_ADD_ABS_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst8_abs_lo12_nc then + "R_AARCH64_LDST8_ABS_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst16_abs_lo12_nc then + "R_AARCH64_LDST16_ABS_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst32_abs_lo12_nc then + "R_AARCH64_LDST32_ABS_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst64_abs_lo12_nc then + "R_AARCH64_LDST64_ABS_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst128_abs_lo12_nc then + "R_AARCH64_LDST128_ABS_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tstbr14 then + "R_AARCH64_TSTBR14" + else if Nat_big_num.equal rel_type1 r_aarch64_condbr19 then + "R_AARCH64_CONBR19" + else if Nat_big_num.equal rel_type1 r_aarch64_jump26 then + "R_AARCH64_JUMP26" + else if Nat_big_num.equal rel_type1 r_aarch64_call26 then + "R_AARCH64_CALL26" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g0 then + "R_AARCH64_MOVW_PREL_G0" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g0_nc then + "R_AARCH64_MOVW_PREL_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g1 then + "R_AARCH64_MOVW_PREL_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g1_nc then + "R_AARCH64_MOVW_PREL_G1_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g2 then + "R_AARCH64_MOVW_PREL_G2" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g2_nc then + "R_AARCH64_MOVW_PREL_G2_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g3 then + "R_AARCH64_MOVW_PREL_G3" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g0 then + "R_AARCH64_MOVW_GOTOFF_G0" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g0_nc then + "R_AARCH64_MOVW_GOTOFF_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g1 then + "R_AARCH64_MOVW_GOTOFF_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g1_nc then + "R_AARCH64_MOVW_GOTOFF_G1_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g2 then + "R_AARCH64_MOVW_GOTOFF_G2" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g2_nc then + "R_AARCH64_MOVW_GOTOFF_G2_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g3 then + "R_AARCH64_MOVW_GOTOFF_G3" + else if Nat_big_num.equal rel_type1 r_aarch64_gotrel64 then + "R_AARCH64_GOTREL64" + else if Nat_big_num.equal rel_type1 r_aarch64_gotrel32 then + "R_AARCH64_GOTREL32" + else if Nat_big_num.equal rel_type1 r_aarch64_got_ld_prel19 then + "R_AARCH64_GOT_LD_PREL19" + else if Nat_big_num.equal rel_type1 r_aarch64_got_ld64_gotoff_lo15 then + "R_AARCH64_GOT_LD64_GOTOFF_LO15" + else if Nat_big_num.equal rel_type1 r_aarch64_adr_got_page then + "R_AARCH64_ADR_GOT_PAGE" + else if Nat_big_num.equal rel_type1 r_aarch64_ld64_got_lo12_nc then + "R_AARCH64_LD64_GOT_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ld64_gotpage_lo15 then + "R_AARCH64_LD64_GOTPAGE_LO15" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_adr_prel21 then + "R_AARCH64_TLSGD_ADR_PREL21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_adr_page21 then + "R_AARCH64_TLSGD_ADR_PAGE21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_add_lo12_nc then + "R_AARCH64_TLSGD_ADD_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_movw_g1 then + "R_AARCH64_TLSGD_MOVW_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_movw_g0_nc then + "R_AARCH64_TlSGD_MOVW_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_adr_prel21 then + "R_AARCH64_TLSLD_ADR_PREL21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_adr_page21 then + "R_AARCH64_TLSLD_ADR_PAGE21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_lo12_nc then + "R_AARCH64_TLSLD_ADD_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_g1 then + "R_AARCH64_TLSLD_MOVW_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_g0_nc then + "R_AARCH64_TLSLD_MOVW_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ld_prel19 then + "R_AARCH64_TLSLD_LD_PREL19" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g2 then + "R_AARCH64_TLSLD_MOVW_DTPREL_G2" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g1 then + "R_AARCH64_TLSLD_MOVW_DTPREL_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g1_nc then + "R_AARCH64_TLSLD_MOVW_DTPREL_G1_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g0 then + "R_AARCH64_TLSLD_MOVW_DTPREL_G0" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g0_nc then + "R_AARCH64_TLSLD_MOVW_DTPREL_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_dtprel_hi12 then + "R_AARCH64_TLSLD_ADD_DTPREL_HI12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_dtprel_lo12 then + "R_AARCH64_TLSLD_ADD_DTPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_dtprel_lo12_nc then + "R_AARCH64_TLSLD_ADD_DTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst8_dtprel_lo12 then + "R_AARCH64_TLSLD_LDST8_DTPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst8_dtprel_lo12_nc then + "R_AARCH64_TLSLD_LDST8_DTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst16_dtprel_lo12 then + "R_AARCH64_TLSLD_LDST16_DTPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst16_dtprel_lo12_nc then + "R_AARCH64_TLSLD_LDST16_DTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst32_dtprel_lo12 then + "R_AARCH64_TLSLD_LDST32_DTPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst32_dtprel_lo12_nc then + "R_AARCH64_TLSLD_LDST32_DTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst64_dtprel_lo12 then + "R_AARCH64_TLSLD_LDST64_DPTREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst64_dtprel_lo12_nc then + "R_AARCH64_TLSLD_LDST64_DTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst128_dtprel_lo12 then + "R_AARCH64_TLSLD_LDST128_DTPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst128_dtprel_lo12_nc then + "R_AARCH64_TLSLD_LDST128_DTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_g1 then + "R_AARCH64_TLSIE_MOVW_GOTTPREL_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_g0_nc then + "R_AARCH64_TLSIE_MOVW_GOTTPREL_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_page21 then + "R_AARCH64_TLSIE_MOVW_GOTTPREL_PAGE21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_lo12_nc then + "R_AARCH64_TLSIE_MOVW_GOTTPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_prel19 then + "R_AARCH64_TLSIE_MOVW_GOTTPREL_PREL19" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g2 then + "R_AARCH64_TLSLE_MOVW_TPREL_G2" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g1 then + "R_AARCH64_TLSLE_MOVW_TPREL_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g1_nc then + "R_AARCH64_TLSLE_MOVW_TPREL_G1_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g0 then + "R_AARCH64_TLSLE_MOVW_TPREL_G0" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g0_nc then + "R_AARCH64_TLSLE_MOVW_TPREL_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_add_tprel_hi12 then + "R_AARCH64_ADD_TPREL_HI12" + else if Nat_big_num.equal rel_type1 r_aarch64_add_tprel_lo12 then + "R_AARCH64_ADD_TPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_add_tprel_lo12_nc then + "R_AARCH64_ADD_TPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst8_tprel_lo12 then + "R_AARCH64_LDST8_TPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst8_tprel_lo12_nc then + "R_AARCH64_LDST8_TPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst16_tprel_lo12 then + "R_AARCH64_LDST16_TPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst16_tprel_lo12_nc then + "R_AARCH64_LDST16_TPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst32_tprel_lo12 then + "R_AARCH64_LDST32_TPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst32_tprel_lo12_nc then + "R_AARCH64_LDST32_TPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst64_tprel_lo12 then + "R_AARCH64_LDST64_TPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst64_tprel_lo12_nc then + "R_AARCH64_LDST64_TPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst128_tprel_lo12 then + "R_AARCH64_LDST128_TPREL_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_ldst128_tprel_lo12_nc then + "R_AARCH64_LDST128_TPREL_LO12_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_ld_prel19 then + "R_AARCH64_TLSDESC_LS_PREL19" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_adr_prel21 then + "R_AARCH64_TLSDESC_ADR_PREL21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_adr_page21 then + "R_AARCH64_TLSDESC_ADR_PAGE21" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_ld64_lo12 then + "R_AARCH64_TLSDESC_LD64_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_add_lo12 then + "R_AARCH64_TLSDESC_ADD_LO12" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_off_g1 then + "R_AARCH64_TLSDESC_OFF_G1" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_off_g0_nc then + "R_AARCH64_TLSDESC_OFF_G0_NC" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_ldr then + "R_AARCH64_TLSDESC_LDR" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_add then + "R_AARCH64_TLSDESC_ADD" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_call then + "R_AARCH64_TLSDESC_CALL" + else if Nat_big_num.equal rel_type1 r_aarch64_copy then + "R_AARCH64_COPY" + else if Nat_big_num.equal rel_type1 r_aarch64_glob_dat then + "R_AARCH64_GLOB_DAT" + else if Nat_big_num.equal rel_type1 r_aarch64_jump_slot then + "R_AARCH64_JUMP_SLOT" + else if Nat_big_num.equal rel_type1 r_aarch64_relative then + "R_AARCH64_RELATIVE" + else if Nat_big_num.equal rel_type1 r_aarch64_tls_dtprel64 then + "R_AARCH64_DTPREL64" + else if Nat_big_num.equal rel_type1 r_aarch64_tls_dtpmod64 then + "R_AARCH64_DTPMOD64" + else if Nat_big_num.equal rel_type1 r_aarch64_tls_tprel64 then + "R_AARCH64_TPREL64" + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc then + "R_AARCH64_TLSDESC" + else if Nat_big_num.equal rel_type1 r_aarch64_irelative then + "R_AARCH64_IRELATIVE" + else + "Invalid AARCH64 relocation type") + +(*val aarch64_le_reloc : forall 'abifeature. reloc_fn 'abifeature*) +let aarch64_le_reloc r:bool*('abifeature annotated_memory_image ->Nat_big_num.num ->symbol_reference_and_reloc_site ->Nat_big_num.num*(Nat_big_num.num ->Nat_big_num.num ->Nat_big_num.num ->Nat_big_num.num))= + (if Nat_big_num.equal r r_aarch64_none then + (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 0, (fun s -> fun a -> fun e -> e)))))) + else + (false, noop_reloc_apply)) + +(** [abi_aarch64_apply_relocation rel s_val p_val got_val ef] produces an AST + * of the relocation calculation for relocation type [rel] using [s_val], [p_val], + * and [got_val] as primitive components. + * + * TODO: unclear from ABI spec. whether overflow check on relocations is + * supposed to cause relocation to fail if not satisfied or whether there is + * wrap-around. Resolve. + *) +(*val abi_aarch64_apply_relocation : elf64_relocation_a -> integer -> integer -> + integer -> elf64_file -> + error (Map.map elf64_addr (relocation_operator_expression integer * integer_bit_width * can_fail integer))*) +let abi_aarch64_apply_relocation rel s_val p_val got_val ef:(((Uint64.uint64),((Nat_big_num.num)relocation_operator_expression*integer_bit_width*(Nat_big_num.num)can_fail))Pmap.map)error= + (if is_elf64_relocatable_file ef.elf64_file_header then + let rel_type1 = (get_elf64_relocation_a_type rel) in + let a_val = (Nat_big_num.of_int64 rel.elf64_ra_addend) in + (** No width, no calculation *) + if Nat_big_num.equal rel_type1 r_aarch64_none then + return (Pmap.empty compare) + (** No width, no calculation *) + else if Nat_big_num.equal rel_type1 r_aarch64_withdrawn then + return (Pmap.empty compare) + (** Signed 64 bit width, calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_aarch64_abs64 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Signed 32 bit width, calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_aarch64_abs32 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Signed 16 bith width, calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_aarch64_abs16 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Signed 64 bit width, calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_aarch64_prel64 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Signed 32 bit width, calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_aarch64_prel32 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Signed 16 bit width, calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_aarch64_prel16 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g0 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g0_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g1 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g1_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g2 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U48, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g2_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U48, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_uabs_g3 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_sabs_g0 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_sabs_g1 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_sabs_g2 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I48, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ld_prel_lo19 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_adr_prel_lo21 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_adr_prel_pg_hi21 then + let result = (Minus(Apply(Page, Lift ( Nat_big_num.add s_val a_val)), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_adr_prel_pg_hi21_nc then + let result = (Minus (Apply(Page, Lift ( Nat_big_num.add s_val a_val)), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_add_abs_lo12_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst8_abs_lo12_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst16_abs_lo12_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst32_abs_lo12_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst64_abs_lo12_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst128_abs_lo12_nc then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tstbr14 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_condbr19 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_jump26 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I27, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_call26 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I27, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g0 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g0_nc then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g1 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g1_nc then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g2 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I48, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g2_nc then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I48, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_prel_g3 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g0 then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g0_nc then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g1 then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g1_nc then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g2 then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I48, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g2_nc then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_movw_gotoff_g3 then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_gotrel64 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_gotrel32 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_got_ld_prel19 then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_got_ld64_gotoff_lo15 then + let result = (Minus (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_adr_got_page then + let result = (Minus (Apply(Page, Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val)))), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ld64_got_lo12_nc then + (** requires ad hoc check *) + let result = (Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val)))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ld64_gotpage_lo15 then + (** requires ad hoc check *) + let result = (Minus(Apply(G, Apply(GDat, Lift ( Nat_big_num.add s_val a_val))), Apply(Page, Lift got_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_adr_prel21 then + let result = (Minus(Apply(G, Apply2(GTLSIdx, Lift s_val, Lift a_val)), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_adr_page21 then + let result = (Minus(Apply(Page, Apply(G, Apply2(GTLSIdx, Lift s_val, Lift a_val))), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_add_lo12_nc then + let result = (Apply(G, Apply2(GTLSIdx, Lift s_val, Lift a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_movw_g1 then + (** requires ad hoc check *) + let result = (Minus(Apply(G, Apply2(GTLSIdx, Lift s_val, Lift a_val)), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsgd_movw_g0_nc then + let result = (Minus(Apply(G, Apply2 (GTLSIdx, Lift s_val, Lift a_val)), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_adr_prel21 then + let result = (Minus(Apply(G, Apply(GLDM, Lift s_val)), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_adr_page21 then + let result = (Minus(Apply(G, Apply(GLDM, Lift s_val)), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_lo12_nc then + let result = (Apply(G, Apply(GLDM, Lift s_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_g1 then + let result = (Minus(Apply(G, Apply(GLDM, Lift s_val)), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_g0_nc then + let result = (Minus(Apply(G, Apply(GLDM, Lift s_val)), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ld_prel19 then + let result = (Minus(Apply(G, Apply(GLDM, Lift s_val)), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g2 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g1 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g1_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g0 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_movw_dtprel_g0_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_dtprel_hi12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U24, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_dtprel_lo12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_add_dtprel_lo12_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst8_dtprel_lo12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst8_dtprel_lo12_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst16_dtprel_lo12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst16_dtprel_lo12_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst32_dtprel_lo12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst32_dtprel_lo12_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst64_dtprel_lo12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst64_dtprel_lo12_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst128_dtprel_lo12 then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsld_ldst128_dtprel_lo12_nc then + let result = (Apply(DTPRel, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_g1 then + let result = (Minus(Apply(G, Apply(GTPRel, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_g0_nc then + let result = (Minus(Apply(G, Apply(GTPRel, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I15, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_page21 then + let result = (Minus(Apply(Page, Apply(G, Apply(GTPRel, Lift ( Nat_big_num.add s_val a_val)))), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_lo12_nc then + (** requires ad hoc check *) + let result = (Apply(G, Apply(GTPRel, Lift ( Nat_big_num.add s_val a_val)))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I8, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsie_movw_gottprel_prel19 then + let result = (Minus(Apply(G, Apply(GTPRel, Lift ( Nat_big_num.add s_val a_val))), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g2 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g1 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g1_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g0 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsle_movw_tprel_g0_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_add_tprel_hi12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U24, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_add_tprel_lo12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_add_tprel_lo12_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst8_tprel_lo12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst8_tprel_lo12_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst16_tprel_lo12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst16_tprel_lo12_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst32_tprel_lo12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst32_tprel_lo12_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst64_tprel_lo12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst64_tprel_lo12_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst128_tprel_lo12 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_ldst128_tprel_lo12_nc then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, U12, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_ld_prel19 then + (** requires ad hoc test *) + let result = (Minus(Apply(G, Apply(GTLSDesc, Lift ( Nat_big_num.add s_val a_val))), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_adr_prel21 then + let result = (Minus (Apply(G, Apply(GTLSDesc, Lift ( Nat_big_num.add s_val a_val))), Lift p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_adr_page21 then + let result = (Minus(Apply(Page, Apply(G, Apply(GTLSDesc, Lift( Nat_big_num.add s_val a_val)))), Apply(Page, Lift p_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_ld64_lo12 then + (** requires ad hoc test *) + let result = (Apply(G, Apply(GTLSDesc, Lift ( Nat_big_num.add s_val a_val)))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I20, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_add_lo12 then + let result = (Apply(G, Apply(GTLSDesc, Lift ( Nat_big_num.add s_val a_val)))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_off_g1 then + let result = (Minus(Apply(G, Apply(GTLSDesc, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_off_g0_nc then + let result = (Minus(Apply(G, Apply(GTLSDesc, Lift ( Nat_big_num.add s_val a_val))), Lift got_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_ldr then + return (Pmap.empty compare) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_add then + return (Pmap.empty compare) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc_call then + return (Pmap.empty compare) + else if Nat_big_num.equal rel_type1 r_aarch64_copy then + fail "AARCH64_COPY" + else if Nat_big_num.equal rel_type1 r_aarch64_glob_dat then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_jump_slot then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_relative then + let result = (Plus(Apply(Delta, Lift s_val), Lift a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tls_dtprel64 then + let result = (Apply(DTPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tls_dtpmod64 then + let result = (Apply(LDM, Lift s_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tls_tprel64 then + let result = (Apply(TPRel, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_tlsdesc then + let result = (Apply(TLSDesc, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_aarch64_irelative then + let result = (Apply(Indirect, Plus (Apply(Delta, Lift s_val), Lift a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else + fail "Invalid AARCH64 relocation type" + else + fail "abi_aarch64_apply_relocation: not a relocatable file") diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_section_header_table.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_section_header_table.ml new file mode 100644 index 00000000..5716a83f --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_section_header_table.ml @@ -0,0 +1,25 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_section_header_table.lem.*) +(** [abi_aarch64_section_header_table], AARCH64 ABI specific definitions related + * to the section header table. + *) + +open Lem_basic_classes +open Lem_num + +(** AARCH64 specific section types *) + +(** Contains build attributes. What these are is not specified, and compilers + * are free to insert their own proprietary information in this section. See + * Section 4.3. + *) +let sht_aarch64_attributes : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524097)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (* 0x70000003 *) + +(** [string_of_aarch64_section_type m] produces a string based representation of + * AARCH64 section type [m]. + *) +(*val string_of_aarch64_section_type : natural -> string*) +let string_of_aarch64_section_type m:string= + (if Nat_big_num.equal m sht_aarch64_attributes then + ".ARM.attributes" + else + "Unrecognised section type") diff --git a/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_symbol_table.ml b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_symbol_table.ml new file mode 100644 index 00000000..35428632 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_symbol_table.ml @@ -0,0 +1,23 @@ +(*Generated by Lem from abis/aarch64/abi_aarch64_symbol_table.lem.*) +(** [abi_aarch64_symbol_table], symbol table specific defintions for the AARCH64 + * ABI. + *) + +open Lem_basic_classes +open Lem_bool + +open Elf_header +open Elf_symbol_table +open Elf_section_header_table +open Elf_types_native_uint + +(** Two types of weak symbol are defined in the AARCH64 ABI. See Section 4.5. + *) +(*val is_aarch64_weak_reference : elf64_symbol_table_entry -> bool*) +let is_aarch64_weak_reference ent:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string ent.elf64_st_shndx)) shn_undef && Nat_big_num.equal +(get_elf64_symbol_binding ent) stb_weak) + +(*val is_aarch64_weak_definition : elf64_symbol_table_entry -> bool*) +let is_aarch64_weak_definition ent:bool= (not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_shndx)) shn_undef) && Nat_big_num.equal +(get_elf64_symbol_binding ent) stb_weak) diff --git a/lib/ocaml_rts/linksem/abis/abi_classes.ml b/lib/ocaml_rts/linksem/abis/abi_classes.ml new file mode 100644 index 00000000..7b8b8876 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/abi_classes.ml @@ -0,0 +1,4 @@ +(*Generated by Lem from abis/abi_classes.lem.*) +type 'a abiFeatureTagEquiv_class={ + abiFeatureTagEquiv_method : 'a -> 'a -> bool +} diff --git a/lib/ocaml_rts/linksem/abis/abi_utilities.ml b/lib/ocaml_rts/linksem/abis/abi_utilities.ml new file mode 100644 index 00000000..02dd9fab --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/abi_utilities.ml @@ -0,0 +1,213 @@ +(*Generated by Lem from abis/abi_utilities.lem.*) +(** [abi_utilities], generic utilities shared between all ABIs. + *) + +open Lem_map +open Lem_maybe +open Lem_num +open Lem_basic_classes +open Lem_maybe +open Lem_string +open Error +open Lem_assert_extra + +open Abi_classes +open Missing_pervasives +open Elf_types_native_uint +open Elf_symbol_table +open Elf_relocation +open Memory_image +open Memory_image_orderings + + +open Error + +(** [integer_bit_width] records various bit widths for integral types, as used + * in relocation calculations. The names are taken directly from the processor + * supplements to keep the calculations as close as possible + * to the specification of relocations. + *) +type integer_bit_width + = I8 (** Signed 8 bit *) + | I12 + | U12 (** Unsigned 12 bit *) + | Low14 + | U15 (** Unsigned 15 bit *) + | I15 + | I16 (** Signed 16 bit *) + | Half16ds + | I20 (** Signed 20 bit *) + | Low24 + | I27 + | Word30 + | I32 (** Signed 32 bit *) + | I48 (** Signed 48 bit *) + | I64 (** Signed 64 bit *) + | I64X2 (** Signed 128 bit *) + | U16 (** Unsigned 16 bit *) + | U24 (** Unsigned 24 bit *) + | U32 (** Unsigned 32 bit *) + | U48 (** Unsigned 48 bit *) + | U64 (** Unsigned 64 bit *) + +(** [natural_of_integer_bit_width i] computes the bit width of integer bit width + * [i]. + *) +(*val natural_of_integer_bit_width : integer_bit_width -> natural*) +let natural_of_integer_bit_width i:Nat_big_num.num= + ((match i with + | I8 ->Nat_big_num.of_int 8 + | I12 ->Nat_big_num.of_int 12 + | U12 ->Nat_big_num.of_int 12 + | Low14 ->Nat_big_num.of_int 14 + | I15 ->Nat_big_num.of_int 15 + | U15 ->Nat_big_num.of_int 15 + | I16 ->Nat_big_num.of_int 16 + | Half16ds ->Nat_big_num.of_int 16 + | U16 ->Nat_big_num.of_int 16 + | I20 ->Nat_big_num.of_int 20 + | Low24 ->Nat_big_num.of_int 24 + | U24 ->Nat_big_num.of_int 24 + | I27 ->Nat_big_num.of_int 27 + | Word30 ->Nat_big_num.of_int 30 + | I32 ->Nat_big_num.of_int 32 + | U32 ->Nat_big_num.of_int 32 + | I48 ->Nat_big_num.of_int 48 + | U48 ->Nat_big_num.of_int 48 + | I64 ->Nat_big_num.of_int 64 + | U64 ->Nat_big_num.of_int 64 + | I64X2 ->Nat_big_num.of_int 128 + )) + +(** [relocation_operator] records the operators used to calculate relocations by + * the various ABIs. Each ABI will only use a subset of these, and they should + * be interpreted on a per-ABI basis. As more ABIs are added, more operators + * will be needed, and therefore more constructors in this type will need to + * be added. These are unary operators, operating on a single integral type. + *) +type relocation_operator + = TPRel + | LTOff + | DTPMod + | DTPRel + | Page + | GDat + | G + | GLDM + | GTPRel + | GTLSDesc + | Delta + | LDM + | TLSDesc + | Indirect + | Lo + | Hi + | Ha + | Higher + | HigherA + | Highest + | HighestA + +(** [relocation_operator2] is a binary relocation operator, as detailed above. + *) +type relocation_operator2 = + | GTLSIdx + +(** Generalising and abstracting over relocation calculations and their return + * types + *) + +type( 'k, 'v) val_map = ('k, 'v) + Pmap.map + +(*val lookupM : forall 'k 'v. MapKeyType 'k => 'k -> val_map 'k 'v -> error 'v*) +let lookupM dict_Map_MapKeyType_k key val_map1:'v error= + ((match Pmap.lookup key val_map1 with + | None -> fail "lookupM: key not found in val_map" + | Some j -> return j + )) + +(** Some relocations may fail, for example: + * Page 58, Power ABI: relocation types whose Field column is marked with an + * asterisk are subject to failure is the value computed does not fit in the + * allocated bits. [can_fail] type passes this information back to the caller + * of the relocation application function. + *) +type 'a can_fail + = CanFail (** [CanFail] signals a potential failing relocation calculation when width constraints are invalidated *) + | CanFailOnTest of ('a -> bool) (** [CanFailOnTest p] signals a potentially failing relocation calculation when predicate [p] on the result of the calculation returns [false] *) + | CannotFail (** [CannotFail] states the relocation calculation cannot fail and bit-width constraints should be ignored *) + +(** [relocation_operator_expression] is an AST of expressions describing a relocation + * calculation. An AST is used as it allows us to unify the treatment of relocation + * calculation: rather than passing in dozens of functions to the calculation function + * that perform the actual relocation, we can simply return a description (in the form + * of the AST below) of the calculation to be carried out and have it interpreted + * separately from the function that produces it. The type parameter 'a is the + * type of base integral type. This AST suffices for the relocation calculations we + * currently have implemented, but adding more ABIs may require that this type is + * expanded. + *) +type 'a relocation_operator_expression + = Lift of 'a (** Lift a base type into an AST *) + | Apply of (relocation_operator * 'a relocation_operator_expression) (** Apply a unary operator to an expression *) + | Apply2 of (relocation_operator2 * 'a relocation_operator_expression * 'a relocation_operator_expression) (** Apply a binary operator to two expressions *) + | Plus of ( 'a relocation_operator_expression * 'a relocation_operator_expression) (** Add two expressions. *) + | Minus of ( 'a relocation_operator_expression * 'a relocation_operator_expression) (** Subtract two expressions. *) + | RShift of ( 'a relocation_operator_expression * Nat_big_num.num) (** Right shift the result of an expression [m] places. *) + +type( 'addr, 'res) relocation_frame = + | Copy + | NoCopy of ( ('addr, ( 'res relocation_operator_expression * integer_bit_width * 'res can_fail))Pmap.map) + +(*val size_of_def : symbol_reference_and_reloc_site -> natural*) +let size_of_def rr:Nat_big_num.num= + (let rf = (rr.ref) in + let sm = (rf.ref_syment) in + Ml_bindings.nat_big_num_of_uint64 sm.elf64_st_size) + +(*val size_of_copy_reloc : forall 'abifeature. annotated_memory_image 'abifeature -> symbol_reference_and_reloc_site -> natural*) +let size_of_copy_reloc img2 rr:Nat_big_num.num= +( + (* it's the minimum of the two definition symbol sizes. FIXME: for now, just use the rr *)size_of_def rr) + +(*val reloc_site_address : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => + annotated_memory_image 'abifeature -> symbol_reference_and_reloc_site -> natural*) +let reloc_site_address dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2 rr:Nat_big_num.num= +( + (* find the element range that's tagged with this reloc site *)let found_kvs = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + dict_Basic_classes_Ord_abifeature) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (=) (SymbolRef(rr)) img2.by_tag) + in + (match found_kvs with + [] -> failwith "impossible: reloc site not marked in memory image" + | [(_, maybe_range)] -> (match maybe_range with + None -> failwith "impossible: reloc site has no element range" + | Some (el_name, el_range) -> + let element_addr = ((match Pmap.lookup el_name img2.elements with + None -> failwith "impossible: non-existent element" + | Some el -> (match el.startpos with + None -> failwith "error: resolving relocation site address before address has been assigned" + | Some addr -> addr + ) + )) + in + let site_offset = (* match rr.maybe_reloc with + Just reloc -> natural_of_elf64_addr reloc.ref_relent.elf64_ra_offset + | Nothing -> failwith "symbol reference with range but no reloc site" + end*) (let (start, _) = el_range in start) + in Nat_big_num.add + element_addr site_offset + ) + | _ -> failwith "error: more than one address with identical relocation record" + )) diff --git a/lib/ocaml_rts/linksem/abis/abis.ml b/lib/ocaml_rts/linksem/abis/abis.ml new file mode 100644 index 00000000..0cbd92d8 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/abis.ml @@ -0,0 +1,1420 @@ +(*Generated by Lem from abis/abis.lem.*) +(** The [abis] module is the top-level module for all ABI related code, including + * some generic functionality that works across all ABIs, and a primitive attempt + * at abstracting over ABIs for purposes of linking. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_num +open Lem_maybe +open Lem_list +open Lem_set +(*import Map*) +open Lem_string +open Show +open Lem_assert_extra +open Error +open Missing_pervasives + +open Elf_file +open Elf_header +open Elf_interpreted_section +open Elf_relocation +open Elf_symbol_table +open Elf_program_header_table +open Elf_section_header_table +open Memory_image + +open Abi_amd64 +open Abi_amd64_relocation + +open Abi_aarch64_le +open Abi_aarch64_relocation + +open Abi_power64 +open Abi_power64_relocation + +open Gnu_ext_abi + +open Abi_classes +open Abi_utilities +open Elf_types_native_uint + +open Memory_image_orderings + +(** Relocation operators and their validity on a given platform *) + +(*val is_valid_abi_aarch64_relocation_operator : relocation_operator -> bool*) +let is_valid_abi_aarch64_relocation_operator op:bool= + ((match op with + | Page -> true + | G -> true + | GDat -> true + | GLDM -> true + | DTPRel -> true + | GTPRel -> true + | TPRel -> true + | GTLSDesc -> true + | Delta -> true + | LDM -> true + | TLSDesc -> true + | Indirect -> true + | _ -> false + )) + +(*val is_valid_abi_aarch64_relocation_operator2 : relocation_operator2 -> bool*) +let is_valid_abi_aarch64_relocation_operator2 op:bool= + ((match op with + | GTLSIdx -> true + )) + +(*val is_valid_abi_amd64_relocation_operator : relocation_operator -> bool*) +let is_valid_abi_amd64_relocation_operator op:bool= + ((match op with + | Indirect -> true + | _ -> false (* XXX: not sure about this? *) + )) + +(*val is_valid_abi_amd64_relocation_operator2 : relocation_operator2 -> bool*) +let is_valid_abi_amd64_relocation_operator2 op:bool= + ((match op with + | _ -> false + )) + +(*val is_valid_abi_power64_relocation_operator : relocation_operator -> bool*) +let is_valid_abi_power64_relocation_operator op:bool= false (* TODO *) + +(*val is_valid_abi_power64_relocation_operator2 : relocation_operator2 -> bool*) +let is_valid_abi_power64_relocation_operator2 op:bool= + ((match op with + | _ -> false + )) + +(** Misc. ABI related stuff *) + +type any_abi_feature = Amd64AbiFeature of any_abi_feature amd64_abi_feature + | Aarch64LeAbiFeature of aarch64_le_abi_feature + +(*val anyAbiFeatureCompare : any_abi_feature -> any_abi_feature -> Basic_classes.ordering*) +let anyAbiFeatureCompare f1 f2:int= + ((match (f1, f2) with + (Amd64AbiFeature(af1), Amd64AbiFeature(af2)) -> Abi_amd64.abiFeatureCompare0 af1 af2 + |(Amd64AbiFeature(_), _) -> (-1) + |(Aarch64LeAbiFeature(af1), Amd64AbiFeature(af2)) -> 1 + |(Aarch64LeAbiFeature(af1), Aarch64LeAbiFeature(af2)) -> abiFeatureCompare af1 af2 + )) + +(*val anyAbiFeatureTagEquiv : any_abi_feature -> any_abi_feature -> bool*) +let anyAbiFeatureTagEquiv f1 f2:bool= + ((match (f1, f2) with + (Amd64AbiFeature(af1), Amd64AbiFeature(af2)) -> Abi_amd64.abiFeatureTagEq0 af1 af2 + |(Amd64AbiFeature(_), _) -> false + |(Aarch64LeAbiFeature(af1), Amd64AbiFeature(af2)) -> false + |(Aarch64LeAbiFeature(af1), Aarch64LeAbiFeature(af2)) -> abiFeatureTagEq af1 af2 + )) + +let instance_Basic_classes_Ord_Abis_any_abi_feature_dict:(any_abi_feature)ord_class= ({ + + compare_method = anyAbiFeatureCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(anyAbiFeatureCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (anyAbiFeatureCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(anyAbiFeatureCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (anyAbiFeatureCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +let instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict:(any_abi_feature)abiFeatureTagEquiv_class= ({ + + abiFeatureTagEquiv_method = anyAbiFeatureTagEquiv}) + +let make_elf64_header data osabi abiv ma t entry shoff phoff phnum shnum shstrndx:elf64_header= + ({ elf64_ident = ([elf_mn_mag0; elf_mn_mag1; elf_mn_mag2; elf_mn_mag3; + Uint32.of_string (Nat_big_num.to_string elf_class_64); + Uint32.of_string (Nat_big_num.to_string data); + Uint32.of_string (Nat_big_num.to_string elf_ev_current); + Uint32.of_string (Nat_big_num.to_string osabi); + Uint32.of_string (Nat_big_num.to_string abiv); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))]) + ; elf64_type = (Uint32.of_string (Nat_big_num.to_string t)) + ; elf64_machine = (Uint32.of_string (Nat_big_num.to_string ma)) + ; elf64_version = (Uint32.of_string (Nat_big_num.to_string elf_ev_current)) + ; elf64_entry = (Uint64.of_string (Nat_big_num.to_string entry)) + ; elf64_phoff = (Uint64.of_string (Nat_big_num.to_string phoff)) + ; elf64_shoff = (Uint64.of_string (Nat_big_num.to_string shoff)) + ; elf64_flags = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_ehsize = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 64))) + ; elf64_phentsize= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 56))) + ; elf64_phnum = (Uint32.of_string (Nat_big_num.to_string phnum)) + ; elf64_shentsize= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 64))) + ; elf64_shnum = (Uint32.of_string (Nat_big_num.to_string shnum)) + ; elf64_shstrndx = (Uint32.of_string (Nat_big_num.to_string shstrndx)) + }) + +(*val phdr_flags_from_section_flags : natural -> string -> natural*) +let phdr_flags_from_section_flags section_flags sec_name:Nat_big_num.num= + (let flags = (Nat_big_num.bitwise_or elf_pf_r (Nat_big_num.bitwise_or + (if flag_is_set shf_write section_flags then elf_pf_w else Nat_big_num.of_int 0) + (if flag_is_set shf_execinstr section_flags then elf_pf_x else Nat_big_num.of_int 0))) + in + (*let _ = errln ("Phdr flags of section " ^ sec_name ^ "(ELF section flags 0x " ^ + (hex_string_of_natural section_flags) ^ ") are 0x" ^ (hex_string_of_natural flags)) + in*) + flags) + +(*val phdr_is_writable : natural -> bool*) +let phdr_is_writable flags:bool= (Nat_big_num.equal + (Nat_big_num.bitwise_and flags elf_pf_w) elf_pf_w) + +type can_combine_flags_fn = Nat_big_num.num Pset.set -> Nat_big_num.num option + +(* FIXME: lift this to a personality function of the GNU linker? + * Not sure really... need to try some other linkers. *) +(*val load_can_combine_flags : can_combine_flags_fn*) +let load_can_combine_flags flagsets:(Nat_big_num.num)option= +( + (* The GNU linker happily adds a .rodata section to a RX segment, + * but not to a RW segment. So the only clear rule is: if any is writable, + * all must be writable. *)let flagslist = (Pset.elements flagsets) + in + let union_flags = (List.fold_left Nat_big_num.bitwise_or(Nat_big_num.of_int 0) flagslist) + in + if List.exists phdr_is_writable flagslist + then + if List.for_all phdr_is_writable flagslist then Some union_flags + else None + else + Some union_flags) + +(*val tls_can_combine_flags : can_combine_flags_fn*) +let tls_can_combine_flags flagsets:(Nat_big_num.num)option= (Some (List.fold_left Nat_big_num.bitwise_or(Nat_big_num.of_int 0) (Pset.elements flagsets))) + +let maybe_extend_phdr phdr isec1 can_combine_flags:(elf64_program_header_table_entry)option= + (let new_p_type = (Nat_big_num.of_string (Uint32.to_string phdr.elf64_p_type)) + in + let this_section_phdr_flags = (phdr_flags_from_section_flags isec1.elf64_section_flags isec1.elf64_section_name_as_string) + in + let maybe_extended_flags = (can_combine_flags(Pset.from_list Nat_big_num.compare [ this_section_phdr_flags; Nat_big_num.of_string (Uint32.to_string phdr.elf64_p_flags) ])) + in + if (Lem.option_equal Nat_big_num.equal maybe_extended_flags None) then (*let _ = errln "flag mismatch" in*) None + else let new_p_flags = ((match maybe_extended_flags with Some flags -> flags | _ -> failwith "impossible" )) + in + (* The new filesz is the file end offset of this section, + * minus the existing file start offset of the phdr. + * Check that the new section begins after the old offset+filesz. *) + if Nat_big_num.less isec1.elf64_section_offset (Nat_big_num.add (Nat_big_num.of_string (Uint64.to_string phdr.elf64_p_offset)) (Ml_bindings.nat_big_num_of_uint64 phdr.elf64_p_filesz)) + then (*let _ = errln "offset went backwards" in*) None + else + let new_p_filesz = (Nat_big_num.add (Ml_bindings.nat_big_num_of_uint64 phdr.elf64_p_filesz) (if Nat_big_num.equal isec1.elf64_section_type sht_progbits then isec1.elf64_section_size else Nat_big_num.of_int 0)) + in + (* The new memsz is the virtual address end address of this section, + * minus the existing start vaddr of the phdr. + * Check that the new section begins after the old vaddr+memsz. *) + if Nat_big_num.less isec1.elf64_section_addr (Nat_big_num.add (Ml_bindings.nat_big_num_of_uint64 phdr.elf64_p_vaddr) (Ml_bindings.nat_big_num_of_uint64 phdr.elf64_p_memsz)) + then (*let _ = errln "vaddr went backwards" in*) None + else + let new_p_memsz = (Nat_big_num.add (Ml_bindings.nat_big_num_of_uint64 phdr.elf64_p_memsz) isec1.elf64_section_size) + in + let (one_if_zero : Nat_big_num.num -> Nat_big_num.num) = (fun n -> if Nat_big_num.equal n(Nat_big_num.of_int 0) then Nat_big_num.of_int 1 else n) + in + let new_p_align = (lcm (one_if_zero (Ml_bindings.nat_big_num_of_uint64 phdr.elf64_p_align)) (one_if_zero isec1.elf64_section_align)) + in + Some + { elf64_p_type = (Uint32.of_string (Nat_big_num.to_string new_p_type)) + ; elf64_p_flags = (Uint32.of_string (Nat_big_num.to_string new_p_flags)) + ; elf64_p_offset = (phdr.elf64_p_offset) + ; elf64_p_vaddr = (phdr.elf64_p_vaddr) + ; elf64_p_paddr = (phdr.elf64_p_paddr) + ; elf64_p_filesz = (Uint64.of_string (Nat_big_num.to_string new_p_filesz)) + ; elf64_p_memsz = (Uint64.of_string (Nat_big_num.to_string new_p_memsz)) + ; elf64_p_align = (Uint64.of_string (Nat_big_num.to_string new_p_align)) + }) + +let make_new_phdr isec1 t maxpagesize1 commonpagesize1:elf64_program_header_table_entry= + (let rounded_down_offset = (fun isec1 -> round_down_to commonpagesize1 isec1.elf64_section_offset) + in + let offset_round_down_amount = (fun isec1 -> Nat_big_num.sub_nat isec1.elf64_section_offset (rounded_down_offset isec1)) + in + let rounded_down_vaddr = (fun isec1 -> round_down_to commonpagesize1 isec1.elf64_section_addr) + in + let vaddr_round_down_amount = (fun isec1 -> Nat_big_num.sub_nat isec1.elf64_section_addr (rounded_down_vaddr isec1)) + in + { elf64_p_type = (Uint32.of_string (Nat_big_num.to_string t)) (** Type of the segment *) + ; elf64_p_flags = (Uint32.of_string (Nat_big_num.to_string (phdr_flags_from_section_flags isec1.elf64_section_flags isec1.elf64_section_name_as_string))) (** Segment flags *) + ; elf64_p_offset = (Uint64.of_string (Nat_big_num.to_string (rounded_down_offset isec1))) (** Offset from beginning of file for segment *) + ; elf64_p_vaddr = (Uint64.of_string (Nat_big_num.to_string (rounded_down_vaddr isec1))) (** Virtual address for segment in memory *) + ; elf64_p_paddr = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (** Physical address for segment *) + ; elf64_p_filesz = (Uint64.of_string (Nat_big_num.to_string (if Nat_big_num.equal isec1.elf64_section_type sht_nobits then Nat_big_num.of_int 0 else Nat_big_num.add isec1.elf64_section_size (offset_round_down_amount isec1)))) (** Size of segment in file, in bytes *) + ; elf64_p_memsz = (Uint64.of_string (Nat_big_num.to_string ( Nat_big_num.add isec1.elf64_section_size (vaddr_round_down_amount isec1)))) (** Size of segment in memory image, in bytes *) + ; elf64_p_align = (Uint64.of_string (Nat_big_num.to_string (* isec.elf64_section_align *)maxpagesize1)) (** Segment alignment memory for memory and file *) + }) + +(*val make_load_phdrs : forall 'abifeature. natural -> natural -> annotated_memory_image 'abifeature -> list elf64_interpreted_section -> list elf64_program_header_table_entry*) +let make_load_phdrs maxpagesize1 commonpagesize1 img2 section_pairs_bare_sorted_by_address:(elf64_program_header_table_entry)list= +( + (* accumulate sections into the phdr *)let rev_list = (List.fold_left (fun accum_phdr_list -> (fun isec1 -> ( + (* Do we have a current phdr? *) + (match accum_phdr_list with + [] -> (* no, so make one *) + (*let _ = errln ("Starting the first LOAD phdr for section " ^ isec.elf64_section_name_as_string) + in*) + [make_new_phdr isec1 elf_pt_load maxpagesize1 commonpagesize1] + | current_phdr :: more -> + (* can we extend it with the current section? *) + (match maybe_extend_phdr current_phdr isec1 load_can_combine_flags with + None -> + (*let _ = errln ("Starting new LOAD phdr for section " ^ isec.elf64_section_name_as_string) + in*) + (make_new_phdr isec1 elf_pt_load maxpagesize1 commonpagesize1) :: (current_phdr :: more) + | Some phdr -> phdr :: more + ) + ) + ))) [] (List.filter (fun isec1 -> flag_is_set shf_alloc isec1.elf64_section_flags + && not (flag_is_set shf_tls isec1.elf64_section_flags)) section_pairs_bare_sorted_by_address)) + in + (*let _ = errln "Successfully made phdrs" + in*) + List.rev rev_list) + +(*val tls_extend: forall 'abifeature. abi 'abifeature -> abi 'abifeature*) +let tls_extend a:'abifeature abi= + ({ is_valid_elf_header = (a.is_valid_elf_header) + ; make_elf_header = (a.make_elf_header) + ; reloc = (a.reloc) + ; section_is_special = (a.section_is_special) + ; section_is_large = (a.section_is_large) + ; maxpagesize = (a.maxpagesize) + ; minpagesize = (a.minpagesize) + ; commonpagesize = (a.commonpagesize) + ; symbol_is_generated_by_linker = (a.symbol_is_generated_by_linker) + ; make_phdrs = (fun maxpagesize1 -> fun commonpagesize1 -> fun file_type -> fun img2 -> fun section_pairs_bare_sorted_by_address -> ( + let rev_list = (List.fold_left (fun accum_phdr_list -> (fun isec1 -> ( + (match accum_phdr_list with + [] -> + (*let _ = errln "Making a new TLS program header" in*) + [make_new_phdr isec1 elf_pt_tls maxpagesize1 commonpagesize1] + | current_phdr :: more -> + (match maybe_extend_phdr current_phdr isec1 tls_can_combine_flags with + None -> + (make_new_phdr isec1 elf_pt_tls maxpagesize1 commonpagesize1) :: (current_phdr :: more) + | Some phdr -> phdr :: more + ) + ) + ))) [] (List.filter (fun isec1 -> flag_is_set shf_alloc isec1.elf64_section_flags + && flag_is_set shf_tls isec1.elf64_section_flags) section_pairs_bare_sorted_by_address)) + in + List.rev_append (List.rev (a.make_phdrs maxpagesize1 commonpagesize1 file_type img2 section_pairs_bare_sorted_by_address)) (List.rev rev_list) + )) + ; max_phnum = (Nat_big_num.add(Nat_big_num.of_int 1) a.max_phnum) + ; guess_entry_point = (a.guess_entry_point) + ; pad_data = (a.pad_data) + ; pad_code = (a.pad_code) + ; generate_support = (a.generate_support) + ; concretise_support = (a.concretise_support) + ; get_reloc_symaddr = (a.get_reloc_symaddr) + }) + +(* We use these snappily-named functions in relocation calculations. *) + +(*val make_default_phdrs : forall 'abifeature. natural -> natural -> natural (* file type *) -> annotated_memory_image 'abifeature -> list elf64_interpreted_section -> list elf64_program_header_table_entry*) +let make_default_phdrs maxpagesize1 commonpagesize1 t img2 section_pairs_bare_sorted_by_address:(elf64_program_header_table_entry)list= +( + (* FIXME: do the shared object and dyn. exec. stuff too *)make_load_phdrs maxpagesize1 commonpagesize1 img2 section_pairs_bare_sorted_by_address) + +(*val find_start_symbol_address : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => annotated_memory_image 'abifeature -> maybe natural*) +let find_start_symbol_address dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2:(Nat_big_num.num)option= +( + (* Do we have a symbol called "_start"? *)let all_defs = (Memory_image_orderings.defined_symbols_and_ranges + dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2) + in + let get_entry_point = (fun (maybe_range, symbol_def) -> + if symbol_def.def_symname = "_start" + then Some (maybe_range, symbol_def) + else None + ) + in + let all_entry_points = (Lem_list.mapMaybe get_entry_point all_defs) + in + (match all_entry_points with + [(maybe_range, symbol_def)] -> + (match maybe_range with + Some (el_name, (el_off, len)) -> + (match Pmap.lookup el_name img2.elements with + None -> failwith ("_start symbol defined in nonexistent element `" ^ (el_name ^ "'")) + | Some el_rec -> + (match el_rec.startpos with + None -> (*let _ = Missing_pervasives.errln "warning: saw `_start' in element with no assigned address" in *)None + | Some x -> (* success! *) Some ( Nat_big_num.add x el_off) + ) + ) + | _ -> (*let _ = Missing_pervasives.errln "warning: `_start' symbol with no range" in*) None + ) + | [] -> (* no _start symbol *) None + | _ -> (*let _ = Missing_pervasives.errln ("warning: saw multiple `_start' symbols: " ^ + (let (ranges, defs) = unzip all_entry_points in show ranges)) in *)None + )) + +(*val pad_zeroes : natural -> list byte*) +let pad_zeroes n:(char)list= (replicate0 n (Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 0)))) + +(*val pad_0x90 : natural -> list byte*) +let pad_0x90 n:(char)list= (replicate0 n (Char.chr (Nat_big_num.to_int ( Nat_big_num.mul(Nat_big_num.of_int 9)(Nat_big_num.of_int 16))))) + +(* null_abi captures ABI details common to all ELF-based, System V-based systems. + * HACK: for now, specialise to 64-bit ABIs. *) +(*val null_abi : abi any_abi_feature*) +let null_abi:(any_abi_feature)abi= ({ + is_valid_elf_header = is_valid_elf64_header + ; make_elf_header = (make_elf64_header elf_data_2lsb elf_osabi_none(Nat_big_num.of_int 0) elf_ma_none) + ; reloc = noop_reloc + ; section_is_special = elf_section_is_special + ; section_is_large = (fun s -> (fun f -> false)) + ; maxpagesize = (Nat_big_num.mul (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 256))(Nat_big_num.of_int 4096)) (* 2MB; bit of a guess, based on gdb and prelink code *) + ; minpagesize =(Nat_big_num.of_int 1024) (* bit of a guess again *) + ; commonpagesize =(Nat_big_num.of_int 4096) + ; symbol_is_generated_by_linker = (fun symname -> symname = "_GLOBAL_OFFSET_TABLE_") + ; make_phdrs = make_default_phdrs + ; max_phnum =(Nat_big_num.of_int 2) + ; guess_entry_point = + (find_start_symbol_address + instance_Basic_classes_Ord_Abis_any_abi_feature_dict + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) + ; pad_data = pad_zeroes + ; pad_code = pad_zeroes + ; generate_support = ( (* fun _ -> *)fun _ -> get_empty_memory_image ()) + ; concretise_support = (fun img2 -> img2) + ; get_reloc_symaddr = + (default_get_reloc_symaddr + instance_Basic_classes_Ord_Abis_any_abi_feature_dict + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) + }) + +(*val got_entry_ordering : (string * maybe symbol_definition) -> (string * maybe symbol_definition) -> Basic_classes.ordering*) +let got_entry_ordering (s1, md1) (s2, md2):int= (compare s1 s2) (* FIXME *) + +let is_ifunc_def:(symbol_definition)option ->bool= (fun maybe_def -> +(match maybe_def with + None -> false + | Some d -> Nat_big_num.equal (get_elf64_symbol_type d.def_syment) stt_gnu_ifunc +)) + +let amd64_reloc_needs_got_slot:'a ->reloc_site ->(symbol_definition)option ->bool= (fun symref -> fun rr -> fun maybe_def -> + if ( Pset.mem(get_elf64_relocation_a_type rr.ref_relent)(Pset.from_list Nat_big_num.compare [ + r_x86_64_got32; r_x86_64_gotpcrel; r_x86_64_gottpoff; r_x86_64_gotoff64; r_x86_64_gotpc32 (* ; r_x86_64_gotpc32_tlsdesc *) + ])) then + true + else if is_ifunc_def maybe_def + then + (* This reference is bound to a STT_GNU_IFUNC definition. + * What now needs to happen is as follows. + * - we ensure that a GOT entry is generated for this symbol (we do this here); + * - we ensure that a PLT entry (specifically .iplt) is generated for the symbol (Below); + * - on making the GOT, we also generate a .rela.plt relocation record covering the GOT slot; + * - when applying the relocation, of whatever kind, the address of the PLT slot + * is the address input to the calculation + * - the code marked by the STT_GNU_IFUNC symbol definition is not the function + * to call; it's the function that calculates the address of the function to call! + * this becomes the addend of the R_X86_64_IRELATIVE Elf64_Rela marking the GOT slot + * - note that for static linking, the GOT is usually pre-filled (cf. dynamically when it is filled by JUMP_SLOT relocs). + * ... but our GOT entries *must* have corresponding R_X86_64_IRELATIVEs generated + *) + true + else false) + + +let amd64_reloc_needs_plt_slot (symref : symbol_reference_and_reloc_site) rr maybe_def ref_is_statically_linked:bool= + (if ( Pset.mem(get_elf64_relocation_a_type rr.ref_relent)(Pset.from_list Nat_big_num.compare [ + r_x86_64_plt32 (* NOTE: when generating shared libs, it starts to matter + * where the definition is -- anything that is locally interposable + * or undefined will need a slot. See amd64_get_reloc_symaddr. *) + ])) then + not (ref_is_statically_linked rr) + else if is_ifunc_def maybe_def + then + true + else + (* not a PLT ref *) + false) + +let amd64_find_got_label_and_element img2:((string*(symbol_definition)option)list*element)option= + ((match Pmap.lookup ".got" img2.elements with + None -> (* got no GOT? okay... *) None + | Some got_el -> + (* Find the GOT tag. *) + let tags_and_ranges = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0([])))) img2.by_tag) + in + (match tags_and_ranges with + [] -> failwith "error: GOT element but no ABI feature GOT tag" + | [(AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0(l))), _)] -> Some (l, got_el) + | _ -> failwith ("multiple GOT elements/tags") + ) + )) + +let amd64_find_plt_label_and_element img2:((string*(symbol_definition)option*(any_abi_feature)plt_entry_content_fn)list*element)option= + ((match Pmap.lookup ".plt" img2.elements with + None -> (* got no PLT? okay... *) None + | Some plt_el -> + (* Find the PLT tag. *) + let tags_and_ranges = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (AbiFeature(Amd64AbiFeature(Abi_amd64.PLT0([])))) img2.by_tag) + in + (match tags_and_ranges with + [] -> failwith "error: PLT element but no ABI feature PLT tag" + | [(AbiFeature(Amd64AbiFeature(Abi_amd64.PLT0(l))), _)] -> Some (l, plt_el) + | _ -> failwith ("multiple PLT elements/tags") + ) + )) + +let got_slot_index_for_symname dict_Basic_classes_Eq_a symname got_label:(int)option= + (Lem_list.find_index (fun (s, _) -> + dict_Basic_classes_Eq_a.isEqual_method s symname) got_label) + +(*val amd64_get_reloc_symaddr : symbol_definition -> annotated_memory_image any_abi_feature -> maybe reloc_site -> natural*) +let amd64_get_reloc_symaddr the_input_def output_img maybe_reloc1:Nat_big_num.num= +( + (* The default implementation simply looks up a "matching" symbol in the output image + * and calculates its address. + * + * That's normally fine, even for via-GOT references since their calculations don't + * use the symaddr. For via-PLT references, we need to use the PLT slot address. + * HMM. Isn't this duplicating the role of functions like amd64_plt_slot_addr? + + * Recall that we created this get_reloc_symaddr mechanism to deal with IFUNC symbols. + * With an IFUNC symbol, we reference it simply using a PC32 relocation, but the address + * that gets filled in isn't the IFUNC address; it's the corresponding PLT slot. + * HMM: does this happen for other PC32 references? If so, we'll need this mechanism + * there. And it certainly does, because relocatable object code never uses PLT32 + * relocs. + * + * I had previously tried to handle this issue in mark_fate_of_relocs, using the + * 1-argument ApplyReloc(_) and MakePIC to encode the "replacement". But at that stage, + * which is ABI-independent and happens before address assignment?, we can't know enough. + *) + (* match bound_def_in_input with + Nothing -> 0 + | Just the_input_def -> *)if is_ifunc_def (Some(the_input_def)) + then + (* We need to return the address of the "matching" PLT slot. + * PLT label entries are (symname, maybe_def, content_fn). *) + (match amd64_find_plt_label_and_element output_img with + None -> failwith "error: ifunc but no PLT" + | Some (l, plt_el) -> + (match Lem_list.find_index (fun (symname, _, _) -> symname = the_input_def.def_symname) l with + (* FIXME: using symnames seems wrong *) + Some idx1 -> + (match plt_el.startpos with + Some addr -> Nat_big_num.add addr (Nat_big_num.mul (Nat_big_num.of_int idx1)(Nat_big_num.of_int 16)) (* size of a PLT entry *) + | None -> failwith "error: PLT has no address assigned" + ) + | None ->Nat_big_num.of_int 0 + ) + ) + else default_get_reloc_symaddr + instance_Basic_classes_Ord_Abis_any_abi_feature_dict instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict the_input_def output_img maybe_reloc1) + (* end *) + +(* *) +(*val amd64_generate_support : (* list (list reloc_site_resolution) -> *) list (string * annotated_memory_image any_abi_feature) -> annotated_memory_image any_abi_feature*) +let amd64_generate_support (* reloc_resolution_lists *) input_fnames_and_imgs:(any_abi_feature)annotated_memory_image= +( + (* We generate a basic GOT. At the moment we can only describe the GOT + * contents abstractly, not as its binary content, because addresses + * have not yet been fixed. + * + * To do this, we create a set of Abi_amd64.GOTEntry records, one for + * each distinct symbol that is referenced by one or more GOT-based relocations. + * To enumerate these, we look at all the symbol refs in the image. + *)let ref_is_statically_linked = (fun _ -> true) + in + let (fnames, input_imgs) = (List.split input_fnames_and_imgs) + in + let tags_and_ranges_by_image = (Lem_list.mapi (fun i -> fun (fname1, img2) -> + (i, fname1, Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (SymbolRef(null_symbol_reference_and_reloc_site)) img2.by_tag) + ) input_fnames_and_imgs) + in + let refs_via_got = (list_concat_map (fun (i, fname1, tags_and_ranges) -> Lem_list.mapMaybe (fun (tag, maybe_range) -> (match tag with + SymbolRef(symref) -> + (* Is this ref a relocation we're going to apply, and does it reference the GOT? *) + (match (symref.maybe_reloc, symref.maybe_def_bound_to) with + (None, _) -> None + | (Some rr, Some(ApplyReloc, maybe_def)) -> + if amd64_reloc_needs_got_slot symref rr maybe_def then + (*let _ = errln ("Saw a via-GOT symbol reference: to `" ^ symref.ref.ref_symname ^ "' coming from linkable " ^ (show i) ^ " (" ^ + fname ^ "), logically from section " ^ (show rr.ref_src_scn)) in *) + Some (symref.ref.ref_symname, maybe_def) + else None + | (Some rr, Some(makePIC0, maybe_def)) -> failwith "FIXME: PIC support please" + ) + | _ -> failwith "impossible: reloc site tag is not a SymbolRef" + )) tags_and_ranges) tags_and_ranges_by_image) + in + let (symnames, maybe_defs) = (List.split refs_via_got) + in + (*let _ = errln ("GOT includes defs with names: " ^ (show (Set_extra.toList (Set.fromList symnames)))) + in*) + let got_pairs_set = (Pset.from_list (pairCompare compare (maybeCompare compare)) refs_via_got) + in + let got_defs_set = (Pset.from_list (maybeCompare compare) maybe_defs) + in + (* This is where we fix the order of the GOT entries. *) + let got_pairs_list = (Pset.elements got_pairs_set) + in + let got_idx_and_maybe_def_by_symname_map = (Lem_map.fromList + (Lem_map.instance_Map_MapKeyType_var_dict + instance_Basic_classes_SetType_var_dict) (mapi (fun slot_idx -> fun (symname, maybe_def) -> (symname, (slot_idx, maybe_def))) got_pairs_list)) + in + let got_ifunc_set = (let x2 =(Pset.from_list (maybeCompare compare) + []) in Pset.fold + (fun maybe_d x2 -> + if is_ifunc_def maybe_d then Pset.add maybe_d x2 else x2) got_defs_set + x2) + in + (* Quirk: what if we have the same def appearing under two different symnames? + * This shouldn't happen, at present. + * What if we have the same symname related to two different defs? This also + * shouldn't happen, because only global symbols go in the GOT, so we don't have + * to worry about local symbols with the same name as another symbol. But still, it + * could plausibly happen in some situations with weird symbol visibilities or binding. *) + (* if Set.size pairs_set <> Set.size defs_set then + failwith "something quirky going on with GOT symbol defs and their names" + else *) +(* let name_def_pairs = List.foldl (fun acc -> fun (idx, symname, (maybe_range, rr)) -> + Set.insert ( + + symname, (match rr.maybe_def_bound_to with + Map.lookup symname acc with + Nothing -> [item] + | Just l -> item :: l + end) acc) {} refs_via_got + in *) + let got_nentries = (Nat_big_num.of_int (Pset.cardinal got_pairs_set)) + in + let got_entrysize =(Nat_big_num.of_int 8) + in + (* We also need a PLT... sort of. We need a way to resolve via-PLT relocs. + * But we might do so without actually creating a (non-zero-length) PLT. + * Again, this is to accommodate the sorts of optimisations the GNU linker does. + * + * Note that every PLT entry has a corresponding GOT entry. Here we are simply + * enumerating the via-PLT relocs that imply a PLT entry. We look their GOT + * slots up later, by symbol name. *) + let refs_via_plt = (list_concat_map (fun (i, fname1, tags_and_ranges) -> Lem_list.mapMaybe (fun (tag, maybe_range) -> (match tag with + SymbolRef(symref) -> + (* Is this ref a relocation we're going to apply, and does it reference the GOT? *) + (match (symref.maybe_reloc, symref.maybe_def_bound_to) with + (None, _) -> None + | (Some rr, Some(ApplyReloc, maybe_def)) -> + if amd64_reloc_needs_plt_slot symref rr maybe_def ref_is_statically_linked + then + (*let _ = if is_ifunc_def maybe_def then + (* we ensure that a PLT entry (specifically .iplt) is generated for the symbol *) + errln ("Saw a reference to IFUNC symbol `" ^ symref.ref.ref_symname ^ "'; ref is coming from linkable " ^ (show i) ^ " (" ^ + fname ^ "), relent idx " ^ (show rr.ref_rel_idx) ^ " logically from section " ^ (show rr.ref_src_scn) ) + else + errln ("Saw a via-PLT symbol reference: to `" ^ symref.ref.ref_symname ^ "' coming from linkable " ^ (show i) ^ " (" ^ + fname ^ "), relent idx " ^ (show rr.ref_rel_idx) ^ " logically from section " ^ (show rr.ref_src_scn) ^ + match maybe_def with Just _ -> ", with definition" | Nothing -> ", not bound to anything" end + ) + in*) + Some(symref.ref.ref_symname, maybe_def) + else None + | (Some rr, Some(makePIC0, maybe_def)) -> failwith "FIXME: PIC support please" + ) + | _ -> failwith "impossible: reloc site tag is not a SymbolRef" + )) tags_and_ranges) tags_and_ranges_by_image) + in + (*let _ = errln ("Saw " ^ (show (length refs_via_plt)) ^ " relocations of a via-PLT type") + in*) + (* account for the optimisations we did on GOT slots *) + let refs_via_plt_having_got_slot = (Lem_list.mapMaybe (fun (symname, _) -> + (match Pmap.lookup symname got_idx_and_maybe_def_by_symname_map with + Some(idx1, maybe_d) -> Some (symname, idx1, maybe_d) + | None -> None + ) + ) refs_via_plt) + in + (*let _ = errln ("Saw " ^ (show (length refs_via_plt_having_got_slot)) ^ " relocations of a via-PLT type where we instantiated a GOT slot for the symbol") + in*) + let (plt_symnames, plt_got_idxs, plt_ref_bound_to_maybe_defs) = (unzip3 refs_via_plt_having_got_slot) + in + let plt_symnames_excluding_header = (Pset.elements ((Pset.from_list compare plt_symnames))) + in + (*let _ = errln ("PLT symnames: " ^ (show plt_symnames_excluding_header)) + in*) + let n_iplt_entries = (Pset.cardinal got_ifunc_set) + (* The content of the IPLT entries depends on the address assignment of GOT slots + * and the IFUNCs that they reference. We need to reserve space for them here, though. *) + in + (*let _ = errln ("We think there should be " ^ (show n_iplt_entries) ^ " PLT entries due to references to IFUNC symbols") + in*) + (* let got_entries_referencing_functions = (List.filter (fun (symname, maybe_def) -> + match def with + Just d -> d.def_syment + | Nothing -> false + end) refs_via_got) + in *) + let plt_needs_header_entry = ((List.length plt_symnames_excluding_header) > n_iplt_entries) + in + (*let _ = errln ("PLT needs header entry? " ^ (show plt_needs_header_entry)) + in*) + let total_n_plt_entries = (Nat_big_num.add (if plt_needs_header_entry then Nat_big_num.of_int 1 else Nat_big_num.of_int 0) (Missing_pervasives.length plt_symnames_excluding_header)) + in + (*let _ = errln ("PLT total entry count: " ^ (show total_n_plt_entries)) + in*) + let new_by_range =(Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) [ + (Some(".plt", (Nat_big_num.of_int 0, Nat_big_num.mul(Nat_big_num.of_int 16) total_n_plt_entries)), AbiFeature(Amd64AbiFeature(Abi_amd64.PLT0( + (* header content fn *) + (* the header entry is required only for dynamic linking, which is not supported yet *) + (* (if plt_needs_header_entry then + ("", Nothing, (((fun (got_base_addr : natural) -> fun (plt_base_addr : natural) -> + (0, [byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; + byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; + byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; + byte_of_natural 0; byte_of_natural 0; byte_of_natural 0; byte_of_natural 0]))) : plt_entry_content_fn any_abi_feature)) + else ("", Nothing, (((fun (got_base_addr : natural) -> fun (plt_base_addr : natural) -> (0, []))) : plt_entry_content_fn any_abi_feature)) + ) + ++ *) ( + mapi (fun plt_entry_idx_not_counting_header -> (fun symname -> + (* We want to label the PLT entry with a function that + * - accepts the PLT base address, the GOT base address and the GOT slot number; + * - closure-captures whatever else it needs (whether we're inserting a PLT header); + * - yields the *full contents of the PLT entry* before relocation. + * - recall that PLT entries might be "header" (the special one at the start), + * "normal" (to be relocated with R_X86_64_JUMP_SLOT) + * or "irelative" (to be relocated with R_X86_64_IRELATIVE). + * Q. Why are R_X86_64_JUMP_SLOT necessary? + * The PLT entries are doing relative addressing, and + * the offset to the GOT entry is known at link time, + * so the linker should be able to fill them in. In + * fact, it does. HMM. Understand this better. *) + (* What is the GOT slot number? *) + let (got_slot_idx, maybe_def) = ((match Pmap.lookup symname got_idx_and_maybe_def_by_symname_map with + Some(idx1, maybe_d) -> (Nat_big_num.of_int idx1, maybe_d) + | None -> failwith ("GOT does not contain symbol `" ^ (symname ^ "' required by PLT entry")) + )) + in + (symname, maybe_def, ((fun (got_base_addr : Nat_big_num.num) -> fun (plt_base_addr : Nat_big_num.num) -> + (* Okay, now we can generate the entry. NOTE that we're lexically still in generate_support, + * but we'll be called from concretise_support. The code that generates the header + * entry is actually in concretise_support. + * + * If the entry is a normal entry, it looks like + * + 0x0000000000400410 <+0>: ff 25 02 0c 20 00 jmpq *0x200c02(%rip) # 0x601018 <puts@got.plt> + 0x0000000000400416 <+6>: 68 00 00 00 00 pushq $0x0 + 0x000000000040041b <+11>: e9 e0 ff ff ff jmpq 0x400400 + * + * If the entry is an irelative entry, it looks like + * + 400350: ff 25 02 fd 2b 00 jmpq *0x2bfd02(%rip) # 6c0058 <_GLOBAL_OFFSET_TABLE_+0x58> + 400356: 68 00 00 00 00 pushq $0x0 + 40035b: e9 00 00 00 00 jmpq 400360 <check_one_fd.part.0> + + * ... i.e. basically the same but the pushq and jmpq have literal-zero args (they're not used). + *) + let this_plt_slot_base_addr = (Nat_big_num.add plt_base_addr (Nat_big_num.mul(Nat_big_num.of_int 16) ( + Nat_big_num.add(Nat_big_num.of_int plt_entry_idx_not_counting_header) (if plt_needs_header_entry then Nat_big_num.of_int 1 else Nat_big_num.of_int 0)))) + in + (*let _ = Missing_pervasives.errln ("PLT slot base address for symname `" ^ symname ^ "': 0x" ^ + (hex_string_of_natural this_plt_slot_base_addr)) + in*) + let got_slot_addr = (Nat_big_num.add got_base_addr (Nat_big_num.mul(Nat_big_num.of_int 8) got_slot_idx)) + in + (*let _ = Missing_pervasives.errln ("GOT slot address for symname `" ^ symname ^ "' (idx " ^ (show got_slot_idx) ^ "): 0x" ^ + (hex_string_of_natural got_slot_addr)) + in*) + let maybe_header_entry_address = (if plt_needs_header_entry then Some(plt_base_addr) else None) + in + let offset_to_got_slot = (Nat_big_num.sub ( got_slot_addr) (( Nat_big_num.add this_plt_slot_base_addr(Nat_big_num.of_int 6)))) + in + (*let _ = Missing_pervasives.errln ("PLT's PC-relative index to GOT slot for symname `" ^ symname ^ "' (GOT idx " ^ (show got_slot_idx) ^ ") is (decimal)" ^ + (show offset_to_got_slot)) + in*) + let content_bytes = + (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev [Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 255)); Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 37))]) (* offset to the GOT entry, from the *next* instruction start, signed 32-bit LE *)(to_le_signed_bytes(Nat_big_num.of_int 4) offset_to_got_slot))) [Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 104))])) (* plt slot number not including header, 32-bit LE *)(to_le_unsigned_bytes(Nat_big_num.of_int 4) ((Nat_big_num.of_int plt_entry_idx_not_counting_header))))) [Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 233))])) (to_le_signed_bytes(Nat_big_num.of_int 4) ( + if is_ifunc_def maybe_def + then Nat_big_num.of_int 0 + else (match maybe_header_entry_address with + None -> failwith "normal PLT entry but no PLT header!" + | Some header_entry_address -> Nat_big_num.sub ( header_entry_address) (( Nat_big_num.add this_plt_slot_base_addr(Nat_big_num.of_int 16))) + ) + ))) + in + (*let _ = errln ("Created a PLT entry consisting of " ^ (show (length content_bytes)) ^ " bytes.") + in*) + (this_plt_slot_base_addr, content_bytes) + (* + match maybe_def with + Nothing -> 0 + | Just sd -> + match Memory_image_orderings.find_defs_matching sd img with + [] -> failwith ("no matching definitions for PLT entry named " ^ symname) + | [(Just(def_el_name, (def_start, def_len)), d)] -> + match element_and_offset_to_address (def_el_name, def_start) img with + Nothing -> failwith ("PLT: no address for definition offset in element " ^ def_el_name) + | Just x -> + let _ = errln ("PLT slot for symbol `" ^ symname ^ + "' calculated at (non-PLT) address 0x" ^ (hex_string_of_natural x) ^ + " (offset 0x" ^ (hex_string_of_natural def_start) ^ " in element " ^ def_el_name ^ ")") + in + x + end + | _ -> failwith ("multiple matching definitions for PLT entry named " ^ symname) + end + end + *) + + ) : any_abi_feature plt_entry_content_fn)) + )) + plt_symnames) + ))) + ) + ; (Some(".plt", (Nat_big_num.of_int 0, Nat_big_num.mul(Nat_big_num.of_int 16) total_n_plt_entries)), FileFeature(ElfSection(Nat_big_num.of_int 1, + { elf64_section_name =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_type = sht_progbits + ; elf64_section_flags = shf_alloc + ; elf64_section_addr =(Nat_big_num.of_int 0) (* ignored -- covered by element *) + ; elf64_section_offset =(Nat_big_num.of_int 0) (* ignored -- will be replaced when file offsets are assigned *) + ; elf64_section_size = (Nat_big_num.mul(Nat_big_num.of_int 16) total_n_plt_entries) (* ignored? NO, we use it in linker_script to avoid plumbing through the element record *) + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 16) + ; elf64_section_entsize =(Nat_big_num.of_int 16) + ; elf64_section_body = Byte_sequence.empty (* ignored *) + ; elf64_section_name_as_string = ".plt" + } + ))) + (* For each GOT entry that corresponds to a thread-local symbol, we also need to + * generate a relocation record. HMM. These new relocation records are ones we don't + * yet have decisions for. That might be a problem. + * + * In fact, this approach is not appropriate for static linking. Just put the offsets + * in there when we concretise the GOT. Something like this will be good for + * dynamic linking, though. At the moment, creating a SymbolRef at this stage + * is problematic because it's not in the bindings list. When we generate shared + * objects, we'll have to revisit that code. *) + (* (Just(".got", (i * got_entrysize, 8)), SymbolRef( <| + ref = <| ref_symname = symname + ; ref_syment = sd.def_syment + ; ref_sym_scn = 0 + ; ref_sym_idx = 0 + |> + ; maybe_def_bound_to = Just(ApplyReloc, Just sd) + ; maybe_reloc = Just( + <| + ref_relent = + <| elf64_ra_offset = elf64_addr_of_natural 0 + ; elf64_ra_info = elf64_xword_of_natural r_x86_64_tpoff64 + ; elf64_ra_addend = elf64_sxword_of_integer 0 + |> + ; ref_rel_scn = 0 + ; ref_rel_idx = 0 + ; ref_src_scn = 0 + |> + ) + |>)) + | forall ((i, symname, sd) IN (Set.fromList (mapMaybei (fun i -> fun (symname, maybe_def) -> + match maybe_def with Nothing -> Nothing | Just sd -> Just(i, symname, sd) end) refs_via_got))) + | get_elf64_symbol_type sd.def_syment = stt_tls + *) + ; (Some(".got", (Nat_big_num.of_int 0, Nat_big_num.mul got_nentries got_entrysize)), AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0(got_pairs_list)))) + ; (Some(".got", (Nat_big_num.of_int 0, Nat_big_num.mul got_nentries got_entrysize)), FileFeature(ElfSection(Nat_big_num.of_int 2, + { elf64_section_name =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_type = sht_progbits + ; elf64_section_flags = (Nat_big_num.bitwise_or shf_write shf_alloc) + ; elf64_section_addr =(Nat_big_num.of_int 0) (* ignored -- covered by element *) + ; elf64_section_offset =(Nat_big_num.of_int 0) (* ignored -- will be replaced when file offsets are assigned *) + ; elf64_section_size = (Nat_big_num.mul got_nentries got_entrysize) (* ignored? NO, we use it in linker_script to avoid plumbing through the element record *) + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 8) + ; elf64_section_entsize = got_entrysize + ; elf64_section_body = Byte_sequence.empty (* ignored *) + ; elf64_section_name_as_string = ".got" + } + ))) + ; (* FIXME: I've a feeling _GLOBAL_OFFSET_TABLE_ generally doesn't mark the *start* of the GOT; + * it's some distance in. What about .got.plt? *) + (Some(".got", (Nat_big_num.of_int 0, Nat_big_num.mul got_nentries got_entrysize)), SymbolDef({ + def_symname = "_GLOBAL_OFFSET_TABLE_" + ; def_syment = ({ elf64_st_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* ignored *) + ; elf64_st_info = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* FIXME *) + ; elf64_st_other = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* FIXME *) + ; elf64_st_shndx = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))) + ; elf64_st_value = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* ignored *) + ; elf64_st_size = (Uint64.of_string (Nat_big_num.to_string ( Nat_big_num.mul got_nentries got_entrysize))) (* FIXME: start later, smaller size? zero size? *) + }) + ; def_sym_scn =(Nat_big_num.of_int 1) + ; def_sym_idx =(Nat_big_num.of_int 1) + ; def_linkable_idx =(Nat_big_num.of_int 0) + })) + ; (Some(".rela.iplt", (Nat_big_num.of_int 0, (* size of an Elf64_Rela *) Nat_big_num.mul(Nat_big_num.of_int 24) (Nat_big_num.of_int n_iplt_entries))), FileFeature(ElfSection(Nat_big_num.of_int 3, + { elf64_section_name =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_type = sht_rela + ; elf64_section_flags = (Nat_big_num.bitwise_or shf_alloc shf_info_link) + ; elf64_section_addr =(Nat_big_num.of_int 0) (* ignored -- covered by element *) + ; elf64_section_offset =(Nat_big_num.of_int 0) (* ignored -- will be replaced when file offsets are assigned *) + ; elf64_section_size = ( (* size of an Elf64_Rela *)Nat_big_num.mul(Nat_big_num.of_int 24) (Nat_big_num.of_int n_iplt_entries)) (* ignored? NO, we use it in linker_script to avoid plumbing through the element record *) + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int (* FIXME: want this to be the PLT section shndx *)0) + ; elf64_section_align =(Nat_big_num.of_int 8) + ; elf64_section_entsize =(Nat_big_num.of_int 24) + ; elf64_section_body = Byte_sequence.empty (* ignored *) + ; elf64_section_name_as_string = ".rela.iplt" + } + ))) + ]) + in + { elements = (Pmap.add ".got" { + startpos = None + ; length1 = (Some ( Nat_big_num.mul got_nentries got_entrysize)) + ; contents = ([]) + } (Pmap.add ".plt" { + startpos = None + ; length1 = (let len = (Nat_big_num.mul(Nat_big_num.of_int 16) total_n_plt_entries) in + (*let _ = errln ("PLT length in element: " ^ (show len) ^ " bytes") + in *) Some ( Nat_big_num.mul(Nat_big_num.of_int 16) total_n_plt_entries)) + ; contents = ([]) + } (Pmap.add ".rela.iplt" { + startpos = None + ; length1 = (Some ( (* size of an Elf64_Rela *) Nat_big_num.mul(Nat_big_num.of_int 24) (Nat_big_num.of_int n_iplt_entries))) + ; contents = ([]) + } (Pmap.empty compare) + ))) + ; by_tag = (by_tag_from_by_range + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) instance_Basic_classes_SetType_var_dict new_by_range) + ; by_range = new_by_range + }) + +(*val amd64_concretise_support : annotated_memory_image any_abi_feature -> annotated_memory_image any_abi_feature*) +let amd64_concretise_support orig_img:(any_abi_feature)annotated_memory_image= +( + (*let _ = errln "Concretising amd64 ABI support structures" + in*) + (* Fill in the GOT contents. *)(match amd64_find_got_label_and_element orig_img with + None -> orig_img (* no GOT, but that's okay *) + | Some (got_l, got_el) -> + let got_base_addr = ((match got_el.startpos with + Some a -> a + | None -> failwith "GOT has no address assigned" + )) + in + let got_entry_bytes_for = (fun img2 -> fun symname -> fun maybe_def -> fun plt_l -> fun maybe_plt_el -> (match maybe_def with + None -> replicate0(Nat_big_num.of_int 8) (Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 0))) + | Some sd -> + (* What should the GOT slot be initialized to point to? + * If there's a PLT entry, we should point to that + 6, + * i.e. the second instruction. + * + * If there's not, then it might be a thread-local. *) + (match Lem_list.find_index (fun (plt_symname, _, _) -> symname = plt_symname) plt_l with + Some plt_slot_idx -> + (match maybe_plt_el with + None -> failwith "GOT slot with PLT entry but no PLT element" + | Some plt_el -> + (match plt_el.startpos with + Some addr -> natural_to_le_byte_list_padded_to(Nat_big_num.of_int 8) ( Nat_big_num.add (Nat_big_num.add addr ( Nat_big_num.mul(Nat_big_num.of_int plt_slot_idx)(Nat_big_num.of_int 16)))(Nat_big_num.of_int 6)) + | None -> failwith ("no PLT!") + ) + ) + | None -> + (* Just look for a definition. *) + (match Memory_image_orderings.find_defs_matching + instance_Basic_classes_Ord_Abis_any_abi_feature_dict instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict sd img2 with + [] -> failwith ("no matching definitions for GOT entry named " ^ symname) + | [(Some(def_el_name, (def_start, def_len)), d)] -> + (match element_and_offset_to_address (def_el_name, def_start) img2 with + None -> failwith ("no address for definition offset in element " ^ def_el_name) + | Some x -> + (* If sd is a TLS symbol, we want its offset from the *end* of the + * TLS segment. *) + (* FIXME: factor out this logic so that it lives in the TLS ABI spec. *) + if Nat_big_num.equal (get_elf64_symbol_type sd.def_syment) stt_tls then + (* FIXME: the right way to do this is to mark the segments in the image + * *first*. They can't have ranges, because they span many elements, + * but they can have vaddr ranges as arguments. *) + let offs = (i2n_signed( 64) (Nat_big_num.sub(Nat_big_num.of_int 0)(Nat_big_num.of_int 8))) + in + (*let _ = errln ("GOT slot for TLS symbol `" ^ symname ^ + "' created containing offset 0x" ^ (hex_string_of_natural offs)) + in*) + natural_to_le_byte_list offs + else (*let _ = errln ("GOT slot for symbol `" ^ symname ^ + "' created pointing to address 0x" ^ (hex_string_of_natural x) ^ + " (offset 0x" ^ (hex_string_of_natural def_start) ^ " in element " ^ def_el_name ^ ")") + in*) + natural_to_le_byte_list_padded_to(Nat_big_num.of_int 8) x + ) + | _ -> failwith ("multiple matching definitions for GOT entry named " ^ symname) + ) + ) + )) + in + let concretise_got = (fun img2 -> fun plt_l -> fun maybe_plt_el -> + let l = got_l + (* Just(got_el_name, (got_start_off, got_len)))] -> *) + in + (*let _ = errln ("Concretising a GOT of " ^ (show (length l)) ^ " entries.") + in*) + let got_entry_contents = (Lem_list.map (fun (symname, maybe_def) -> + Lem_list.map (fun b -> Some b) (got_entry_bytes_for img2 symname maybe_def plt_l maybe_plt_el)) l) + in + (* We replace the GOT element's contents with the concrete addresses + * of the symbols it should contain. We leave the metadata label in there, + * for the relocation logic to find. If we change the order of entries, + * change it there too. *) + let got_content = (List.concat got_entry_contents) + in + let new_got_el = + ({ contents = got_content + ; startpos = (got_el.startpos) + ; length1 = (got_el.length1) + }) + in + let new_got_tag = (AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0(l)))) + in + let got_range = (Some(".got", (Nat_big_num.of_int 0, Nat_big_num.mul(Nat_big_num.of_int 8) (length l)))) + in + let new_by_tag = + (Pset.(union)( Pset.diff(img2.by_tag : (( any_abi_feature range_tag) * ( element_range option)) Pset.set)(Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) [(AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0(l))), got_range)]))(Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) [(new_got_tag, got_range)])) + in + let new_elements_map = (Pmap.add ".got" new_got_el ( + Pmap.remove ".got" img2.elements + )) + in + { elements = new_elements_map + ; by_tag = new_by_tag + ; by_range = (by_range_from_by_tag + instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) new_by_tag) + }) + in + (match amd64_find_plt_label_and_element orig_img with + None -> concretise_got orig_img [] None (* no PLT, but possibly a GOT *) + | Some (plt_l, plt_el) -> + let plt_base_addr = ((match plt_el.startpos with + Some a -> a + | None -> failwith "PLT has no address assigned" + )) + in + let concretise_plt = (fun img2 -> + let l = plt_l + in + (* We replace the PLT element's contents with the concrete entries + * for each of the symbols in the table. We leave the metadata label in there, + * for the relocation logic to find. If we change the order of entries, + * change it there too. *) + let all_content = (List.concat (Lem_list.map (fun (_, _, plt_content_fn) -> + let (_, content) = (plt_content_fn got_base_addr plt_base_addr) in + content + ) l)) + in + (*let _ = errln ("Got " ^ (show (length all_content)) ^ " bytes of PLT content") + in + let _ = errln ("Generated PLT reserved " ^ (show (match plt_el.length with + Just n -> n + | Nothing -> failwith "PLT has no length" + end)) ^ " bytes of PLT content") + in*) + let new_plt_el = + ({ contents = (Lem_list.map (fun b -> Some b) all_content) + ; startpos = (plt_el.startpos) + ; length1 = (Some(length all_content)) + }) + in + let new_elements_map = (Pmap.add ".plt" new_plt_el ( + Pmap.remove ".plt" img2.elements + )) + in + { elements = new_elements_map + ; by_tag = (img2.by_tag) + ; by_range = (img2.by_range) + }) + in + let concretise_rela_plt = (fun img2 -> + let maybe_rela_plt_el = (Pmap.lookup ".rela.plt" img2.elements) + in + let maybe_new_rela_plt_el = ((match maybe_rela_plt_el with + None -> (* got no .rela.plt? okay... *) + (*let _ = errln "No .rela.plt found" + in*) + None + | Some rela_plt_el -> + let got_entry_iplt_widget_for = (fun symname -> fun maybe_def -> (match maybe_def with + None -> None + | Some sd -> + if not (Nat_big_num.equal (get_elf64_symbol_type sd.def_syment) stt_gnu_ifunc) then None + else Some(fun index_in_got -> + (* This is a 24-byte Elf64_Rela. *) + let (r_offset : Nat_big_num.num) (* GOT *slot* address! *) = + ((match got_el.startpos with + None -> failwith "internal error: GOT has no assigned address" + | Some addr -> Nat_big_num.add addr ( Nat_big_num.mul(Nat_big_num.of_int 8) index_in_got) + )) + in + let (r_info : Nat_big_num.num) = r_x86_64_irelative in + ( List.rev_append (List.rev (List.rev_append (List.rev (natural_to_le_byte_list_padded_to(Nat_big_num.of_int 8) r_offset)) (natural_to_le_byte_list_padded_to(Nat_big_num.of_int 8) r_info))) + (* r_addend -- address of the ifunc definition. + * NOTE that this is NOT the same as the GOT entry bytes. + * It's the actual address of the ifunc, whereas + * the GOT entry is initialized to point back into the PLT entry. *)(match Memory_image_orderings.find_defs_matching + instance_Basic_classes_Ord_Abis_any_abi_feature_dict instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict sd img2 with + [] -> failwith ("impossible: IPLT entry widget found matching ifunc definition for " ^ symname) + | [(Some(def_el_name, (def_start, def_len)), d)] -> + (match element_and_offset_to_address (def_el_name, def_start) img2 with + None -> failwith ("no address for ifunc definition offset in element " ^ def_el_name) + | Some x -> + (* If sd is a TLS symbol, we want its offset from the *end* of the + * TLS segment. *) + (* FIXME: factor out this logic so that it lives in the TLS ABI spec. *) + if not (Nat_big_num.equal (get_elf64_symbol_type sd.def_syment) stt_gnu_ifunc) + then failwith "impossible: found ifunc definition that is not an ifunc" + else + natural_to_le_byte_list_padded_to(Nat_big_num.of_int 8) x + ) + | _ -> failwith "impossible: more than one ifunc definition" + ) + )) + (* end Just sd *) + )) + in + let rela_iplt_widgets = (Lem_list.map (fun (symname, maybe_def) -> got_entry_iplt_widget_for symname maybe_def) got_l) + in + let new_content_bytelists = + (mapi (fun i -> fun rela_widget -> + (match rela_widget with + Some f -> f (Nat_big_num.of_int i) + | None -> [] + ) + ) rela_iplt_widgets) + in + let new_contents = (Lem_list.map (fun b -> Some b) (List.concat new_content_bytelists)) + in + (*let _ = errln ("Concretised .rela.plt; first 24 bytes: " ^ (show (take 24 new_contents))) + in*) + Some( + { contents = new_contents + ; startpos = (rela_plt_el.startpos) + ; length1 = (rela_plt_el.length1) + } + ) + )) + in + let new_elements_map = ((match maybe_new_rela_plt_el with + Some new_rela_plt_el -> Pmap.add ".rela.plt" new_rela_plt_el ( + Pmap.remove ".rela.plt" img2.elements + ) + | None -> img2.elements + )) + in + { elements = new_elements_map + ; by_tag = (img2.by_tag) + ; by_range = (img2.by_range) + }) + in + concretise_rela_plt (concretise_plt (concretise_got orig_img plt_l (Some plt_el))) +) )) + +(*val amd64_got_slot_idx : annotated_memory_image any_abi_feature -> symbol_reference_and_reloc_site -> natural*) +let amd64_got_slot_idx img2 rr:Nat_big_num.num= +( + (*let _ = errln ("Looking up GOT slot for symbol " ^ rr.ref.ref_symname) in*)(match Pmap.lookup ".got" img2.elements with + None -> (* got no GOT? okay... *) failwith "got no GOT" + | Some got_el -> + (* Find the GOT tag. *) + let tags_and_ranges = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0([])))) img2.by_tag) + in + (match tags_and_ranges with + [] -> failwith "error: GOT element but no ABI feature GOT tag" + | [(AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0(l))), Some(got_el_name, (got_start_off, got_len)))] -> + (* Find the slot corresponding to rr, if we have one. *) + let got_addr = ((match got_el.startpos with Some addr -> addr | None -> failwith "GOT has no addr at reloc time" )) + in + (match rr.maybe_def_bound_to with + Some (_, Some(d)) -> + (match Lem_list.find_index (fun (symname, maybe_def) -> (Lem.option_equal (=) (Some(d)) maybe_def)) l with + Some idx1 -> Nat_big_num.of_int idx1 + | None -> failwith ("no GOT slot for reloc against `" ^ (rr.ref.ref_symname ^ "'")) + ) + | Some(_, None) -> (* HACK: look for the weak symname. Really want more (ref-based) labelling. *) + (match Lem_list.find_index (fun (symname, _) -> symname = rr.ref.ref_symname) l with + Some idx1 -> Nat_big_num.of_int idx1 + | None -> failwith ("no GOT slot for reloc against undefined symbol `" ^ (rr.ref.ref_symname ^ "'")) + ) + | _ -> failwith "GOT: unbound def" + ) + | _ -> failwith "got bad GOT" + ) + )) + +(*val amd64_got_slot_addr : annotated_memory_image any_abi_feature -> symbol_reference_and_reloc_site -> natural*) +let amd64_got_slot_addr img2 rr:Nat_big_num.num= + ((match Pmap.lookup ".got" img2.elements with + None -> (* got no GOT? okay... *) failwith "got no GOT" + | Some got_el -> + (* Find the GOT tag. *) + let tags_and_ranges = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0([])))) img2.by_tag) + in + (match tags_and_ranges with + [] -> failwith "error: GOT element but no ABI feature GOT tag" + | [(AbiFeature(Amd64AbiFeature(Abi_amd64.GOT0(l))), Some(got_el_name, (got_start_off, got_len)))] -> + (* Find the slot corresponding to rr, if we have one. *) + let got_addr = ((match got_el.startpos with Some addr -> addr | None -> failwith "GOT has no addr at reloc time" )) + in Nat_big_num.add (Nat_big_num.mul(Nat_big_num.of_int 8) (amd64_got_slot_idx img2 rr)) got_addr + | _ -> failwith "got bad GOT" + ) + )) + +(*val amd64_plt_slot_addr : annotated_memory_image any_abi_feature -> symbol_reference_and_reloc_site -> natural -> natural*) +let amd64_plt_slot_addr img2 rr raw_addr:Nat_big_num.num= + ((match Pmap.lookup ".plt" img2.elements with + None -> + (* got no PLT? okay... under static linking this can happen. + We use the actual symbol address of the *) + (*let _ = errln "Warning: no PLT, so attempting to use actual symbol address as PLT slot address" + in*) + (* if raw_addr = 0 then failwith "bailing rather than resolving PLT slot to null address (perhaps conservatively)" else *) + raw_addr + | Some plt_el -> + (* Find the PLT tag. *) + let tags_and_ranges = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (AbiFeature(Amd64AbiFeature(Abi_amd64.PLT0([])))) img2.by_tag) + in + (match tags_and_ranges with + [] -> failwith "error: PLT element but no ABI feature PLT tag" + | [(AbiFeature(Amd64AbiFeature(Abi_amd64.PLT0(l))), Some(plt_el_name, (plt_start_off, plt_len)))] -> + let plt_addr = ((match plt_el.startpos with Some addr -> addr | None -> failwith "PLT has no addr at reloc time" )) + in + (* Find the slot corresponding to rr, if we have one. *) + (match rr.maybe_def_bound_to with + Some (_, Some(d)) -> + (match Lem_list.mapMaybe (fun (symname, maybe_def, fn) -> if (Lem.option_equal (=) (Some(d)) maybe_def) then Some fn else None) l with + [fn] -> + let got_addr = + ((match Pmap.lookup ".got" img2.elements with + None -> (* got no GOT? okay... *) failwith "got no GOT (applying PLT calculation)" + | Some got_el -> (match got_el.startpos with + Some addr -> addr + | None -> failwith "concrete GOT has no addr" + ) + )) + in + let (addr, content) = (fn got_addr plt_addr) + in + (*let _ = errln ("Calculated PLT slot for `" ^ d.def_symname ^ "', from PLT addr " ^ (hex_string_of_natural plt_addr) + ^ " and GOT addr " ^ (hex_string_of_natural got_addr) ^ ", as " ^ (hex_string_of_natural addr)) + in*) + addr + | [] -> (* failwith ("internal error: no PLT entry for reloc against `" ^ rr.ref.ref_symname ^ "'") *) + (* If we got no PLT slot, we assume it's because the PLT entry was optimised out. + * So we just return the address of the symbol itself. *) + (*let _ = errln ("No PLT entry for reloc against `" ^ rr.ref.ref_symname ^ + "', which we assume was optimised to avoid the GOT") + in*) + (match Memory_image_orderings.find_defs_matching + instance_Basic_classes_Ord_Abis_any_abi_feature_dict instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict d img2 with + [] ->Nat_big_num.of_int 0 (* HMM -- should be an error? *) + | [(Some(el_name, (start_off, len)), matching_d)] -> + (match element_and_offset_to_address (el_name, start_off) img2 with + Some a -> a + | None -> failwith ("internal error: could not get address for PLT-short-circuited symbol `" ^ (rr.ref.ref_symname ^ "'")) + ) + | _ -> failwith ("output image has multiple and/or no-location definitions to which via-PLT ref to `" ^ (rr.ref.ref_symname ^ "' could resolve")) + ) + | _ -> failwith ("internal error: multiple PLT entries for reloc against `" ^ (rr.ref.ref_symname ^ "'")) + ) + | Some(_, None) ->Nat_big_num.of_int (* weak, so 0 *)0 + | _ -> failwith "PLT: unbound def" + ) + | _ -> failwith "got bad PLT" + ) + )) + +(** [amd64_reloc r] yields a function that applies relocations of type [r]. *) +(*val amd64_reloc : reloc_fn any_abi_feature*) +let amd64_reloc r:bool*((any_abi_feature)annotated_memory_image ->Nat_big_num.num ->symbol_reference_and_reloc_site ->Nat_big_num.num*(Nat_big_num.num ->Nat_big_num.num ->Nat_big_num.num ->Nat_big_num.num))= + ((match (string_of_amd64_relocation_type r) with + | "R_X86_64_NONE" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 0, (fun s -> fun a -> fun e -> e)))))) + | "R_X86_64_64" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8, (fun s -> fun a -> fun e -> i2n ( Nat_big_num.add(n2i s) a))))))) + | "R_X86_64_PC32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n_signed( 32) ( Nat_big_num.sub( Nat_big_num.add(n2i s) a) (n2i site_addr)))))))) + | "R_X86_64_GOT32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n_signed( 32) ( Nat_big_num.add(n2i (amd64_got_slot_idx img2 rr)) a))))))) + | "R_X86_64_PLT32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n_signed( 32) ( Nat_big_num.sub (Nat_big_num.add(n2i (amd64_plt_slot_addr img2 rr s)) a) (n2i site_addr))) )))) ) + | "R_X86_64_COPY" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (size_of_copy_reloc img2 rr, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_GLOB_DAT" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (size_of_def rr, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_JUMP_SLOT" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_RELATIVE" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_GOTPCREL" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n_signed( 32) ( Nat_big_num.sub (Nat_big_num.add(n2i (amd64_got_slot_addr img2 rr)) a) (n2i site_addr))) )))) ) + | "R_X86_64_32" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n ( Nat_big_num.add(n2i s) a))))))) + | "R_X86_64_32S" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n_signed( 32) ( Nat_big_num.add(n2i s) a))))))) + | "R_X86_64_16" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 2, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_PC16" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 2, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_8" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 1, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_PC8" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 1, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_DTPMOD64" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_DTPOFF64" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_TPOFF64" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> i2n_signed( 64) (Nat_big_num.sub(Nat_big_num.of_int 0)(Nat_big_num.of_int 8))) (* FIXME *)))))) + | "R_X86_64_TLSGD" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_TLSLD" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_DTPOFF32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_GOTTPOFF" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> i2n_signed( 32) ( Nat_big_num.sub (Nat_big_num.add(n2i (amd64_got_slot_addr img2 rr)) a) (n2i site_addr)))))))) + | "R_X86_64_TPOFF32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_PC64" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_GOTOFF64" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_GOTPC32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_SIZE32" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_SIZE64" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8, (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_GOTPC32_TLSDESC" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_TLSDESC_CALL" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 4 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_TLSDESC" -> (false, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | "R_X86_64_IRELATIVE" -> (true, (fun img2 -> (fun site_addr -> (fun rr -> (Nat_big_num.of_int 8 (* CHECK *), (fun s -> fun a -> fun e -> e) (* FIXME *)))))) + | _ -> failwith "unrecognised relocation" +)) + +(*val sysv_amd64_std_abi : abi any_abi_feature*) +let sysv_amd64_std_abi:(any_abi_feature)abi= + ({ is_valid_elf_header = header_is_amd64 + ; make_elf_header = (make_elf64_header elf_data_2lsb elf_osabi_none(Nat_big_num.of_int 0) elf_ma_x86_64) + ; reloc = amd64_reloc + ; section_is_special = section_is_special0 + ; section_is_large = (fun s -> (fun f -> flag_is_set shf_x86_64_large s.elf64_section_flags)) + ; maxpagesize =(Nat_big_num.of_int 65536) + ; minpagesize =(Nat_big_num.of_int 4096) + ; commonpagesize =(Nat_big_num.of_int 4096) + (* XXX: DPM, changed from explicit reference to null_abi field due to problems in HOL4. *) + ; symbol_is_generated_by_linker = (fun symname -> symname = "_GLOBAL_OFFSET_TABLE_") + ; make_phdrs = make_default_phdrs + ; max_phnum =(Nat_big_num.of_int 2) (* incremented by extensions *) + ; guess_entry_point = + (find_start_symbol_address + instance_Basic_classes_Ord_Abis_any_abi_feature_dict + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) + ; pad_data = pad_zeroes + ; pad_code = pad_0x90 + ; generate_support = amd64_generate_support + ; concretise_support = amd64_concretise_support + ; get_reloc_symaddr = amd64_get_reloc_symaddr + }) + +(*val sysv_aarch64_le_std_abi : abi any_abi_feature*) +let sysv_aarch64_le_std_abi:(any_abi_feature)abi= + ({ is_valid_elf_header = header_is_aarch64_le + ; make_elf_header = (make_elf64_header elf_data_2lsb elf_osabi_none(Nat_big_num.of_int 0) elf_ma_aarch64) + ; reloc = aarch64_le_reloc + ; section_is_special = section_is_special0 + ; section_is_large = (fun _ -> (fun _ -> false)) + ; maxpagesize = (Nat_big_num.mul (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 256))(Nat_big_num.of_int 4096)) (* 2MB; bit of a guess, based on gdb and prelink code *) + ; minpagesize =(Nat_big_num.of_int 1024) (* bit of a guess again *) + ; commonpagesize =(Nat_big_num.of_int 4096) + ; symbol_is_generated_by_linker = (fun symname -> symname = "_GLOBAL_OFFSET_TABLE_") + ; make_phdrs = make_default_phdrs + ; max_phnum =(Nat_big_num.of_int 2) (* incremented by extensions *) + ; guess_entry_point = + (find_start_symbol_address + instance_Basic_classes_Ord_Abis_any_abi_feature_dict + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) + ; pad_data = pad_zeroes + ; pad_code = pad_zeroes + ; generate_support = ( (* fun _ -> *)fun _ -> get_empty_memory_image ()) + ; concretise_support = (fun img2 -> img2) + ; get_reloc_symaddr = + (default_get_reloc_symaddr + instance_Basic_classes_Ord_Abis_any_abi_feature_dict + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) + }) + +(*val all_abis : list (abi any_abi_feature)*) +let all_abis:((any_abi_feature)abi)list= ([sysv_amd64_std_abi; sysv_aarch64_le_std_abi; null_abi]) + diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64.ml new file mode 100644 index 00000000..1f7ee662 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64.ml @@ -0,0 +1,98 @@ +(*Generated by Lem from abis/amd64/abi_amd64.lem.*) +(** [abi_amd64] contains top-level definition for the AMD64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Error +open Lem_map +open Lem_assert_extra + +open Missing_pervasives +open Elf_header +open Elf_types_native_uint +open Elf_file +open Elf_interpreted_segment +open Elf_interpreted_section + +open Endianness +open Memory_image +(* open import Elf_memory_image *) + +open Abi_classes +open Abi_amd64_relocation +open Abi_amd64_elf_header + +(** [abi_amd64_compute_program_entry_point segs entry] computes the program + * entry point using ABI-specific conventions. On AMD64 the entry point in + * the ELF header ([entry] here) is the real entry point. On other ABIs, e.g. + * PowerPC64, the entry point [entry] is a pointer into one of the segments + * constituting the process image (passed in as [segs] here for a uniform + * interface). + *) +(*val abi_amd64_compute_program_entry_point : list elf64_interpreted_segments -> elf64_addr -> error natural*) +let abi_amd64_compute_program_entry_point segs entry:(Nat_big_num.num)error= + (return (Ml_bindings.nat_big_num_of_uint64 entry)) + +(*val header_is_amd64 : elf64_header -> bool*) +let header_is_amd64 h:bool= + (is_valid_elf64_header h + && ((Lem.option_equal (=) (Lem_list.list_index h.elf64_ident (Nat_big_num.to_int elf_ii_data)) (Some (Uint32.of_string (Nat_big_num.to_string elf_data_2lsb)))) + && (is_valid_abi_amd64_machine_architecture (Nat_big_num.of_string (Uint32.to_string h.elf64_machine)) + && is_valid_abi_amd64_magic_number h.elf64_ident))) + +let shf_x86_64_large : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 1048576)) (* 0x10000000 a.k.a. 2^28 *) + +(* We model the PLT as a list of symbol name, maybe def, and a function + * - from the PLT slot offset and the whole with-addresses image (overkill) + * - to... what? currently it's the address of the named symbol *) +type 'abifeature plt_entry_content_fn = Nat_big_num.num -> Nat_big_num.num -> (Nat_big_num.num * char list) + (* PLT base addr, GOT base addr (the rest is closure-captured) -> slot_addr, slot contents *) + +type 'abifeature amd64_abi_feature = + GOT0 of ( (string * ( symbol_definition option))list) + | PLT0 of ( (string * ( symbol_definition option) * 'abifeature plt_entry_content_fn)list) + +(*val abiFeatureCompare : forall 'abifeature. amd64_abi_feature 'abifeature -> amd64_abi_feature 'abifeature -> Basic_classes.ordering*) +let abiFeatureCompare0 f1 f2:int= + ((match (f1, f2) with + (GOT0(_), GOT0(_)) -> 0 + | (GOT0(_), PLT0(_)) -> (-1) + | (PLT0(_), PLT0(_)) -> 0 + | (PLT0(_), GOT0(_)) -> 1 + )) + +(*val abiFeatureTagEq : forall 'abifeature. amd64_abi_feature 'abifeature -> amd64_abi_feature 'abifeature -> bool*) +let abiFeatureTagEq0 f1 f2:bool= + ((match (f1, f2) with + (GOT0(_), GOT0(_)) -> true + | (PLT0(_), PLT0(_)) -> true + | (_, _) -> false + )) + +let instance_Abi_classes_AbiFeatureTagEquiv_Abi_amd64_amd64_abi_feature_dict:('abifeature amd64_abi_feature)abiFeatureTagEquiv_class= ({ + + abiFeatureTagEquiv_method = abiFeatureTagEq0}) + +let instance_Basic_classes_Ord_Abi_amd64_amd64_abi_feature_dict:('abifeature amd64_abi_feature)ord_class= ({ + + compare_method = abiFeatureCompare0; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(abiFeatureCompare0 f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (abiFeatureCompare0 f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(abiFeatureCompare0 f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (abiFeatureCompare0 f1 f2)(Pset.from_list compare [1; 0])))}) + +(*val section_is_special : forall 'abifeature. elf64_interpreted_section -> annotated_memory_image 'abifeature -> bool*) +let section_is_special1 s img2:bool= + (elf_section_is_special s img2 || + (match s.elf64_section_name_as_string with + ".eh_frame" -> true (* HACK needed because SHT_X86_64_UNWIND is often not used *) + | _ -> false + )) diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_elf_header.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_elf_header.ml new file mode 100644 index 00000000..61f36af3 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_elf_header.ml @@ -0,0 +1,60 @@ +(*Generated by Lem from abis/amd64/abi_amd64_elf_header.lem.*) +(** [abi_amd64_elf_header] contains types and definitions relating to ABI + * specific ELF header functionality for the AMD64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Missing_pervasives + +open Elf_header +open Elf_types_native_uint + +open Endianness + +(*val abi_amd64_data_encoding : natural*) +let abi_amd64_data_encoding:Nat_big_num.num= elf_data_2lsb + +(*val abi_amd64_endianness : endianness*) +let abi_amd64_endianness:endianness= Little (* Must match above *) + +(*val abi_amd64_file_class : natural*) +let abi_amd64_file_class:Nat_big_num.num= elf_class_64 + +(*val abi_amd64_file_version : natural*) +let abi_amd64_file_version:Nat_big_num.num= elf_ev_current + +(*val abi_amd64_page_size_min : natural*) +let abi_amd64_page_size_min:Nat_big_num.num= (Nat_big_num.of_int 4096) + +(*val abi_amd64_page_size_max : natural*) +let abi_amd64_page_size_max:Nat_big_num.num= (Nat_big_num.of_int 65536) + +(** [is_valid_abi_amd64_machine_architecture m] checks whether the ELF header's + * machine architecture is valid according to the ABI-specific specification. + * Machine architecture must be x86-64 (pg 60) + *) +(*val is_valid_abi_amd64_machine_architecture : natural -> bool*) +let is_valid_abi_amd64_machine_architecture m:bool= (Nat_big_num.equal + m elf_ma_x86_64) + +(** [is_valid_abi_amd64_magic_number magic] checks whether the ELF header's + * magic number is valid according to the ABI-specific specification. + * File class must be 64-bit (pg 60) + * Data encoding must be little endian (pg 60) + *) +(*val is_valid_abi_amd64_magic_number : list unsigned_char -> bool*) +let is_valid_abi_amd64_magic_number magic:bool= + ((match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_class) with + | None -> false + | Some cls -> + (match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_data) with + | None -> false + | Some data -> + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string cls)) abi_amd64_file_class) && + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string data)) abi_amd64_data_encoding) + ) + )) diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_program_header_table.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_program_header_table.ml new file mode 100644 index 00000000..aa13d087 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_program_header_table.ml @@ -0,0 +1,38 @@ +(*Generated by Lem from abis/amd64/abi_amd64_program_header_table.lem.*) +(** [abi_amd64_program_header_table], program header table specific definitions + * for the AMD64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_num +open Lem_string + +(** New segment types. *) + +(** The segment contains the stack unwind tables *) +let abi_amd64_pt_gnu_eh_frame : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 842691240)) (* 0x6474e550 *) +let abi_amd64_pt_sunw_eh_frame : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 842691240)) (* 0x6474e550 *) +let abi_amd64_pt_sunw_unwind : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 842691240)) (* 0x6474e550 *) + +(** [string_of_abi_amd64_elf_segment_type m] produces a string based representation + * of AMD64 segment type [m]. + *) +(*val string_of_abi_amd64_elf_segment_type : natural -> string*) +let string_of_abi_amd64_elf_segment_type m:string= + (if Nat_big_num.equal m abi_amd64_pt_gnu_eh_frame then + "GNU_EH_FRAME" + else if Nat_big_num.equal m abi_amd64_pt_sunw_eh_frame then + "SUNW_EH_FRAME" + else if Nat_big_num.equal m abi_amd64_pt_sunw_unwind then + "SUNW_UNWIND" + else + "Invalid AMD64 segment type") + +(** [abi_amd64_is_valid_program_interpreter s] checks whether the program interpreter + * string is valid for AMD64 ABI. + * See Section 5.2.1 + *) +(*val abi_amd64_is_valid_program_interpreter : string -> bool*) +let abi_amd64_is_valid_program_interpreter s:bool= + ((s = "/lib/ld64.so.1") || (s = "/lib64/ld-linux-x86-64.so.2")) diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_relocation.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_relocation.ml new file mode 100644 index 00000000..39355f61 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_relocation.ml @@ -0,0 +1,355 @@ +(*Generated by Lem from abis/amd64/abi_amd64_relocation.lem.*) +(** [abi_amd64_relocation] contains types and definitions relating to ABI + * specific relocation functionality for the AMD64 ABI. + *) + +open Lem_basic_classes +open Lem_map +open Lem_maybe +open Lem_num +open Lem_string + +open Error +open Missing_pervasives +open Lem_assert_extra + +open Elf_types_native_uint +open Elf_file +open Elf_header +open Elf_relocation +open Elf_symbol_table +open Memory_image + +open Abi_classes +open Abi_utilities + +(** x86-64 relocation types. *) + +let r_x86_64_none : Nat_big_num.num= (Nat_big_num.of_int 0) +let r_x86_64_64 : Nat_big_num.num= (Nat_big_num.of_int 1) +let r_x86_64_pc32 : Nat_big_num.num= (Nat_big_num.of_int 2) +let r_x86_64_got32 : Nat_big_num.num= (Nat_big_num.of_int 3) +let r_x86_64_plt32 : Nat_big_num.num= (Nat_big_num.of_int 4) +let r_x86_64_copy : Nat_big_num.num= (Nat_big_num.of_int 5) +let r_x86_64_glob_dat : Nat_big_num.num= (Nat_big_num.of_int 6) +let r_x86_64_jump_slot : Nat_big_num.num= (Nat_big_num.of_int 7) +let r_x86_64_relative : Nat_big_num.num= (Nat_big_num.of_int 8) +let r_x86_64_gotpcrel : Nat_big_num.num= (Nat_big_num.of_int 9) +let r_x86_64_32 : Nat_big_num.num= (Nat_big_num.of_int 10) +let r_x86_64_32s : Nat_big_num.num= (Nat_big_num.of_int 11) +let r_x86_64_16 : Nat_big_num.num= (Nat_big_num.of_int 12) +let r_x86_64_pc16 : Nat_big_num.num= (Nat_big_num.of_int 13) +let r_x86_64_8 : Nat_big_num.num= (Nat_big_num.of_int 14) +let r_x86_64_pc8 : Nat_big_num.num= (Nat_big_num.of_int 15) +let r_x86_64_dtpmod64 : Nat_big_num.num= (Nat_big_num.of_int 16) +let r_x86_64_dtpoff64 : Nat_big_num.num= (Nat_big_num.of_int 17) +let r_x86_64_tpoff64 : Nat_big_num.num= (Nat_big_num.of_int 18) +let r_x86_64_tlsgd : Nat_big_num.num= (Nat_big_num.of_int 19) +let r_x86_64_tlsld : Nat_big_num.num= (Nat_big_num.of_int 20) +let r_x86_64_dtpoff32 : Nat_big_num.num= (Nat_big_num.of_int 21) +let r_x86_64_gottpoff : Nat_big_num.num= (Nat_big_num.of_int 22) +let r_x86_64_tpoff32 : Nat_big_num.num= (Nat_big_num.of_int 23) +let r_x86_64_pc64 : Nat_big_num.num= (Nat_big_num.of_int 24) +let r_x86_64_gotoff64 : Nat_big_num.num= (Nat_big_num.of_int 25) +let r_x86_64_gotpc32 : Nat_big_num.num= (Nat_big_num.of_int 26) +let r_x86_64_size32 : Nat_big_num.num= (Nat_big_num.of_int 32) +let r_x86_64_size64 : Nat_big_num.num= (Nat_big_num.of_int 33) +let r_x86_64_gotpc32_tlsdesc : Nat_big_num.num= (Nat_big_num.of_int 34) +let r_x86_64_tlsdesc_call : Nat_big_num.num= (Nat_big_num.of_int 35) +let r_x86_64_tlsdesc : Nat_big_num.num= (Nat_big_num.of_int 36) +let r_x86_64_irelative : Nat_big_num.num= (Nat_big_num.of_int 37) + +(** [string_of_x86_64_relocation_type m] produces a string representation of the + * relocation type [m]. + *) +(*val string_of_amd64_relocation_type : natural -> string*) +let string_of_amd64_relocation_type rel_type1:string= + (if Nat_big_num.equal rel_type1 r_x86_64_none then + "R_X86_64_NONE" + else if Nat_big_num.equal rel_type1 r_x86_64_64 then + "R_X86_64_64" + else if Nat_big_num.equal rel_type1 r_x86_64_pc32 then + "R_X86_64_PC32" + else if Nat_big_num.equal rel_type1 r_x86_64_got32 then + "R_X86_64_GOT32" + else if Nat_big_num.equal rel_type1 r_x86_64_plt32 then + "R_X86_64_PLT32" + else if Nat_big_num.equal rel_type1 r_x86_64_copy then + "R_X86_64_COPY" + else if Nat_big_num.equal rel_type1 r_x86_64_glob_dat then + "R_X86_64_GLOB_DAT" + else if Nat_big_num.equal rel_type1 r_x86_64_jump_slot then + "R_X86_64_JUMP_SLOT" + else if Nat_big_num.equal rel_type1 r_x86_64_relative then + "R_X86_64_RELATIVE" + else if Nat_big_num.equal rel_type1 r_x86_64_gotpcrel then + "R_X86_64_GOTPCREL" + else if Nat_big_num.equal rel_type1 r_x86_64_32 then + "R_X86_64_32" + else if Nat_big_num.equal rel_type1 r_x86_64_32s then + "R_X86_64_32S" + else if Nat_big_num.equal rel_type1 r_x86_64_16 then + "R_X86_64_16" + else if Nat_big_num.equal rel_type1 r_x86_64_pc16 then + "R_X86_64_PC16" + else if Nat_big_num.equal rel_type1 r_x86_64_8 then + "R_X86_64_8" + else if Nat_big_num.equal rel_type1 r_x86_64_pc8 then + "R_X86_64_PC8" + else if Nat_big_num.equal rel_type1 r_x86_64_dtpmod64 then + "R_X86_64_DTPMOD64" + else if Nat_big_num.equal rel_type1 r_x86_64_dtpoff64 then + "R_X86_64_DTPOFF64" + else if Nat_big_num.equal rel_type1 r_x86_64_tpoff64 then + "R_X86_64_TPOFF64" + else if Nat_big_num.equal rel_type1 r_x86_64_tlsgd then + "R_X86_64_TLSGD" + else if Nat_big_num.equal rel_type1 r_x86_64_tlsld then + "R_X86_64_TLSLD" + else if Nat_big_num.equal rel_type1 r_x86_64_dtpoff32 then + "R_X86_64_DTPOFF32" + else if Nat_big_num.equal rel_type1 r_x86_64_gottpoff then + "R_X86_64_GOTTPOFF" + else if Nat_big_num.equal rel_type1 r_x86_64_tpoff32 then + "R_X86_64_TPOFF32" + else if Nat_big_num.equal rel_type1 r_x86_64_pc64 then + "R_X86_64_PC64" + else if Nat_big_num.equal rel_type1 r_x86_64_gotoff64 then + "R_X86_64_GOTOFF64" + else if Nat_big_num.equal rel_type1 r_x86_64_gotpc32 then + "R_X86_64_GOTPC32" + else if Nat_big_num.equal rel_type1 r_x86_64_size32 then + "R_X86_64_SIZE32" + else if Nat_big_num.equal rel_type1 r_x86_64_size64 then + "R_X86_64_SIZE64" + else if Nat_big_num.equal rel_type1 r_x86_64_gotpc32_tlsdesc then + "R_X86_64_GOTPC32_TLSDESC" + else if Nat_big_num.equal rel_type1 r_x86_64_tlsdesc_call then + "R_X86_64_TLSDESC_CALL" + else if Nat_big_num.equal rel_type1 r_x86_64_tlsdesc then + "R_X86_64_TLSDESC" + else if Nat_big_num.equal rel_type1 r_x86_64_irelative then + "R_X86_64_IRELATIVE" + else + "Invalid X86_64 relocation") + +(* How do we find the GOT? *) +(* We really want to find the GOT without knowing how it's labelled, because + * in this file 'abifeature is abstract. This is a real problem. So for now, + * we use the HACK of looking for a section called ".got". + * Even then, we can't understand the content of the GOT without reading the tag. + * + * So we can + * + * - accept an argument of type abi 'abifeature and call a function on it to get the GOT + (but then type abi becomes a recursive record type); + * - extend the AbiFeatureTagEquiv class into a generic class capturing ABIs; + then we risk breaking various things in Isabelle because Lem's type classes don't work there; + * - move the amd64_reloc function to abis.lem and define it only for any_abi_feature. + *) + +(** [abi_amd64_apply_relocation rel val_map ef] + * calculates the effect of a relocation of type [rel] using relevant addresses, + * offsets and fields represented by [b_val], [g_val], [got_val], [l_val], [p_val], + * [s_val] and [z_val], stored in [val_map] with "B", "G", and so on as string + * keys, which are: + * + * - B : Base address at which a shared-object has been loaded into memory + * during execution. + * - G : Represents the offset into the GOT at which the relocation's entry + * will reside during execution. + * - GOT: Address of the GOT. + * - L : Represents the address or offset of the PLT entry for a symbol. + * - P : Represents the address or offset of the storage unit being + * relocated. + * - S : Represents the value of the symbol whose index resides in the + * relocation entry. + * - Z : Represents the size of the symbol whose index resides in the + * relocation entry. + * + * More details of the above can be found in the AMD64 ABI document's chapter + * on relocations. + * + * The [abi_amd64_apply_relocation] function returns a relocation frame, either + * indicating that the relocation is a copy relocation, or that some calculation + * must be carried out at a certain location. See the comment above the + * [relocation_frame] type in [Abi_utilities.lem] for more details. + *) +(*val abi_amd64_apply_relocation : elf64_relocation_a -> val_map string integer -> elf64_file + -> error (relocation_frame elf64_addr integer)*) +let abi_amd64_apply_relocation rel val_map1 ef:(((Uint64.uint64),(Nat_big_num.num))relocation_frame)error= + (if is_elf64_relocatable_file ef.elf64_file_header then + let rel_type1 = (get_elf64_relocation_a_type rel) in + let a_val = (Nat_big_num.of_int64 rel.elf64_ra_addend) in + (** No width, No calculation *) + if Nat_big_num.equal rel_type1 r_x86_64_none then + return (NoCopy ((Pmap.empty compare))) + (** Width: 64 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_64 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)))) + (** Width: 32 Calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_pc32 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare))))) + (** Width: 32 Calculation: G + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_got32 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "G" val_map1 >>= (fun g_val -> + let result = (Lift ( Nat_big_num.add g_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)))) + (** Width: 32 Calculation: L + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_plt32 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "L" val_map1 >>= (fun l_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add l_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare))))) + (** No width, No calculation *) + else if Nat_big_num.equal rel_type1 r_x86_64_copy then + return Copy + (** Width: 64 Calculation: S *) + else if Nat_big_num.equal rel_type1 r_x86_64_glob_dat then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift s_val) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)))) + (** Width: 64 Calculation: S *) + else if Nat_big_num.equal rel_type1 r_x86_64_jump_slot then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift s_val) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)))) + (** Width: 64 Calculation: B + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_relative then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "B" val_map1 >>= (fun b_val -> + let result = (Lift ( Nat_big_num.add b_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)))) + (** Width: 32 Calculation: G + GOT + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_gotpcrel then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "G" val_map1 >>= (fun g_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "GOT" val_map1 >>= (fun got_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add (Nat_big_num.add g_val got_val) a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)))))) + (** Width: 32 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_32 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)))) + (** Width: 32 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_32s then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)))) + (** Width: 16 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_16 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)))) + (** Width: 16 Calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_pc16 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare))))) + (** Width: 8 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_8 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I8, CanFail) (Pmap.empty compare)))) + (** Width 8: Calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_pc8 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I8, CanFail) (Pmap.empty compare))))) + (** Width: 64 *) + else if Nat_big_num.equal rel_type1 r_x86_64_dtpmod64 then + failwith "abi_amd64_apply_relocation: r_x86_64_dtpmod64 not implemented" + (** Width: 64 *) + else if Nat_big_num.equal rel_type1 r_x86_64_dtpoff64 then + failwith "abi_amd64_apply_relocation: r_x86_64_dtpoff64 not implemented" + (** Width: 64 *) + else if Nat_big_num.equal rel_type1 r_x86_64_tpoff64 then + failwith "abi_amd64_apply_relocation: r_x86_64_tpoff64 not implemented" + (** Width: 32 *) + else if Nat_big_num.equal rel_type1 r_x86_64_tlsgd then + failwith "abi_amd64_apply_relocation: r_x86_64_tlsgd not implemented" + (** Width: 32 *) + else if Nat_big_num.equal rel_type1 r_x86_64_tlsld then + failwith "abi_amd64_apply_relocation: r_x86_64_tlsld not implemented" + (** Width: 32 *) + else if Nat_big_num.equal rel_type1 r_x86_64_dtpoff32 then + failwith "abi_amd64_apply_relocation: r_x86_64_dtpoff32 not implemented" + (** Width: 32 *) + else if Nat_big_num.equal rel_type1 r_x86_64_gottpoff then + failwith "abi_amd64_apply_relocation: r_x86_64_gottpoff not implemented" + (** Width: 32 *) + else if Nat_big_num.equal rel_type1 r_x86_64_tpoff32 then + failwith "abi_amd64_apply_relocation: r_x86_64_tpoff32 not implemented" + (** Width: 64 Calculation: S + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_pc64 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare))))) + (** Width: 64 Calculation: S + A - GOT *) + else if Nat_big_num.equal rel_type1 r_x86_64_gotoff64 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "S" val_map1 >>= (fun s_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "GOT" val_map1 >>= (fun got_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) got_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare))))) + (** Width: 32 Calculation: GOT + A - P *) + else if Nat_big_num.equal rel_type1 r_x86_64_gotpc32 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "GOT" val_map1 >>= (fun got_val -> + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "P" val_map1 >>= (fun p_val -> + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add got_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare))))) + (** Width: 32 Calculation: Z + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_size32 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "Z" val_map1 >>= (fun z_val -> + let result = (Lift ( Nat_big_num.add z_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)))) + (** Width: 64 Calculation: Z + A *) + else if Nat_big_num.equal rel_type1 r_x86_64_size64 then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "Z" val_map1 >>= (fun z_val -> + let result = (Lift ( Nat_big_num.add z_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)))) + (** Width: 32 *) + else if Nat_big_num.equal rel_type1 r_x86_64_gotpc32_tlsdesc then + failwith "abi_amd64_apply_relocation: r_x86_64_gotpc32_tlsdesc not implemented" + (** No width *) + else if Nat_big_num.equal rel_type1 r_x86_64_tlsdesc_call then + failwith "abi_amd64_apply_relocation: r_x86_64_tlsdesc_call not implemented" + (** Width: 64X2 *) + else if Nat_big_num.equal rel_type1 r_x86_64_tlsdesc then + failwith "abi_amd64_apply_relocation: r_x86_64_tlsdesc not implemented" + (** Calculation: indirect(B + A) *) + else if Nat_big_num.equal rel_type1 r_x86_64_irelative then + lookupM (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) "B" val_map1 >>= (fun b_val -> + let result = (Apply(Indirect, Lift( Nat_big_num.add b_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (NoCopy (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)))) + else + failwith "abi_amd64_apply_relocation: invalid relocation type" + else + failwith "abi_amd64_apply_relocation: not a relocatable file") diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_section_header_table.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_section_header_table.ml new file mode 100644 index 00000000..f4520a67 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_section_header_table.ml @@ -0,0 +1,51 @@ +(*Generated by Lem from abis/amd64/abi_amd64_section_header_table.lem.*) +(** [abi_amd64_section_header_table] module contains section header table + * specific definitions for the AMD64 ABI. + *) + +open Lem_basic_classes +open Lem_map +open Lem_num + +open Elf_section_header_table + +(** AMD64 specific flags. See Section 4.2.1. *) + +let shf_abi_amd64_large : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 67108864)(Nat_big_num.of_int 4)) (* 0x10000000 *) + +(** AMD64 specific section types. See Section 4.2.2 *) + +let sht_abi_amd64_unwind : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524096)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (* 0x70000001 *) + +(** [string_of_abi_amd64_section_type m] produces a string based representation + * of AMD64 section type [m]. + *) +(*val string_of_abi_amd64_section_type : natural -> string*) +let string_of_abi_amd64_section_type m:string= + (if Nat_big_num.equal m sht_abi_amd64_unwind then + "X86_64_UNWIND" + else + "Invalid AMD64 section type") + +(** Special sections *) + +(*val abi_amd64_special_sections : Map.map string (natural * natural)*) +let abi_amg64_special_sections:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + (".got", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".plt", (sht_progbits, Nat_big_num.add shf_alloc shf_execinstr)) + ; (".eh_frame", (sht_abi_amd64_unwind, shf_alloc)) + ]) + +(*val abi_amd64_special_sections_large_code_model : Map.map string (natural * natural)*) +let abi_amd64_special_sections_large_code_model:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + (".lbss", (sht_nobits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_abi_amd64_large)) + ; (".ldata", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_abi_amd64_large)) + ; (".ldata1", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_abi_amd64_large)) + ; (".lgot", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_abi_amd64_large)) + ; (".lplt", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_execinstr) shf_abi_amd64_large)) + ; (".lrodata", (sht_progbits, Nat_big_num.add shf_alloc shf_abi_amd64_large)) + ; (".lrodata1", (sht_progbits, Nat_big_num.add shf_alloc shf_abi_amd64_large)) + ; (".ltext", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_execinstr) shf_abi_amd64_large)) + ]) diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_serialisation.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_serialisation.ml new file mode 100644 index 00000000..6656e896 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_serialisation.ml @@ -0,0 +1,282 @@ +(*Generated by Lem from abis/amd64/abi_amd64_serialisation.lem.*) +(** [abi_amd64_serialisation] contains code for producing an AMD64 conformant + * ELF file from executable (machine) code. + * Used in ongoing experiments with CakeML. + * + * XXX: experimental, and outdated. Commented out for now until attention turns + * to CakeML again. + *) + +open Lem_basic_classes +open Lem_list +open Lem_maybe +open Lem_num + +open Byte_sequence +open Missing_pervasives + +open Memory_image +open Elf_file +open Elf_header +open Elf_interpreted_segment +open Elf_program_header_table +open Elf_section_header_table +open Elf_types_native_uint + +open Abi_amd64_elf_header + +(* +(** [abi_amd64_elf_ident abi_version] produces the ELF identification field for + * the ELF header based on ABI-specific information and the [abi_version] + * argument passed in. + *) +val abi_amd64_elf_ident : natural -> list unsigned_char +let abi_amd64_elf_ident abi_version = + List.map unsigned_char_of_natural + [127; 69; 76; 70; (* 127 E L F *) + abi_amd64_file_class; abi_amd64_data_encoding; abi_amd64_file_version; + elf_osabi_none; abi_version; 0; + 0; 0; 0; + 0; 0; 0] + +(** [abi_amd64_generate_elf_header entry phoff phnum] produces an ELF header for + * 64-bit PPC ELF files. The function expects the [entry] address to start + * execution from, the offset of the program header table in [phoff] and the + * number of entries in the program header table in [phnum]. + *) +val abi_amd64_generate_elf_header : elf64_addr -> elf64_off -> elf64_half -> elf64_header +let abi_amd64_generate_elf_header entry phoff phnum = + <| elf64_ident = abi_amd64_elf_ident 0; + elf64_type = elf64_half_of_natural elf_ft_exec; + elf64_machine = elf64_half_of_natural elf_ma_x86_64; + elf64_version = elf64_word_of_natural elf_ev_current; + elf64_entry = entry; + elf64_phoff = phoff; + elf64_shoff = elf64_off_of_natural 0; + elf64_flags = elf64_word_of_natural 0; + elf64_ehsize = elf64_half_of_natural 64; + elf64_phentsize = elf64_half_of_natural 56; + elf64_phnum = phnum; + elf64_shentsize = elf64_half_of_natural 0; + elf64_shnum = elf64_half_of_natural 0; + elf64_shstrndx = elf64_half_of_natural shn_undef + |> + +val elf64_pack_segment_flags : (bool * bool * bool) -> elf64_word +let elf64_pack_segment_flags (r, w, x) = + let xflag = 1 * natural_of_bool x in + let wflag = 2 * natural_of_bool w in + let rflag = 4 * natural_of_bool r in + elf64_word_of_natural (xflag + wflag + rflag) + +val elf64_header_size : natural +let elf64_header_size = 64 + +val elf64_program_header_table_entry_size : natural +let elf64_program_header_table_entry_size = 56 + +val exec_entry_offset : natural +let exec_entry_offset = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + +val code_heap_entry_offset : natural -> natural +let code_heap_entry_offset exec_size = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + exec_size + +val data_heap_entry_offset : natural -> natural -> natural +let data_heap_entry_offset exec_size code_heap_size = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + exec_size + code_heap_size + +val abi_amd64_generate_program_header_table : elf64_interpreted_segment -> elf64_interpreted_segment -> elf64_interpreted_segment -> elf64_program_header_table +let abi_amd64_generate_program_header_table exec code_heap data_heap = + (* exec segment and then base *) + let exec_header = + <| elf64_p_type = elf64_word_of_natural exec.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags exec.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural exec.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural exec.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural exec.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural exec.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural exec.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural exec.elf64_segment_align |> + in + let code_heap_header = + <| elf64_p_type = elf64_word_of_natural code_heap.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags code_heap.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural code_heap.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural code_heap.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural code_heap.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural code_heap.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural code_heap.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural code_heap.elf64_segment_align |> + in + let data_heap_header = + <| elf64_p_type = elf64_word_of_natural data_heap.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags data_heap.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural data_heap.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural data_heap.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural data_heap.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural data_heap.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural data_heap.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural data_heap.elf64_segment_align |> + in + [exec_header; code_heap_header; data_heap_header] + +val abi_amd64_generate_exec_interpreted_segment : natural -> natural -> byte_sequence -> elf64_interpreted_segment +let abi_amd64_generate_exec_interpreted_segment vma offset exec_code = + let segment_size = Byte_sequence.length exec_code in + <| elf64_segment_body = exec_code; + elf64_segment_size = segment_size; + elf64_segment_memsz = segment_size; + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_amd64_page_size_max; + elf64_segment_flags = (true, false, true); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = offset + |> + +val abi_amd64_generate_code_heap_interpreted_segment : natural -> natural -> natural -> elf64_interpreted_segment +let abi_amd64_generate_code_heap_interpreted_segment vma offset segment_size = + let seg = Byte_sequence.create segment_size Missing_pervasives.null_byte in + <| elf64_segment_body = seg; + elf64_segment_size = segment_size; + elf64_segment_memsz = segment_size; + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_amd64_page_size_max; + elf64_segment_flags = (true, true, true); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = offset + |> + +val abi_amd64_entry_point_addr : natural +let abi_amd64_entry_point_addr = 4194304 (* 0x400000 *) + +val abi_amd64_code_heap_addr : natural +let abi_amd64_code_heap_addr = 67108864 (* 16 * 4194304 *) + +val abi_amd64_data_heap_addr : natural +let abi_amd64_data_heap_addr = 67108864 * 16 + +val quad_le_bytes_of_natural : natural -> byte * byte * byte * byte +let quad_le_bytes_of_natural m = + let conv = elf64_addr_of_natural m in + let b0 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land conv (elf64_addr_of_natural 255))) in + let b1 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 8) (elf64_addr_of_natural 255))) in + let b2 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 16) (elf64_addr_of_natural 255))) in + let b3 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 24) (elf64_addr_of_natural 255))) in + (b0, b1, b2, b3) + +val abi_amd64_generate_data_heap_interpreted_segment : natural -> natural -> natural -> natural -> elf64_interpreted_segment +let abi_amd64_generate_data_heap_interpreted_segment vma off segment_size code_heap_size = + let (d0, d1, d2, d3) = quad_le_bytes_of_natural segment_size in + let (c0, c1, c2, c3) = quad_le_bytes_of_natural abi_amd64_code_heap_addr in + let (sz0, sz1, sz2, sz3) = quad_le_bytes_of_natural code_heap_size in + let (pc0, pc1, pc2, pc3) = quad_le_bytes_of_natural 0 in + let (gc0, gc1, gc2, gc3) = quad_le_bytes_of_natural 0 in + let preamble = Byte_sequence.from_byte_lists [[ + d0; d1; d2; d3; null_byte; null_byte; null_byte; null_byte; + c0; c1; c2; c3; null_byte; null_byte; null_byte; null_byte; + sz0; sz1; sz2; sz3; null_byte; null_byte; null_byte; null_byte; + pc0; pc1; pc2; pc3; null_byte; null_byte; null_byte; null_byte; + gc0; gc1; gc2; gc3; null_byte; null_byte; null_byte; null_byte + ]] in + <| elf64_segment_body = preamble; + elf64_segment_size = Byte_sequence.length preamble; + elf64_segment_memsz = max segment_size (Byte_sequence.length preamble); + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_amd64_page_size_max; + elf64_segment_flags = (true, true, false); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = off + |> + +val init_data_heap_instrs : byte_sequence +let init_data_heap_instrs = + let (b0, b1, b2, b3) = quad_le_bytes_of_natural abi_amd64_data_heap_addr in + Byte_sequence.from_byte_lists + [[ byte_of_natural 72 + ; byte_of_natural 199 + ; byte_of_natural 68 + ; byte_of_natural 36 + ; byte_of_natural 248 + ; b0 + ; b1 + ; b2 + ; b3 + ; byte_of_natural 72 + ; byte_of_natural 139 + ; byte_of_natural 68 + ; byte_of_natural 36 + ; byte_of_natural 248 + ]] + +val exit_syscall_instrs : byte_sequence +let exit_syscall_instrs = + Byte_sequence.from_byte_lists + [[ + byte_of_natural 72; + byte_of_natural 199; + byte_of_natural 192; + byte_of_natural 60; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 15; + byte_of_natural 5 + ]] + +val push_instr : natural -> byte_sequence +let push_instr addr = + let (b0, b1, b2, b3) = quad_le_bytes_of_natural addr in + Byte_sequence.from_byte_lists [[ + byte_of_natural 104; + b0; b1; b2; b3 + ]] + +val setup_return_code_instr : byte_sequence +let setup_return_code_instr = + Byte_sequence.from_byte_lists [[ + byte_of_natural 191; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0 + ]] + +val abi_amd64_generate_executable_file : byte_sequence -> natural -> natural -> elf64_file +let abi_amd64_generate_executable_file exec_code code_heap_size data_heap_size = + let exec_code' = Byte_sequence.concat [ + init_data_heap_instrs; + exec_code + ] in + let pre_entry = 5 + abi_amd64_entry_point_addr + Byte_sequence.length exec_code' in + let exec_code = Byte_sequence.concat [push_instr pre_entry; exec_code'; setup_return_code_instr; exit_syscall_instrs] in + let hdr = abi_amd64_generate_elf_header + (elf64_addr_of_natural abi_amd64_entry_point_addr) + (elf64_off_of_natural 64) (elf64_half_of_natural 3) in + let exec_off_i = 64 + 3 * 56 in + let exec_off_adj = compute_virtual_address_adjustment abi_amd64_page_size_max exec_off_i abi_amd64_entry_point_addr in + let exec_off = exec_off_i + exec_off_adj in + let exec = abi_amd64_generate_exec_interpreted_segment + abi_amd64_entry_point_addr exec_off exec_code in + let code_off_i = exec_off + exec.elf64_segment_size in + let code_off_adj = compute_virtual_address_adjustment abi_amd64_page_size_max code_off_i abi_amd64_code_heap_addr in + let code_off = code_off_i + code_off_adj in + let code_heap = abi_amd64_generate_code_heap_interpreted_segment + abi_amd64_code_heap_addr code_off code_heap_size in + let data_off_i = code_off + code_heap.elf64_segment_size in + let data_off_adj = compute_virtual_address_adjustment abi_amd64_page_size_max data_off_i abi_amd64_data_heap_addr in + let data_off = data_off_i + data_off_adj in + let data_heap = abi_amd64_generate_data_heap_interpreted_segment + abi_amd64_data_heap_addr data_off data_heap_size code_heap_size in + let pht = abi_amd64_generate_program_header_table + exec code_heap data_heap in + <| elf64_file_header = hdr; elf64_file_program_header_table = pht; + elf64_file_interpreted_segments = [exec; code_heap; data_heap]; + elf64_file_interpreted_sections = []; + elf64_file_section_header_table = []; + elf64_file_bits_and_bobs = [] |> +*) diff --git a/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_symbol_table.ml b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_symbol_table.ml new file mode 100644 index 00000000..47b05e4c --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/amd64/abi_amd64_symbol_table.ml @@ -0,0 +1,22 @@ +(*Generated by Lem from abis/amd64/abi_amd64_symbol_table.lem.*) +(** [abi_amd64_symbol_table], AMD64 ABI specific definitions for the ELF symbol + * table. + *) + +open Lem_basic_classes +open Lem_num +open Gnu_ext_abi + +(** AMD64 specific symbol types. See doc/ifunc.txt and Section 4.3 of the + * ABI. + *) + +(** [string_of_abi_amd64_symbol_type m] produces a string based representation + * of AMD64 symbol type [m]. + *) +(*val string_of_abi_amd64_symbol_type : natural -> string*) +let string_of_abi_amd64_symbol_type m:string= + (if Nat_big_num.equal m stt_gnu_ifunc then + "GNU_IFUNC" + else + "Invalid AMD64 symbol type") diff --git a/lib/ocaml_rts/linksem/abis/mips64/abi_mips64.ml b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64.ml new file mode 100644 index 00000000..9e86b537 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64.ml @@ -0,0 +1,88 @@ +(*Generated by Lem from abis/mips64/abi_mips64.lem.*) +(** [abi_mips64] contains top-level definition for the MIPS64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Error +open Lem_map +open Lem_assert_extra + +open Missing_pervasives +open Elf_header +open Elf_types_native_uint +open Elf_file +open Elf_interpreted_segment +open Elf_interpreted_section + +open Endianness +open Memory_image +(* open import Elf_memory_image *) + +open Abi_classes +(*open import Abi_mips64_relocation*) +open Abi_mips64_elf_header + +(** [abi_mips64_compute_program_entry_point segs entry] computes the program + * entry point using ABI-specific conventions. On MIPS64 the entry point in + * the ELF header ([entry] here) is the real entry point. On other ABIs, e.g. + * PowerPC64, the entry point [entry] is a pointer into one of the segments + * constituting the process image (passed in as [segs] here for a uniform + * interface). + *) +(*val abi_mips64_compute_program_entry_point : list elf64_interpreted_segments -> elf64_addr -> error natural*) +let abi_mips64_compute_program_entry_point segs entry:(Nat_big_num.num)error= + (return (Ml_bindings.nat_big_num_of_uint64 entry)) + +(*val header_is_mips64 : elf64_header -> bool*) +let header_is_mips64 h:bool= + (is_valid_elf64_header h + && ((Lem.option_equal (=) (Lem_list.list_index h.elf64_ident (Nat_big_num.to_int elf_ii_data)) (Some (Uint32.of_string (Nat_big_num.to_string elf_data_2msb)))) + && (is_valid_abi_mips64_machine_architecture (Nat_big_num.of_string (Uint32.to_string h.elf64_machine)) + && is_valid_abi_mips64_magic_number h.elf64_ident))) + +type 'abifeature plt_entry_address_fn = Nat_big_num.num (* offset in PLT? *) -> 'abifeature annotated_memory_image (* img *) -> Nat_big_num.num (* addr *) + +type 'abifeature mips64_abi_feature = + GOT1 of ( (string * ( symbol_definition option))list) + | PLT1 of ( (string * ( symbol_definition option) * 'abifeature plt_entry_address_fn)list) + +(*val abiFeatureCompare : forall 'abifeature. mips64_abi_feature 'abifeature -> mips64_abi_feature 'abifeature -> Basic_classes.ordering*) +let abiFeatureCompare1 f1 f2:int= + ((match (f1, f2) with + (GOT1(_), GOT1(_)) -> 0 + | (GOT1(_), PLT1(_)) -> (-1) + | (PLT1(_), PLT1(_)) -> 0 + | (PLT1(_), GOT1(_)) -> 1 + )) + +(*val abiFeatureTagEq : forall 'abifeature. mips64_abi_feature 'abifeature -> mips64_abi_feature 'abifeature -> bool*) +let abiFeatureTagEq1 f1 f2:bool= + ((match (f1, f2) with + (GOT1(_), GOT1(_)) -> true + | (PLT1(_), PLT1(_)) -> true + | (_, _) -> false + )) + +let instance_Abi_classes_AbiFeatureTagEquiv_Abi_mips64_mips64_abi_feature_dict:('abifeature mips64_abi_feature)abiFeatureTagEquiv_class= ({ + + abiFeatureTagEquiv_method = abiFeatureTagEq1}) + +let instance_Basic_classes_Ord_Abi_mips64_mips64_abi_feature_dict:('abifeature mips64_abi_feature)ord_class= ({ + + compare_method = abiFeatureCompare1; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(abiFeatureCompare1 f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (abiFeatureCompare1 f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(abiFeatureCompare1 f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (abiFeatureCompare1 f1 f2)(Pset.from_list compare [1; 0])))}) + +(*val section_is_special : forall 'abifeature. elf64_interpreted_section -> annotated_memory_image 'abifeature -> bool*) +let section_is_special2 s img2:bool= + (elf_section_is_special s img2) diff --git a/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_elf_header.ml b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_elf_header.ml new file mode 100644 index 00000000..90193916 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_elf_header.ml @@ -0,0 +1,59 @@ +(*Generated by Lem from abis/mips64/abi_mips64_elf_header.lem.*) +(** [abi_mips64_elf_header] contains types and definitions relating to ABI + * specific ELF header functionality for the MIPS64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Missing_pervasives + +open Elf_header +open Elf_types_native_uint + +open Endianness + +(*val abi_mips64_data_encoding : natural*) +let abi_mips64_data_encoding:Nat_big_num.num= elf_data_2msb + +(*val abi_mips64_endianness : endianness*) +let abi_mips64_endianness:endianness= Big (* Must match above *) + +(*val abi_mips64_file_class : natural*) +let abi_mips64_file_class:Nat_big_num.num= elf_class_64 + +(*val abi_mips64_file_version : natural*) +let abi_mips64_file_version:Nat_big_num.num= elf_ev_current + +(*val abi_mips64_page_size_min : natural*) +let abi_mips64_page_size_min:Nat_big_num.num= (Nat_big_num.of_int 4096) + +(*val abi_mips64_page_size_max : natural*) +let abi_mips64_page_size_max:Nat_big_num.num= (Nat_big_num.of_int 65536) + +(** [is_valid_abi_mips64_machine_architecture m] checks whether the ELF header's + * machine architecture is valid according to the ABI-specific specification. + *) +(*val is_valid_abi_mips64_machine_architecture : natural -> bool*) +let is_valid_abi_mips64_machine_architecture m:bool= (Nat_big_num.equal + m elf_ma_mips) + +(** [is_valid_abi_mips64_magic_number magic] checks whether the ELF header's + * magic number is valid according to the ABI-specific specification. + * File class must be 64-bit (pg 60) + * Data encoding must be little endian (pg 60) + *) +(*val is_valid_abi_mips64_magic_number : list unsigned_char -> bool*) +let is_valid_abi_mips64_magic_number magic:bool= + ((match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_class) with + | None -> false + | Some cls -> + (match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_data) with + | None -> false + | Some data -> + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string cls)) abi_mips64_file_class) && + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string data)) abi_mips64_data_encoding) + ) + )) diff --git a/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_program_header_table.ml b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_program_header_table.ml new file mode 100644 index 00000000..d1a4a1fa --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_program_header_table.ml @@ -0,0 +1,38 @@ +(*Generated by Lem from abis/mips64/abi_mips64_program_header_table.lem.*) +(** [abi_mips64_program_header_table], program header table specific definitions + * for the MIPS64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_num +open Lem_string + +(** New segment types. *) + +(** The segment contains the stack unwind tables *) +let abi_mips64_pt_gnu_eh_frame : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 842691240)) (* 0x6474e550 *) +let abi_mips64_pt_sunw_eh_frame : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 842691240)) (* 0x6474e550 *) +let abi_mips64_pt_sunw_unwind : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 842691240)) (* 0x6474e550 *) + +(** [string_of_abi_mips64_elf_segment_type m] produces a string based representation + * of MIPS64 segment type [m]. + *) +(*val string_of_abi_mips64_elf_segment_type : natural -> string*) +let string_of_abi_mips64_elf_segment_type m:string= + (if Nat_big_num.equal m abi_mips64_pt_gnu_eh_frame then + "GNU_EH_FRAME" + else if Nat_big_num.equal m abi_mips64_pt_sunw_eh_frame then + "SUNW_EH_FRAME" + else if Nat_big_num.equal m abi_mips64_pt_sunw_unwind then + "SUNW_UNWIND" + else + "Invalid MIPS64 segment type") + +(** [abi_mips64_is_valid_program_interpreter s] checks whether the program interpreter + * string is valid for MIPS64 ABI. + * See Section XXX FIXME + *) +(*val abi_mips64_is_valid_program_interpreter : string -> bool*) +let abi_mips64_is_valid_program_interpreter s:bool= + (s = "/lib/ld64.so.1") diff --git a/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_section_header_table.ml b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_section_header_table.ml new file mode 100644 index 00000000..3df8365f --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_section_header_table.ml @@ -0,0 +1,37 @@ +(*Generated by Lem from abis/mips64/abi_mips64_section_header_table.lem.*) +(** [abi_mips64_section_header_table] module contains section header table + * specific definitions for the MIPS64 ABI. + *) + +open Lem_basic_classes +open Lem_map +open Lem_num + +open Elf_section_header_table + +(** MIPS64 specific flags. See Section XXX FIXME. *) + +(** MIPS64 specific section types. See Section XXX FIXME *) + +(** [string_of_abi_mips64_section_type m] produces a string based representation + * of MIPS64 section type [m]. + *) +(*val string_of_abi_mips64_section_type : natural -> string*) +let string_of_abi_mips64_section_type m:string= + "Invalid MIPS64 section type" + +(** Special sections *) + +(*val abi_mips64_special_sections : Map.map string (natural * natural)*) +let abi_amg64_special_sections0:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + (".got", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".plt", (sht_progbits, Nat_big_num.add shf_alloc shf_execinstr)) + (* FIXME ; (".eh_frame", (sht_abi_mips64_unwind, shf_alloc)) *) + ]) + +(*val abi_mips64_special_sections_large_code_model : Map.map string (natural * natural)*) +let abi_mips64_special_sections_large_code_model:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + (* FIXME *) + ]) diff --git a/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_serialisation.ml b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_serialisation.ml new file mode 100644 index 00000000..febc9c30 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_serialisation.ml @@ -0,0 +1,282 @@ +(*Generated by Lem from abis/mips64/abi_mips64_serialisation.lem.*) +(** [abi_mips64_serialisation] contains code for producing an MIPS64 conformant + * ELF file from executable (machine) code. + * Used in ongoing experiments with CakeML. + * + * XXX: experimental, and outdated. Commented out for now until attention turns + * to CakeML again. + *) + +open Lem_basic_classes +open Lem_list +open Lem_maybe +open Lem_num + +open Byte_sequence +open Missing_pervasives + +open Memory_image +open Elf_file +open Elf_header +open Elf_interpreted_segment +open Elf_program_header_table +open Elf_section_header_table +open Elf_types_native_uint + +open Abi_mips64_elf_header + +(* +(** [abi_mips64_elf_ident abi_version] produces the ELF identification field for + * the ELF header based on ABI-specific information and the [abi_version] + * argument passed in. + *) +val abi_mips64_elf_ident : natural -> list unsigned_char +let abi_mips64_elf_ident abi_version = + List.map unsigned_char_of_natural + [127; 69; 76; 70; (* 127 E L F *) + abi_mips64_file_class; abi_mips64_data_encoding; abi_mips64_file_version; + elf_osabi_none; abi_version; 0; + 0; 0; 0; + 0; 0; 0] + +(** [abi_mips64_generate_elf_header entry phoff phnum] produces an ELF header for + * 64-bit PPC ELF files. The function expects the [entry] address to start + * execution from, the offset of the program header table in [phoff] and the + * number of entries in the program header table in [phnum]. + *) +val abi_mips64_generate_elf_header : elf64_addr -> elf64_off -> elf64_half -> elf64_header +let abi_mips64_generate_elf_header entry phoff phnum = + <| elf64_ident = abi_mips64_elf_ident 0; + elf64_type = elf64_half_of_natural elf_ft_exec; + elf64_machine = elf64_half_of_natural elf_ma_mips; + elf64_version = elf64_word_of_natural elf_ev_current; + elf64_entry = entry; + elf64_phoff = phoff; + elf64_shoff = elf64_off_of_natural 0; + elf64_flags = elf64_word_of_natural 0; + elf64_ehsize = elf64_half_of_natural 64; + elf64_phentsize = elf64_half_of_natural 56; + elf64_phnum = phnum; + elf64_shentsize = elf64_half_of_natural 0; + elf64_shnum = elf64_half_of_natural 0; + elf64_shstrndx = elf64_half_of_natural shn_undef + |> + +val elf64_pack_segment_flags : (bool * bool * bool) -> elf64_word +let elf64_pack_segment_flags (r, w, x) = + let xflag = 1 * natural_of_bool x in + let wflag = 2 * natural_of_bool w in + let rflag = 4 * natural_of_bool r in + elf64_word_of_natural (xflag + wflag + rflag) + +val elf64_header_size : natural +let elf64_header_size = 64 + +val elf64_program_header_table_entry_size : natural +let elf64_program_header_table_entry_size = 56 + +val exec_entry_offset : natural +let exec_entry_offset = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + +val code_heap_entry_offset : natural -> natural +let code_heap_entry_offset exec_size = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + exec_size + +val data_heap_entry_offset : natural -> natural -> natural +let data_heap_entry_offset exec_size code_heap_size = + elf64_header_size + (elf64_program_header_table_entry_size * 3) + exec_size + code_heap_size + +val abi_mips64_generate_program_header_table : elf64_interpreted_segment -> elf64_interpreted_segment -> elf64_interpreted_segment -> elf64_program_header_table +let abi_mips64_generate_program_header_table exec code_heap data_heap = + (* exec segment and then base *) + let exec_header = + <| elf64_p_type = elf64_word_of_natural exec.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags exec.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural exec.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural exec.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural exec.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural exec.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural exec.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural exec.elf64_segment_align |> + in + let code_heap_header = + <| elf64_p_type = elf64_word_of_natural code_heap.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags code_heap.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural code_heap.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural code_heap.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural code_heap.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural code_heap.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural code_heap.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural code_heap.elf64_segment_align |> + in + let data_heap_header = + <| elf64_p_type = elf64_word_of_natural data_heap.elf64_segment_type; + elf64_p_flags = elf64_pack_segment_flags data_heap.elf64_segment_flags; + elf64_p_offset = elf64_off_of_natural data_heap.elf64_segment_offset; + elf64_p_vaddr = elf64_addr_of_natural data_heap.elf64_segment_base; + elf64_p_paddr = elf64_addr_of_natural data_heap.elf64_segment_paddr; + elf64_p_filesz = elf64_xword_of_natural data_heap.elf64_segment_size; + elf64_p_memsz = elf64_xword_of_natural data_heap.elf64_segment_memsz; + elf64_p_align = elf64_xword_of_natural data_heap.elf64_segment_align |> + in + [exec_header; code_heap_header; data_heap_header] + +val abi_mips64_generate_exec_interpreted_segment : natural -> natural -> byte_sequence -> elf64_interpreted_segment +let abi_mips64_generate_exec_interpreted_segment vma offset exec_code = + let segment_size = Byte_sequence.length exec_code in + <| elf64_segment_body = exec_code; + elf64_segment_size = segment_size; + elf64_segment_memsz = segment_size; + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_mips64_page_size_max; + elf64_segment_flags = (true, false, true); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = offset + |> + +val abi_mips64_generate_code_heap_interpreted_segment : natural -> natural -> natural -> elf64_interpreted_segment +let abi_mips64_generate_code_heap_interpreted_segment vma offset segment_size = + let seg = Byte_sequence.create segment_size Missing_pervasives.null_byte in + <| elf64_segment_body = seg; + elf64_segment_size = segment_size; + elf64_segment_memsz = segment_size; + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_mips64_page_size_max; + elf64_segment_flags = (true, true, true); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = offset + |> + +val abi_mips64_entry_point_addr : natural +let abi_mips64_entry_point_addr = 4194304 (* 0x400000 *) + +val abi_mips64_code_heap_addr : natural +let abi_mips64_code_heap_addr = 67108864 (* 16 * 4194304 *) + +val abi_mips64_data_heap_addr : natural +let abi_mips64_data_heap_addr = 67108864 * 16 + +val quad_le_bytes_of_natural : natural -> byte * byte * byte * byte +let quad_le_bytes_of_natural m = + let conv = elf64_addr_of_natural m in + let b0 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land conv (elf64_addr_of_natural 255))) in + let b1 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 8) (elf64_addr_of_natural 255))) in + let b2 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 16) (elf64_addr_of_natural 255))) in + let b3 = byte_of_natural (natural_of_elf64_addr (elf64_addr_land (elf64_addr_rshift conv 24) (elf64_addr_of_natural 255))) in + (b0, b1, b2, b3) + +val abi_mips64_generate_data_heap_interpreted_segment : natural -> natural -> natural -> natural -> elf64_interpreted_segment +let abi_mips64_generate_data_heap_interpreted_segment vma off segment_size code_heap_size = + let (d0, d1, d2, d3) = quad_le_bytes_of_natural segment_size in + let (c0, c1, c2, c3) = quad_le_bytes_of_natural abi_mips64_code_heap_addr in + let (sz0, sz1, sz2, sz3) = quad_le_bytes_of_natural code_heap_size in + let (pc0, pc1, pc2, pc3) = quad_le_bytes_of_natural 0 in + let (gc0, gc1, gc2, gc3) = quad_le_bytes_of_natural 0 in + let preamble = Byte_sequence.from_byte_lists [[ + d0; d1; d2; d3; null_byte; null_byte; null_byte; null_byte; + c0; c1; c2; c3; null_byte; null_byte; null_byte; null_byte; + sz0; sz1; sz2; sz3; null_byte; null_byte; null_byte; null_byte; + pc0; pc1; pc2; pc3; null_byte; null_byte; null_byte; null_byte; + gc0; gc1; gc2; gc3; null_byte; null_byte; null_byte; null_byte + ]] in + <| elf64_segment_body = preamble; + elf64_segment_size = Byte_sequence.length preamble; + elf64_segment_memsz = max segment_size (Byte_sequence.length preamble); + elf64_segment_base = vma; + elf64_segment_paddr = 0; + elf64_segment_align = abi_mips64_page_size_max; + elf64_segment_flags = (true, true, false); + elf64_segment_type = elf_pt_load; + elf64_segment_offset = off + |> + +val init_data_heap_instrs : byte_sequence +let init_data_heap_instrs = + let (b0, b1, b2, b3) = quad_le_bytes_of_natural abi_mips64_data_heap_addr in + Byte_sequence.from_byte_lists + [[ byte_of_natural 72 + ; byte_of_natural 199 + ; byte_of_natural 68 + ; byte_of_natural 36 + ; byte_of_natural 248 + ; b0 + ; b1 + ; b2 + ; b3 + ; byte_of_natural 72 + ; byte_of_natural 139 + ; byte_of_natural 68 + ; byte_of_natural 36 + ; byte_of_natural 248 + ]] + +val exit_syscall_instrs : byte_sequence +let exit_syscall_instrs = + Byte_sequence.from_byte_lists + [[ + byte_of_natural 72; + byte_of_natural 199; + byte_of_natural 192; + byte_of_natural 60; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 15; + byte_of_natural 5 + ]] + +val push_instr : natural -> byte_sequence +let push_instr addr = + let (b0, b1, b2, b3) = quad_le_bytes_of_natural addr in + Byte_sequence.from_byte_lists [[ + byte_of_natural 104; + b0; b1; b2; b3 + ]] + +val setup_return_code_instr : byte_sequence +let setup_return_code_instr = + Byte_sequence.from_byte_lists [[ + byte_of_natural 191; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0; + byte_of_natural 0 + ]] + +val abi_mips64_generate_executable_file : byte_sequence -> natural -> natural -> elf64_file +let abi_mips64_generate_executable_file exec_code code_heap_size data_heap_size = + let exec_code' = Byte_sequence.concat [ + init_data_heap_instrs; + exec_code + ] in + let pre_entry = 5 + abi_mips64_entry_point_addr + Byte_sequence.length exec_code' in + let exec_code = Byte_sequence.concat [push_instr pre_entry; exec_code'; setup_return_code_instr; exit_syscall_instrs] in + let hdr = abi_mips64_generate_elf_header + (elf64_addr_of_natural abi_mips64_entry_point_addr) + (elf64_off_of_natural 64) (elf64_half_of_natural 3) in + let exec_off_i = 64 + 3 * 56 in + let exec_off_adj = compute_virtual_address_adjustment abi_mips64_page_size_max exec_off_i abi_mips64_entry_point_addr in + let exec_off = exec_off_i + exec_off_adj in + let exec = abi_mips64_generate_exec_interpreted_segment + abi_mips64_entry_point_addr exec_off exec_code in + let code_off_i = exec_off + exec.elf64_segment_size in + let code_off_adj = compute_virtual_address_adjustment abi_mips64_page_size_max code_off_i abi_mips64_code_heap_addr in + let code_off = code_off_i + code_off_adj in + let code_heap = abi_mips64_generate_code_heap_interpreted_segment + abi_mips64_code_heap_addr code_off code_heap_size in + let data_off_i = code_off + code_heap.elf64_segment_size in + let data_off_adj = compute_virtual_address_adjustment abi_mips64_page_size_max data_off_i abi_mips64_data_heap_addr in + let data_off = data_off_i + data_off_adj in + let data_heap = abi_mips64_generate_data_heap_interpreted_segment + abi_mips64_data_heap_addr data_off data_heap_size code_heap_size in + let pht = abi_mips64_generate_program_header_table + exec code_heap data_heap in + <| elf64_file_header = hdr; elf64_file_program_header_table = pht; + elf64_file_interpreted_segments = [exec; code_heap; data_heap]; + elf64_file_interpreted_sections = []; + elf64_file_section_header_table = []; + elf64_file_bits_and_bobs = [] |> +*) diff --git a/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_symbol_table.ml b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_symbol_table.ml new file mode 100644 index 00000000..4889556b --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/mips64/abi_mips64_symbol_table.ml @@ -0,0 +1,22 @@ +(*Generated by Lem from abis/mips64/abi_mips64_symbol_table.lem.*) +(** [abi_mips64_symbol_table], MIPS64 ABI specific definitions for the ELF symbol + * table. + *) + +open Lem_basic_classes +open Lem_num +open Gnu_ext_abi + +(** MIPS64 specific symbol types. See doc/ifunc.txt and Section XXX FIXME of the + * ABI. + *) + +(** [string_of_abi_mips64_symbol_type m] produces a string based representation + * of MIPS64 symbol type [m]. + *) +(*val string_of_abi_mips64_symbol_type : natural -> string*) +let string_of_abi_mips64_symbol_type m:string= + (if Nat_big_num.equal m stt_gnu_ifunc then + "GNU_IFUNC" + else + "Invalid MIPS64 symbol type") diff --git a/lib/ocaml_rts/linksem/abis/power64/abi_power64.ml b/lib/ocaml_rts/linksem/abis/power64/abi_power64.ml new file mode 100644 index 00000000..aea13a79 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/power64/abi_power64.ml @@ -0,0 +1,46 @@ +(*Generated by Lem from abis/power64/abi_power64.lem.*) +(** [abi_power64] contains top-level definition for the PowerPC64 ABI. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe + +open Byte_sequence +open Error +open Missing_pervasives + +open Elf_header +open Elf_types_native_uint +open Elf_file +open Elf_interpreted_segment + +(** [abi_power64_compute_program_entry_point segs entry] computes the program + * entry point using ABI-specific conventions. On Power64 the entry point in + * the ELF header ([entry] here) is a pointer into a program segment that + * contains the "real" entry point. On other ABIs, e.g. + * AArch64 and AMD64, the entry point in the ELF header [entry] is the actual + * program entry point. + *) +(*val abi_power64_compute_program_entry_point : list elf64_interpreted_segment -> elf64_addr -> error natural*) +let abi_power64_compute_program_entry_point segs entry:(Nat_big_num.num)error= + (let entry = (Ml_bindings.nat_big_num_of_uint64 entry) in + let filtered = (List.filter ( + fun seg -> + let base = (seg.elf64_segment_base) in + let size2 = (seg.elf64_segment_memsz) in Nat_big_num.less_equal + base entry && Nat_big_num.less_equal entry ( Nat_big_num.add base size2) + ) segs) + in + (match filtered with + | [] -> fail "abi_power64_compute_program_entry_point: no program segment contains the program entry point" + | [x] -> + let rebase = (Nat_big_num.sub_nat entry x.elf64_segment_base) in + Byte_sequence.offset_and_cut rebase(Nat_big_num.of_int 8) x.elf64_segment_body >>= (fun bytes -> + Byte_sequence.read_8_bytes_le bytes >>= (fun (bytes, _) -> + let (b1,b2,b3,b4,b5,b6,b7,b8) = bytes in + return (Ml_bindings.nat_big_num_of_uint64 (Uint64_wrapper.of_oct_native b1 b2 b3 b4 b5 b6 b7 b8)))) + | _ -> fail "abi_power64_compute_program_entry_point: multiple program segments contain the program entry point" + )) diff --git a/lib/ocaml_rts/linksem/abis/power64/abi_power64_dynamic.ml b/lib/ocaml_rts/linksem/abis/power64/abi_power64_dynamic.ml new file mode 100644 index 00000000..b26d841f --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/power64/abi_power64_dynamic.ml @@ -0,0 +1,40 @@ +(*Generated by Lem from abis/power64/abi_power64_dynamic.lem.*) +open Lem_basic_classes +open Lem_num +open Lem_string + +open Error +open Show +open String_table + +open Elf_dynamic +open Elf_types_native_uint + +let abi_power64_dt_ppcgot : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 939524096)(Nat_big_num.of_int 2)) (* 0x70000000 *) + +(*val string_of_abi_power64_dynamic_tag : natural -> string*) +let string_of_abi_power64_dynamic_tag m:string= + (if Nat_big_num.equal m abi_power64_dt_ppcgot then + "PPC64_GLINK" + else + "Invalid Power64 dynamic tag") + +(*val abi_power64_tag_correspondence_of_tag : natural -> error tag_correspondence*) +let abi_power64_tag_correspondence_of_tag m:(tag_correspondence)error= + (if Nat_big_num.equal m abi_power64_dt_ppcgot then + return C_Ptr + else + fail ("abi_power64_tag_correspondence_of_tag: invalid Power64 dynamic tag")) + +(*val abi_power64_elf64_value_of_elf64_dyn : elf64_dyn -> string_table -> error elf64_dyn_value*) +let abi_power64_elf64_value_of_elf64_dyn dyn stbl:(((Uint64.uint64),(Uint64.uint64))dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int64 dyn.elf64_dyn_tag)) in + if Nat_big_num.equal tag abi_power64_dt_ppcgot then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "abi_power64_elf64_value_of_elf64_dyn: PPC_GOT must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "abi_power64_elf64_value_of_elf64_dyn: PPC_GOT must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else + fail ("abi_power64_elf64_value_of_elf64_dyn: invalid Power64 dynamic tag")) diff --git a/lib/ocaml_rts/linksem/abis/power64/abi_power64_elf_header.ml b/lib/ocaml_rts/linksem/abis/power64/abi_power64_elf_header.ml new file mode 100644 index 00000000..83826f85 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/power64/abi_power64_elf_header.ml @@ -0,0 +1,48 @@ +(*Generated by Lem from abis/power64/abi_power64_elf_header.lem.*) +(** [abi_power64_elf_header], Power64 ABI specific definitions related to the + * ELF file header. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_maybe +open Missing_pervasives + +open Elf_header +open Elf_types_native_uint + +open Endianness + +(** [is_valid_abi_power64_machine_architecture m] checks whether the ELF header's + * machine architecture is valid according to the ABI-specific specification. + * Machine architecture must be Power64 (Section 4.1). + *) +(*val is_valid_abi_power64_machine_architecture : nat -> bool*) +let is_valid_abi_power64_machine_architecture m:bool= + (m = Nat_big_num.to_int elf_ma_ppc64) + +(** [is_valid_abi_power64_magic_number magic] checks whether the ELF header's + * magic number is valid according to the ABI-specific specification. + * File class must be 64-bit (Section 4.1) + * Data encoding must be little or big endian and must match the data encoding + * of the file. (Section 4.1) + *) +(*val is_valid_abi_power64_magic_number : list unsigned_char -> endianness -> bool*) +let is_valid_abi_power64_magic_number magic endian:bool= + ((match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_class) with + | None -> false + | Some cls -> + (match Lem_list.list_index magic (Nat_big_num.to_int elf_ii_data) with + | None -> false + | Some ed -> + (match endian with + | Little -> + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string cls)) elf_class_64) && + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ed)) elf_data_2lsb) + | Big -> + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string cls)) elf_class_64) && + ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ed)) elf_data_2msb) + ) + ) + )) diff --git a/lib/ocaml_rts/linksem/abis/power64/abi_power64_relocation.ml b/lib/ocaml_rts/linksem/abis/power64/abi_power64_relocation.ml new file mode 100644 index 00000000..af9b7cfe --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/power64/abi_power64_relocation.ml @@ -0,0 +1,833 @@ +(*Generated by Lem from abis/power64/abi_power64_relocation.lem.*) +(** [abi_power64_relocation] contains types and definitions specific to + * relocations in the Power64 ABI + *) + +open Lem_basic_classes +open Lem_map +open Lem_maybe +open Lem_num +open Lem_string + +open Error +open Missing_pervasives + +open Elf_types_native_uint +open Elf_file +open Elf_header +open Elf_relocation +open Elf_symbol_table + +open Abi_utilities + +(** Power64 relocation types *) + +let r_ppc64_none : Nat_big_num.num= (Nat_big_num.of_int 0) +let r_ppc64_addr32 : Nat_big_num.num= (Nat_big_num.of_int 1) +let r_ppc64_addr24 : Nat_big_num.num= (Nat_big_num.of_int 2) +let r_ppc64_addr16 : Nat_big_num.num= (Nat_big_num.of_int 3) +let r_ppc64_addr16_lo : Nat_big_num.num= (Nat_big_num.of_int 4) +let r_ppc64_addr16_hi : Nat_big_num.num= (Nat_big_num.of_int 5) +let r_ppc64_addr16_ha : Nat_big_num.num= (Nat_big_num.of_int 6) +let r_ppc64_addr14 : Nat_big_num.num= (Nat_big_num.of_int 7) +let r_ppc64_addr14_brtaken : Nat_big_num.num= (Nat_big_num.of_int 8) +let r_ppc64_addr14_brntaken : Nat_big_num.num= (Nat_big_num.of_int 9) +let r_ppc64_rel24 : Nat_big_num.num= (Nat_big_num.of_int 10) +let r_ppc64_rel14 : Nat_big_num.num= (Nat_big_num.of_int 11) +let r_ppc64_rel14_brtaken : Nat_big_num.num= (Nat_big_num.of_int 12) +let r_ppc64_rel14_brntaken : Nat_big_num.num= (Nat_big_num.of_int 13) +let r_ppc64_got16 : Nat_big_num.num= (Nat_big_num.of_int 14) +let r_ppc64_got16_lo : Nat_big_num.num= (Nat_big_num.of_int 15) +let r_ppc64_got16_hi : Nat_big_num.num= (Nat_big_num.of_int 16) +let r_ppc64_got16_ha : Nat_big_num.num= (Nat_big_num.of_int 17) +let r_ppc64_copy : Nat_big_num.num= (Nat_big_num.of_int 19) +let r_ppc64_glob_dat : Nat_big_num.num= (Nat_big_num.of_int 20) +let r_ppc64_jmp_slot : Nat_big_num.num= (Nat_big_num.of_int 21) +let r_ppc64_relative : Nat_big_num.num= (Nat_big_num.of_int 22) +let r_ppc64_uaddr32 : Nat_big_num.num= (Nat_big_num.of_int 24) +let r_ppc64_uaddr16 : Nat_big_num.num= (Nat_big_num.of_int 25) +let r_ppc64_rel32 : Nat_big_num.num= (Nat_big_num.of_int 26) +let r_ppc64_plt32 : Nat_big_num.num= (Nat_big_num.of_int 27) +let r_ppc64_pltrel32 : Nat_big_num.num= (Nat_big_num.of_int 28) +let r_ppc64_plt16_lo : Nat_big_num.num= (Nat_big_num.of_int 29) +let r_ppc64_plt16_hi : Nat_big_num.num= (Nat_big_num.of_int 30) +let r_ppc64_plt16_ha : Nat_big_num.num= (Nat_big_num.of_int 31) +let r_ppc64_sectoff : Nat_big_num.num= (Nat_big_num.of_int 33) +let r_ppc64_sectoff_lo : Nat_big_num.num= (Nat_big_num.of_int 34) +let r_ppc64_sectoff_hi : Nat_big_num.num= (Nat_big_num.of_int 35) +let r_ppc64_sectoff_ha : Nat_big_num.num= (Nat_big_num.of_int 36) +let r_ppc64_addr30 : Nat_big_num.num= (Nat_big_num.of_int 37) +let r_ppc64_addr64 : Nat_big_num.num= (Nat_big_num.of_int 38) +let r_ppc64_addr16_higher : Nat_big_num.num= (Nat_big_num.of_int 39) +let r_ppc64_addr16_highera : Nat_big_num.num= (Nat_big_num.of_int 40) +let r_ppc64_addr16_highest : Nat_big_num.num= (Nat_big_num.of_int 41) +let r_ppc64_addr16_highesta : Nat_big_num.num= (Nat_big_num.of_int 42) +let r_ppc64_uaddr64 : Nat_big_num.num= (Nat_big_num.of_int 43) +let r_ppc64_rel64 : Nat_big_num.num= (Nat_big_num.of_int 44) +let r_ppc64_plt64 : Nat_big_num.num= (Nat_big_num.of_int 45) +let r_ppc64_pltrel64 : Nat_big_num.num= (Nat_big_num.of_int 46) +let r_ppc64_toc16 : Nat_big_num.num= (Nat_big_num.of_int 47) +let r_ppc64_toc16_lo : Nat_big_num.num= (Nat_big_num.of_int 48) +let r_ppc64_toc16_hi : Nat_big_num.num= (Nat_big_num.of_int 49) +let r_ppc64_toc16_ha : Nat_big_num.num= (Nat_big_num.of_int 50) +let r_ppc64_toc : Nat_big_num.num= (Nat_big_num.of_int 51) +let r_ppc64_pltgot16 : Nat_big_num.num= (Nat_big_num.of_int 52) +let r_ppc64_pltgot16_lo : Nat_big_num.num= (Nat_big_num.of_int 53) +let r_ppc64_pltgot16_hi : Nat_big_num.num= (Nat_big_num.of_int 54) +let r_ppc64_pltgot16_ha : Nat_big_num.num= (Nat_big_num.of_int 55) +let r_ppc64_addr16_ds : Nat_big_num.num= (Nat_big_num.of_int 56) +let r_ppc64_addr16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 57) +let r_ppc64_got16_ds : Nat_big_num.num= (Nat_big_num.of_int 58) +let r_ppc64_got16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 59) +let r_ppc64_plt16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 60) +let r_ppc64_sectoff_ds : Nat_big_num.num= (Nat_big_num.of_int 61) +let r_ppc64_sectoff_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 62) +let r_ppc64_toc16_ds : Nat_big_num.num= (Nat_big_num.of_int 63) +let r_ppc64_toc16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 64) +let r_ppc64_pltgot16_ds : Nat_big_num.num= (Nat_big_num.of_int 65) +let r_ppc64_pltgot16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 66) +let r_ppc64_tls : Nat_big_num.num= (Nat_big_num.of_int 67) +let r_ppc64_dtpmod64 : Nat_big_num.num= (Nat_big_num.of_int 68) +let r_ppc64_tprel16 : Nat_big_num.num= (Nat_big_num.of_int 69) +let r_ppc64_tprel16_lo : Nat_big_num.num= (Nat_big_num.of_int 60) +let r_ppc64_tprel16_hi : Nat_big_num.num= (Nat_big_num.of_int 71) +let r_ppc64_tprel16_ha : Nat_big_num.num= (Nat_big_num.of_int 72) +let r_ppc64_tprel64 : Nat_big_num.num= (Nat_big_num.of_int 73) +let r_ppc64_dtprel16 : Nat_big_num.num= (Nat_big_num.of_int 74) +let r_ppc64_dtprel16_lo : Nat_big_num.num= (Nat_big_num.of_int 75) +let r_ppc64_dtprel16_hi : Nat_big_num.num= (Nat_big_num.of_int 76) +let r_ppc64_dtprel16_ha : Nat_big_num.num= (Nat_big_num.of_int 77) +let r_ppc64_dtprel64 : Nat_big_num.num= (Nat_big_num.of_int 78) +let r_ppc64_got_tlsgd16 : Nat_big_num.num= (Nat_big_num.of_int 79) +let r_ppc64_got_tlsgd16_lo : Nat_big_num.num= (Nat_big_num.of_int 80) +let r_ppc64_got_tlsgd16_hi : Nat_big_num.num= (Nat_big_num.of_int 81) +let r_ppc64_got_tlsgd16_ha : Nat_big_num.num= (Nat_big_num.of_int 82) +let r_ppc64_got_tlsld16 : Nat_big_num.num= (Nat_big_num.of_int 83) +let r_ppc64_got_tlsld16_lo : Nat_big_num.num= (Nat_big_num.of_int 84) +let r_ppc64_got_tlsld16_hi : Nat_big_num.num= (Nat_big_num.of_int 85) +let r_ppc64_got_tlsld16_ha : Nat_big_num.num= (Nat_big_num.of_int 86) +let r_ppc64_got_tprel16_ds : Nat_big_num.num= (Nat_big_num.of_int 87) +let r_ppc64_got_tprel16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 88) +let r_ppc64_got_tprel16_hi : Nat_big_num.num= (Nat_big_num.of_int 89) +let r_ppc64_got_tprel16_ha : Nat_big_num.num= (Nat_big_num.of_int 90) +let r_ppc64_got_dtprel16_ds : Nat_big_num.num= (Nat_big_num.of_int 91) +let r_ppc64_got_dtprel16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 92) +let r_ppc64_got_dtprel16_hi : Nat_big_num.num= (Nat_big_num.of_int 93) +let r_ppc64_got_dtprel16_ha : Nat_big_num.num= (Nat_big_num.of_int 94) +let r_ppc64_tprel16_ds : Nat_big_num.num= (Nat_big_num.of_int 95) +let r_ppc64_tprel16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 96) +let r_ppc64_tprel16_higher : Nat_big_num.num= (Nat_big_num.of_int 97) +let r_ppc64_tprel16_highera : Nat_big_num.num= (Nat_big_num.of_int 98) +let r_ppc64_tprel16_highest : Nat_big_num.num= (Nat_big_num.of_int 99) +let r_ppc64_tprel16_highesta : Nat_big_num.num= (Nat_big_num.of_int 100) +let r_ppc64_dtprel16_ds : Nat_big_num.num= (Nat_big_num.of_int 101) +let r_ppc64_dtprel16_lo_ds : Nat_big_num.num= (Nat_big_num.of_int 102) +let r_ppc64_dtprel16_higher : Nat_big_num.num= (Nat_big_num.of_int 103) +let r_ppc64_dtprel16_highera : Nat_big_num.num= (Nat_big_num.of_int 104) +let r_ppc64_dtprel16_highest : Nat_big_num.num= (Nat_big_num.of_int 105) +let r_ppc64_dtprel16_highesta : Nat_big_num.num= (Nat_big_num.of_int 106) + +(** [string_of_ppc64_relocation_type rel_type] produces a string representation + * of relocation type [rel_type]. + *) +(*val string_of_ppc64_relocation_type : natural -> string*) +let string_of_ppc64_relocation_type rel_type1:string= + (if Nat_big_num.equal rel_type1 r_ppc64_none then + "R_PPC64_NONE" + else if Nat_big_num.equal rel_type1 r_ppc64_addr32 then + "R_PPC64_ADDR32" + else if Nat_big_num.equal rel_type1 r_ppc64_addr24 then + "R_PPC64_ADDR24" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16 then + "R_PPC64_ADDR16" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_lo then + "R_PPC64_ADDR16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_hi then + "R_PPC64_ADDR16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_ha then + "R_PPC64_ADDR16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_addr14 then + "R_PPC64_ADDR14" + else if Nat_big_num.equal rel_type1 r_ppc64_addr14_brtaken then + "R_PPC64_ADDR14_BRTAKEN" + else if Nat_big_num.equal rel_type1 r_ppc64_addr14_brntaken then + "R_PPC64_ADDR14_BRNTAKEN" + else if Nat_big_num.equal rel_type1 r_ppc64_rel24 then + "R_PPC64_REL24" + else if Nat_big_num.equal rel_type1 r_ppc64_rel14 then + "R_PPC64_REL14" + else if Nat_big_num.equal rel_type1 r_ppc64_rel14_brtaken then + "R_PPC64_REL14_BRTAKEN" + else if Nat_big_num.equal rel_type1 r_ppc64_rel14_brntaken then + "R_PPC64_REL14_BRNTAKEN" + else if Nat_big_num.equal rel_type1 r_ppc64_got16 then + "R_PPC64_GOT16" + else if Nat_big_num.equal rel_type1 r_ppc64_got16_lo then + "R_PPC64_GOT16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_got16_hi then + "R_PPC64_GOT16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_got16_ha then + "R_PPC64_GOT16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_copy then + "R_PPC64_COPY" + else if Nat_big_num.equal rel_type1 r_ppc64_glob_dat then + "R_PPC64_GLOB_DAT" + else if Nat_big_num.equal rel_type1 r_ppc64_jmp_slot then + "R_PPC64_JMP_SLOT" + else if Nat_big_num.equal rel_type1 r_ppc64_relative then + "R_PPC64_RELATIVE" + else if Nat_big_num.equal rel_type1 r_ppc64_uaddr32 then + "R_PPC64_UADDR32" + else if Nat_big_num.equal rel_type1 r_ppc64_uaddr16 then + "R_PPC64_UADDR16" + else if Nat_big_num.equal rel_type1 r_ppc64_rel32 then + "R_PPC64_REL32" + else if Nat_big_num.equal rel_type1 r_ppc64_plt32 then + "R_PPC64_PLT32" + else if Nat_big_num.equal rel_type1 r_ppc64_pltrel32 then + "R_PPC64_PLTREL32" + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_lo then + "R_PPC64_PLT16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_hi then + "R_PPC64_PLT16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_ha then + "R_PPC64_PLT16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff then + "R_PPC64_SECTOFF" + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_lo then + "R_PPC64_SECTOFF_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_hi then + "R_PPC64_SECTOFF_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_ha then + "R_PPC64_SECTOFF_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_addr30 then + "R_PPC64_ADDR30" + else if Nat_big_num.equal rel_type1 r_ppc64_addr64 then + "R_PPC64_ADDR64" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_higher then + "R_PPC64_ADDR16_HIGHER" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_highera then + "R_PPC64_ADDR16_HIGHERA" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_highest then + "R_PPC64_ADDR16_HIGHEST" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_highesta then + "R_PPC64_ADDR16_HIGHESTA" + else if Nat_big_num.equal rel_type1 r_ppc64_uaddr64 then + "R_PPC64_UADDR64" + else if Nat_big_num.equal rel_type1 r_ppc64_rel64 then + "R_PPC64_REL64" + else if Nat_big_num.equal rel_type1 r_ppc64_plt64 then + "R_PPC64_PLT64" + else if Nat_big_num.equal rel_type1 r_ppc64_pltrel64 then + "R_PPC64_PLTREL64" + else if Nat_big_num.equal rel_type1 r_ppc64_toc16 then + "R_PPC64_TOC16" + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_lo then + "R_PPC64_TOC16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_hi then + "R_PPC64_TOC16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_ha then + "R_PPC64_TOC16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_toc then + "R_PPC64_TOC" + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16 then + "R_PPC64_PLTGOT16" + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_lo then + "R_PPC64_PLTGOT16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_hi then + "R_PPC64_PLTGOT16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_ha then + "R_PPC64_PLTGOT16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_ds then + "R_PPC64_ADDR16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_lo_ds then + "R_PPC64_ADDR16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_got16_ds then + "R_PPC64_GOT16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_got16_lo_ds then + "R_PPC64_GOT16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_lo_ds then + "R_PPC64_PLT16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_ds then + "R_PPC64_SECTOFF_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_lo_ds then + "R_PPC64_SECTOFF_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_ds then + "R_PPC64_TOC16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_lo_ds then + "R_PPC64_TOC16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_ds then + "R_PPC64_PLTGOT16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_lo_ds then + "R_PPC64_PLTGOT16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_tls then + "R_PPC64_TLS" + else if Nat_big_num.equal rel_type1 r_ppc64_dtpmod64 then + "R_PPC64_DTPMOD64" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16 then + "R_PPC64_TPREL16" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_lo then + "R_PPC64_TPREL16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_hi then + "R_PPC64_TPREL16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_ha then + "R_PPC64_TPREL16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel64 then + "R_PPC64_TPREL64" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16 then + "R_PPC64_DTPREL16" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_lo then + "R_PPC64_DTPREL16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_hi then + "R_PPC64_DTPREL16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_ha then + "R_PPC64_DTPREL16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel64 then + "R_PPC64_DTPREL64" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16 then + "R_PPC64_GOT_TLSGD16" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16_lo then + "R_PPC64_GOT_TLSGD16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16_hi then + "R_PPC64_GOT_TLSGD16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16_ha then + "R_PPC64_GOT_TLSGD16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16 then + "R_PPC64_GOT_TLSLD16" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16_lo then + "R_PPC64_GOT_TLSLD16_LO" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16_hi then + "R_PPC64_GOT_TLSLD16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16_ha then + "R_PPC64_GOT_TLSLD16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_ds then + "R_PPC64_GOT_TPREL16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_lo_ds then + "R_PPC64_GOT_TPREL16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_hi then + "R_PPC64_GOT_TPREL16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_ha then + "R_PPC64_GOT_TPREL16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_ds then + "R_PPC64_GOT_DTPREL16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_lo_ds then + "R_PPC64_GOT_DTPREL16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_hi then + "R_PPC64_GOT_DTPREL16_HI" + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_ha then + "R_PPC64_GOT_DTPREL16_HA" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_ds then + "R_PPC64_TPREL16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_lo_ds then + "R_PPC64_TPREL16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_higher then + "R_PPC64_TPREL16_HIGHER" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_highera then + "R_PPC64_TPREL16_HIGHERA" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_highest then + "R_PPC64_TPREL16_HIGHEST" + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_highesta then + "R_PPC64_TPREL16_HIGHESTA" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_ds then + "R_PPC64_DTPREL16_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_lo_ds then + "R_PPC64_DTPREL16_LO_DS" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_higher then + "R_PPC64_DTPREL16_HIGHER" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_highera then + "R_PPC64_DTPREL16_HIGHERA" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_highest then + "R_PPC64_DTPREL16_HIGHEST" + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_highesta then + "R_PPC64_DTPREL16_HIGHESTA" + else + "Invalid Power64 relocation type") + +(*val abi_ppc64_apply_relocation : elf64_relocation_a -> integer -> integer -> + integer -> integer -> integer -> integer -> integer -> integer -> integer -> + integer -> integer -> integer -> integer -> integer -> integer -> elf64_file -> + error (Map.map elf64_addr (relocation_operator_expression integer * integer_bit_width * can_fail integer))*) +let abi_ppc64_apply_relocation rel s_val b_val p_val l_val g_val r_val m_val + toc_val dtpmod_val tprel_val dtprel_val gottlsgd_val gottlsld_val + gottprel_val gotdtprel_val ef:(((Uint64.uint64),((Nat_big_num.num)relocation_operator_expression*integer_bit_width*(Nat_big_num.num)can_fail))Pmap.map)error= + (if is_elf64_relocatable_file ef.elf64_file_header then + let rel_type1 = (extract_elf64_relocation_r_type rel.elf64_ra_info) in + let a_val = (Nat_big_num.of_int64 rel.elf64_ra_addend) in + (** No width, no calculation *) + if Nat_big_num.equal rel_type1 r_ppc64_none then + return (Pmap.empty compare) + (** Width: 32 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr32 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Width: Low24 Calculation: (S + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr24 then + let result = (RShift (Lift( Nat_big_num.add s_val a_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low24, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16 then + let result = (Lift ( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #lo(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_lo then + let result = (Apply(Lo, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #hi(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_hi then + let result = (Apply(Hi, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #ha(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_ha then + let result = (Apply(Ha, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Low14 Calculation: (S + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr14 then + let result = (RShift(Lift( Nat_big_num.add s_val a_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low14, CanFail) (Pmap.empty compare)) + (** Width: Low14 Calculation: (S + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr14_brtaken then + let result = (RShift(Lift( Nat_big_num.add s_val a_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low14, CanFail) (Pmap.empty compare)) + (** Width: Low14 Calculation: (S + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr14_brntaken then + let result = (RShift(Lift( Nat_big_num.add s_val a_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low14, CanFail) (Pmap.empty compare)) + (** Width: Low24 Calculation: ((S + A) - P) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_rel24 then + let result = (RShift(Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low24, CanFail) (Pmap.empty compare)) + (** Width: Low14 Calculation: ((S + A) - P) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_rel14 then + let result = (RShift(Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low14, CanFail) (Pmap.empty compare)) + (** Width: Low14 Calculation: ((S + A) - P) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_rel14_brtaken then + let result = (RShift(Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low14, CanFail) (Pmap.empty compare)) + (** Width: Low14 Calculation: ((S + A) - P) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_rel14_brntaken then + let result = (RShift(Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Low14, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: G *) + else if Nat_big_num.equal rel_type1 r_ppc64_got16 then + let result = (Lift g_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #lo(G) *) + else if Nat_big_num.equal rel_type1 r_ppc64_got16_lo then + let result = (Apply(Lo, Lift g_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #hi(G) *) + else if Nat_big_num.equal rel_type1 r_ppc64_got16_hi then + let result = (Apply(Hi, Lift g_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #ha(G) *) + else if Nat_big_num.equal rel_type1 r_ppc64_got16_ha then + let result = (Apply(Ha, Lift g_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** No width, no calculation *) + else if Nat_big_num.equal rel_type1 r_ppc64_copy then + fail "abi_ppc64_apply_relocation: r_ppc64_copy not implemented" + (** Width I64, Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_glob_dat then + let result = (Lift( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** No width, dynamic link calculation *) + else if Nat_big_num.equal rel_type1 r_ppc64_jmp_slot then + fail "abi_ppc64_apply_relocation: r_ppc64_jmp_slot not implemented" + (** Width I64, Calculation: B + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_relative then + let result = (Lift( Nat_big_num.add b_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: I32 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_uaddr32 then + let result = (Lift( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_uaddr16 then + let result = (Lift( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: I32 Calculation: (S + A) - P *) + else if Nat_big_num.equal rel_type1 r_ppc64_rel32 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Width: I32 Calculation: L *) + else if Nat_big_num.equal rel_type1 r_ppc64_plt32 then + let result = (Lift l_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Width: I32 Calculation: L - P *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltrel32 then + let result = (Lift ( Nat_big_num.sub l_val p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I32, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #lo(L) *) + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_lo then + let result = (Apply(Lo, Lift l_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #hi(L) *) + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_hi then + let result = (Apply(Hi, Lift l_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #ha(L) *) + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_ha then + let result = (Apply(Ha, Lift l_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: R + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff then + let result = (Lift( Nat_big_num.add r_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #lo(R + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_lo then + let result = (Apply(Lo, Lift ( Nat_big_num.add r_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #hi(R + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_hi then + let result = (Apply(Hi, Lift ( Nat_big_num.add r_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #ha(R + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_ha then + let result = (Apply(Ha, Lift ( Nat_big_num.add r_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Word30 Calculation: ((S + A) - P) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr30 then + let result = (RShift(Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Word30, CannotFail) (Pmap.empty compare)) + (** Width: I64 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr64 then + let result = (Lift( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #higher(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_higher then + let result = (Apply(Higher, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #highera(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_highera then + let result = (Apply(HigherA, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #highest(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_highest then + let result = (Apply(Highest, Lift ( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #highesta(S + A) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_highesta then + let result = (Apply(HighestA, Lift( Nat_big_num.add s_val a_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: I64 Calculation: S + A *) + else if Nat_big_num.equal rel_type1 r_ppc64_uaddr64 then + let result = (Lift( Nat_big_num.add s_val a_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: I64 Calculation: (S + A) - P *) + else if Nat_big_num.equal rel_type1 r_ppc64_rel64 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: I64 Calculation: L *) + else if Nat_big_num.equal rel_type1 r_ppc64_plt64 then + let result = (Lift l_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: I64 Calculation: L - P *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltrel64 then + let result = (Lift( Nat_big_num.sub l_val p_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: (S + A) - TOC *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc16 then + let result = (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) toc_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #lo((S + A) - TOC) *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_lo then + let result = (Apply (Lo, Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) toc_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #hi((S + A) - TOC) *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_hi then + let result = (Apply(Hi, Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) toc_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #ha((S + A) - TOC) *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_ha then + let result = (Apply(Ha, Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) toc_val))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: I64 Calculation: .TOC *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc then + let result = (Lift toc_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: M *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16 then + let result = (Lift m_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #lo(M) *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_lo then + let result = (Apply(Lo, Lift m_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #hi(M) *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_hi then + let result = (Apply(Hi, Lift m_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16 Calculation: #ha(M) *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_ha then + let result = (Apply(Ha, Lift m_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: (S + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_ds then + let result = (RShift(Lift ( Nat_big_num.add s_val a_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: #lo((S + A) >> 2) *) + else if Nat_big_num.equal rel_type1 r_ppc64_addr16_lo_ds then + let result = (Apply(Lo, RShift(Lift ( Nat_big_num.add s_val a_val),Nat_big_num.of_int 2))) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: G >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_got16_ds then + let result = (RShift(Lift g_val,Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: #lo(G) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_got16_lo_ds then + let result = (RShift(Apply(Lo, Lift g_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: #lo(L) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_plt16_lo_ds then + let result = (RShift (Apply(Lo, Lift l_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: (R + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_ds then + let result = (RShift (Lift ( Nat_big_num.add r_val a_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: #lo(R + A) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_sectoff_lo_ds then + let result = (RShift(Apply(Lo, Lift ( Nat_big_num.add r_val a_val)),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: ((S + A) - TOC) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_ds then + let result = (RShift (Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) toc_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: #lo((S + A) - TOC) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_toc16_lo_ds then + let result = (RShift (Apply(Lo, Lift ( Nat_big_num.sub( Nat_big_num.add s_val a_val) toc_val)),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: M >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_ds then + let result = (RShift(Lift m_val,Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + (** Width: Half16ds Calculation: #lo(M) >> 2 *) + else if Nat_big_num.equal rel_type1 r_ppc64_pltgot16_lo_ds then + let result = (RShift (Apply(Lo, Lift m_val),Nat_big_num.of_int 2)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + (** No width, no calculation *) + else if Nat_big_num.equal rel_type1 r_ppc64_tls then + fail "abi_ppc64_apply_relocation: r_ppc64_tls not implemented" + (** Width I64 Calculation: @dtpmod *) + else if Nat_big_num.equal rel_type1 r_ppc64_dtpmod64 then + let result = (Lift dtpmod_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16 then + let result = (Lift tprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_lo then + let result = (Apply(Lo, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_hi then + let result = (Apply(Hi, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_ha then + let result = (Apply(Ha, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel64 then + let result = (Lift tprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16 then + let result = (Lift dtprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_lo then + let result = (Apply(Lo, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_hi then + let result = (Apply(Hi, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_ha then + let result = (Apply(Ha, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel64 then + let result = (Lift dtprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I64, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16 then + let result = (Lift gottlsgd_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16_lo then + let result = (Apply(Lo, Lift gottlsgd_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16_hi then + let result = (Apply(Hi, Lift gottlsgd_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsgd16_ha then + let result = (Apply(Ha, Lift gottlsgd_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16 then + let result = (Lift gottlsgd_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16_lo then + let result = (Apply(Lo, Lift gottlsgd_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16_hi then + let result = (Apply(Hi, Lift gottlsgd_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tlsld16_ha then + let result = (Apply(Ha, Lift gottlsgd_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_ds then + let result = (Lift gottprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_lo_ds then + let result = (Apply(Lo, Lift gottprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_hi then + let result = (Apply(Hi, Lift gottprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_tprel16_ha then + let result = (Apply(Ha, Lift gottprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_ds then + let result = (Lift gotdtprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_lo_ds then + let result = (Apply(Lo, Lift gotdtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_hi then + let result = (Apply(Hi, Lift gotdtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_got_dtprel16_ha then + let result = (Apply(Ha, Lift gotdtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_ds then + let result = (Lift tprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_lo_ds then + let result = (Apply(Lo, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_higher then + let result = (Apply(Higher, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_highera then + let result = (Apply(HigherA, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_highest then + let result = (Apply(Highest, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_tprel16_highesta then + let result = (Apply(HighestA, Lift tprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_ds then + let result = (Lift dtprel_val) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CanFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_lo_ds then + let result = (Apply(Lo, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, Half16ds, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_higher then + let result = (Apply(Higher, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_highera then + let result = (Apply(HigherA, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_highest then + let result = (Apply(Highest, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else if Nat_big_num.equal rel_type1 r_ppc64_dtprel16_highesta then + let result = (Apply(HighestA, Lift dtprel_val)) in + let addr = (rel.elf64_ra_offset) in + return (Pmap.add addr (result, I16, CannotFail) (Pmap.empty compare)) + else + fail "abi_ppc64_apply_relocation: unrecognised relocation type" + else + fail "abi_ppc64_apply_relocation: not a relocatable file") diff --git a/lib/ocaml_rts/linksem/abis/power64/abi_power64_section_header_table.ml b/lib/ocaml_rts/linksem/abis/power64/abi_power64_section_header_table.ml new file mode 100644 index 00000000..a68f81cf --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/power64/abi_power64_section_header_table.ml @@ -0,0 +1,24 @@ +(*Generated by Lem from abis/power64/abi_power64_section_header_table.lem.*) +(** [abi_power64_section_header_table] contains Power64 ABI specific definitions + * related to the section header table. + *) + +open Lem_map +open Lem_num + +open Elf_section_header_table + +(** Special sections. *) + +(** See Section 4.2 *) + +(*val abi_power64_special_sections : Map.map string (natural * natural)*) +let abi_power64_special_sections:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict + Lem_basic_classes.instance_Basic_classes_SetType_var_dict) [ + (".glink", (sht_progbits, Nat_big_num.add shf_alloc shf_execinstr)) + ; (".got", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".toc", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".tocbss", (sht_nobits, Nat_big_num.add shf_alloc shf_write)) + ; (".plt", (sht_nobits, Nat_big_num.add shf_alloc shf_write)) + ]) diff --git a/lib/ocaml_rts/linksem/abis/x86/abi_x86_relocation.ml b/lib/ocaml_rts/linksem/abis/x86/abi_x86_relocation.ml new file mode 100644 index 00000000..ee57be63 --- /dev/null +++ b/lib/ocaml_rts/linksem/abis/x86/abi_x86_relocation.ml @@ -0,0 +1,69 @@ +(*Generated by Lem from abis/x86/abi_x86_relocation.lem.*) +(** [abi_x86_relocation] contains X86 ABI specific definitions relating to + * relocations. + *) + +open Lem_basic_classes +open Lem_num +open Lem_string + +open Show + +(** Relocation types. *) + +let r_386_none : Nat_big_num.num= (Nat_big_num.of_int 0) +let r_386_32 : Nat_big_num.num= (Nat_big_num.of_int 1) +let r_386_pc32 : Nat_big_num.num= (Nat_big_num.of_int 2) +let r_386_got32 : Nat_big_num.num= (Nat_big_num.of_int 3) +let r_386_plt32 : Nat_big_num.num= (Nat_big_num.of_int 4) +let r_386_copy : Nat_big_num.num= (Nat_big_num.of_int 5) +let r_386_glob_dat : Nat_big_num.num= (Nat_big_num.of_int 6) +let r_386_jmp_slot : Nat_big_num.num= (Nat_big_num.of_int 7) +let r_386_relative : Nat_big_num.num= (Nat_big_num.of_int 8) +let r_386_gotoff : Nat_big_num.num= (Nat_big_num.of_int 9) +let r_386_gotpc : Nat_big_num.num= (Nat_big_num.of_int 10) + +(** Found in the "wild" but not in the ABI docs: *) + +let r_386_tls_tpoff : Nat_big_num.num= (Nat_big_num.of_int 14) +let r_386_tls_dtpmod32 : Nat_big_num.num= (Nat_big_num.of_int 35) +let r_386_tls_dtpoff32 : Nat_big_num.num= (Nat_big_num.of_int 36) +let r_386_irelative : Nat_big_num.num= (Nat_big_num.of_int 42) + +(** [string_of_x86_relocation_type m] produces a string based representation of + * X86 ABI relocation type [m]. + *) +(*val string_of_x86_relocation_type : natural -> string*) +let string_of_x86_relocation_type m:string= + (if Nat_big_num.equal m r_386_none then + "R_386_NONE" + else if Nat_big_num.equal m r_386_32 then + "R_386_32" + else if Nat_big_num.equal m r_386_pc32 then + "R_386_PC32" + else if Nat_big_num.equal m r_386_got32 then + "R_386_GOT32" + else if Nat_big_num.equal m r_386_plt32 then + "R_386_PLT32" + else if Nat_big_num.equal m r_386_copy then + "R_386_COPY" + else if Nat_big_num.equal m r_386_glob_dat then + "R_386_GLOB_DAT" + else if Nat_big_num.equal m r_386_jmp_slot then + "R_386_JUMP_SLOT" + else if Nat_big_num.equal m r_386_relative then + "R_386_RELATIVE" + else if Nat_big_num.equal m r_386_gotoff then + "R_386_GOTOFF" + else if Nat_big_num.equal m r_386_gotpc then + "R_386_GOTPC" + else if Nat_big_num.equal m r_386_tls_tpoff then + "R_386_TLS_TPOFF" + else if Nat_big_num.equal m r_386_tls_dtpmod32 then + "R_386_TLS_DTPMOD32" + else if Nat_big_num.equal m r_386_tls_dtpoff32 then + "R_386_TLS_DTPOFF32" + else if Nat_big_num.equal m r_386_irelative then + "R_386_IRELATIVE" + else + "Invalid x86 relocation") diff --git a/lib/ocaml_rts/linksem/abstract_linker_script.ml b/lib/ocaml_rts/linksem/abstract_linker_script.ml new file mode 100644 index 00000000..547b3b2d --- /dev/null +++ b/lib/ocaml_rts/linksem/abstract_linker_script.ml @@ -0,0 +1,59 @@ +(*Generated by Lem from abstract_linker_script.lem.*) +open Lem_basic_classes +open Lem_list +open Lem_num + +type binary_relation + = Eq0 + | Lt0 + +type binary_connective + = And0 (** Conjunction *) + | Or0 (** Disjunction *) + +(** The type [expression] denotes addresses, whether known or to be ascertained. + *) +type expression + = Var0 of string (** Ranges over memory addresses *) + | Const of Nat_big_num.num (** Fixed memory address *) + +(* These are *one-place* predicates on unsigned integer solutions (usually representing + * addresses). Implicitly, every binary relation is being applied to the solution. HMM: is + * this sane? Taking my lead from KLEE / SMT solver formulae. What we're describing is a + * big SMT instance; it's sane if we can always factor the instances we want into this + * form, i.e. into a big conjunction of per-variable formulae where each two-place relation + * has the variable in one of its places. + * + * Could try to claim it follows from taking CNF and assigning + * each conjunct to one of the variables it contains. But what if that conjunct is a big + * disjunction including some other binary operators applied to two other variables? + * Might need to factor those out into a "global" extra conjunct. YES. *) +type value_formula + = VFTrue + | VFFalse + | VFBinaryRelation of (binary_relation * expression) + | VFBinaryConnective of (binary_connective * value_formula * value_formula) + | VFNot of value_formula + +type memory_image_formula + = MIFTrue + | MIFFalse + | MIFExists of (string * memory_image_formula) + | MIFBinaryRelation of (binary_relation * expression * expression) + | MIFBinaryConnective of (binary_connective * memory_image_formula * memory_image_formula) + | MIFAssertValueFormula of (expression * value_formula) + | MIFNot of memory_image_formula + +type memory_image0 + = MemoryImage of memory_image_formula + +(*val mk_range : natural -> natural -> value_formula*) +let rec mk_range left right:value_formula= + (if Nat_big_num.equal left right then + VFTrue + else if Nat_big_num.less right left then + VFFalse + else + let l = (Const left) in + let r = (Const right) in + VFBinaryConnective(And0, VFBinaryRelation(Lt0, r), VFNot(VFBinaryRelation(Lt0, l)))) diff --git a/lib/ocaml_rts/linksem/adaptors/harness_interface.ml b/lib/ocaml_rts/linksem/adaptors/harness_interface.ml new file mode 100644 index 00000000..8ce4f6bd --- /dev/null +++ b/lib/ocaml_rts/linksem/adaptors/harness_interface.ml @@ -0,0 +1,1154 @@ +(*Generated by Lem from adaptors/harness_interface.lem.*) +open Lem_basic_classes +open Lem_bool +open Lem_function +open Lem_maybe +open Lem_num +open Lem_string + +open Byte_sequence +open Error +open Hex_printing +open Missing_pervasives +open Show + +open Default_printing + +open Endianness +open String_table + +open Elf_dynamic +open Elf_file +open Elf_header +open Elf_program_header_table +open Elf_relocation +open Elf_section_header_table +open Elf_symbol_table +open Elf_types_native_uint + +open Gnu_ext_dynamic +open Gnu_ext_section_header_table +open Gnu_ext_section_to_segment_mapping +open Gnu_ext_symbol_versioning + +(*val concatS' : list string -> string -> string*) +let rec concatS' ss accum:string= + ((match ss with + | [] -> accum + | s::ss -> concatS' ss (accum^s) + )) + +(*val concatS : list string -> string*) +let concatS ss:string= (concatS' ss "") + +(*val harness_string_of_elf32_file_header : elf32_header -> string*) +let harness_string_of_elf32_file_header hdr:string= + (unlines [ + "ELF Header:" + ; (" Magic:" ^ (" " ^ unsafe_hex_string_of_uc_list (hdr.elf32_ident))) + ; (" Class:" ^ (" " ^ string_of_elf_file_class (get_elf32_file_class hdr))) + ; (" Data:" ^ (" " ^ string_of_elf_data_encoding (get_elf32_data_encoding hdr))) + ; (" Version:" ^ (" " ^ string_of_elf_version_number (get_elf32_version_number hdr))) + ; (" OS/ABI:" ^ (" " ^ string_of_elf_osabi_version ((fun y->"Architecture defined")) (get_elf32_osabi hdr))) + ; (" ABI Version:" ^ (" " ^ Nat_big_num.to_string (get_elf32_abi_version hdr))) + ; (" Type:" ^ (" " ^ string_of_elf_file_type default_os_specific_print default_proc_specific_print (Nat_big_num.of_string (Uint32.to_string hdr.elf32_type)))) + ; (" Machine:" ^ (" " ^ string_of_elf_machine_architecture (Nat_big_num.of_string (Uint32.to_string hdr.elf32_machine)))) + ; (" Version:" ^ (" " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_version))))) + ; (" Entry point address:" ^ (" " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_entry))))) + ; (" Start of program headers:" ^ (" " ^ (Uint32.to_string hdr.elf32_phoff ^ " (bytes into file)"))) + ; (" Start of section headers:" ^ (" " ^ (Uint32.to_string hdr.elf32_shoff ^ " (bytes into file)"))) + ; (" Flags:" ^ (" " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_flags))))) + ; (" Size of this header:" ^ (" " ^ (Uint32.to_string hdr.elf32_ehsize ^ " (bytes)"))) + ; (" Size of program headers:" ^ (" " ^ (Uint32.to_string hdr.elf32_phentsize ^ " (bytes)"))) + ; (" Number of program headers:" ^ (" " ^ Uint32.to_string hdr.elf32_phnum)) + ; (" Size of section headers:" ^ (" " ^ (Uint32.to_string hdr.elf32_shentsize ^ " (bytes)"))) + ; (" Number of section headers:" ^ (" " ^ Uint32.to_string hdr.elf32_shnum)) + ; (" Section header string table index:" ^ (" " ^ Uint32.to_string hdr.elf32_shstrndx)) + ]) + +(*val harness_string_of_elf64_file_header : elf64_header -> string*) +let harness_string_of_elf64_file_header hdr:string= + (unlines [ + "ELF Header:" + ; (" Magic:" ^ (" " ^ unsafe_hex_string_of_uc_list (hdr.elf64_ident))) + ; (" Class:" ^ (" " ^ string_of_elf_file_class (get_elf64_file_class hdr))) + ; (" Data:" ^ (" " ^ string_of_elf_data_encoding (get_elf64_data_encoding hdr))) + ; (" Version:" ^ (" " ^ string_of_elf_version_number (get_elf64_version_number hdr))) + ; (" OS/ABI:" ^ (" " ^ string_of_elf_osabi_version ((fun y->"Architecture defined")) (get_elf64_osabi hdr))) + ; (" ABI Version:" ^ (" " ^ Nat_big_num.to_string (get_elf64_abi_version hdr))) + ; (" Type:" ^ (" " ^ string_of_elf_file_type default_os_specific_print default_proc_specific_print (Nat_big_num.of_string (Uint32.to_string hdr.elf64_type)))) + ; (" Machine:" ^ (" " ^ string_of_elf_machine_architecture (Nat_big_num.of_string (Uint32.to_string hdr.elf64_machine)))) + ; (" Version:" ^ (" " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string hdr.elf64_version))))) + ; (" Entry point address:" ^ (" " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Ml_bindings.nat_big_num_of_uint64 hdr.elf64_entry)))) + ; (" Start of program headers:" ^ (" " ^ (Uint64.to_string hdr.elf64_phoff ^ " (bytes into file)"))) + ; (" Start of section headers:" ^ (" " ^ (Uint64.to_string hdr.elf64_shoff ^ " (bytes into file)"))) + ; (" Flags:" ^ (" " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string hdr.elf64_flags))))) + ; (" Size of this header:" ^ (" " ^ (Uint32.to_string hdr.elf64_ehsize ^ " (bytes)"))) + ; (" Size of program headers:" ^ (" " ^ (Uint32.to_string hdr.elf64_phentsize ^ " (bytes)"))) + ; (" Number of program headers:" ^ (" " ^ Uint32.to_string hdr.elf64_phnum)) + ; (" Size of section headers:" ^ (" " ^ (Uint32.to_string hdr.elf64_shentsize ^ " (bytes)"))) + ; (" Number of section headers:" ^ (" " ^ Uint32.to_string hdr.elf64_shnum)) + ; (" Section header string table index:" ^ (" " ^ Uint32.to_string hdr.elf64_shstrndx)) + ]) + +(*val harness_string_of_elf32_program_header_table_entry : (natural -> string) -> (natural -> string) -> byte_sequence -> elf32_program_header_table_entry -> string*) +let harness_string_of_elf32_program_header_table_entry os proc bs0 pent:string= + (let typ = (string_of_segment_type os proc (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_type))) in + let typ_s = +(let len = (Nat_num.nat_monus( 15) (String.length typ)) in + if len <= 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int len) " ")) + in + concatS [ + " " + ; typ ; typ_s + ; ("0x" ^ unsafe_hex_string_of_natural( 6) (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_offset))) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 8) (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_vaddr))) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 8) (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_paddr))) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 5) (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_filesz))) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 5) (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_memsz))) + ; " " + ; string_of_elf_segment_permissions (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_flags)) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_align))) + ] ^ +(if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_type)) elf_pt_interp then + (match Elf_program_header_table.get_elf32_requested_interpreter pent bs0 with + | Fail f -> "\n [Requesting program interpreter: " ^ (f ^ "]") + | Success s -> "\n [Requesting program interpreter: " ^ (s ^ "]") + ) + else + "")) + +(*val harness_string_of_elf64_program_header_table_entry : (natural -> string) -> (natural -> string) -> byte_sequence -> elf64_program_header_table_entry -> string*) +let harness_string_of_elf64_program_header_table_entry os proc bs0 pent:string= + (let typ = (string_of_segment_type os proc (Nat_big_num.of_string (Uint32.to_string pent.elf64_p_type))) in + let typ_s = +(let len = (Nat_num.nat_monus( 15) (String.length typ)) in + if len <= 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int len) " ")) + in + concatS [ + " " + ; typ ; typ_s + ; ("0x" ^ unsafe_hex_string_of_natural( 6) (Nat_big_num.of_string (Uint64.to_string pent.elf64_p_offset))) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 16) (Ml_bindings.nat_big_num_of_uint64 pent.elf64_p_vaddr)) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 16) (Ml_bindings.nat_big_num_of_uint64 pent.elf64_p_paddr)) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 6) (Ml_bindings.nat_big_num_of_uint64 pent.elf64_p_filesz)) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 6) (Ml_bindings.nat_big_num_of_uint64 pent.elf64_p_memsz)) + ; " " + ; string_of_elf_segment_permissions (Nat_big_num.of_string (Uint32.to_string pent.elf64_p_flags)) + ; " " + ; ("0x" ^ unsafe_hex_string_of_natural( 1) (Ml_bindings.nat_big_num_of_uint64 pent.elf64_p_align)) + ] ^ +(if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string pent.elf64_p_type)) elf_pt_interp then + (match Elf_program_header_table.get_elf64_requested_interpreter pent bs0 with + | Fail f -> "\n [Requesting program interpreter: " ^ (f ^ "]") + | Success s -> "\n [Requesting program interpreter: " ^ (s ^ "]") + ) + else + "")) + +(*val harness_string_of_efl32_pht : (natural -> string) -> (natural -> string) -> elf32_program_header_table -> byte_sequence -> string*) +let harness_string_of_elf32_pht os proc pht bs0:string= + (" Type Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align\n" ^ + unlines (Lem_list.map (harness_string_of_elf32_program_header_table_entry os proc bs0) pht)) + +(*val harness_string_of_efl64_pht : (natural -> string) -> (natural -> string) -> elf64_program_header_table -> byte_sequence -> string*) +let harness_string_of_elf64_pht os proc pht bs0:string= + (" Type Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align\n" ^ + unlines (Lem_list.map (harness_string_of_elf64_program_header_table_entry os proc bs0) pht)) + +(*val harness_string_of_elf32_segment_section_mappings : elf32_header -> elf32_program_header_table -> elf32_section_header_table -> string_table -> string*) +let harness_string_of_elf32_segment_section_mappings hdr pht sht stbl:string= + (let map1 = +(Lem_list.mapi (fun i -> fun pent -> + let mapping = +((match get_elf32_section_to_segment_mapping hdr sht pent elf32_section_in_segment stbl with + | Fail err -> [("ERR: " ^ err)] + | Success mp -> intercalate " " mp + )) + in + let str = +(let temp = (concatS mapping) in + if temp = "" then + temp + else + temp ^ " ") + in + concatS [ +(" " ^ Ml_bindings.hex_string_of_nat_pad2 i) + ; " " + ; str + ] + ) pht) + in + concatS (intercalate "\n" map1)) + +(*val harness_string_of_elf64_segment_section_mappings : elf64_header -> elf64_program_header_table -> elf64_section_header_table -> string_table -> string*) +let harness_string_of_elf64_segment_section_mappings hdr pht sht stbl:string= + (let map1 = +(Lem_list.mapi (fun i -> fun pent -> + let mapping = +((match get_elf64_section_to_segment_mapping hdr sht pent elf64_section_in_segment stbl with + | Fail err -> [("ERR: " ^ err)] + | Success mp -> intercalate " " mp + )) + in + let str = +(let temp = (concatS mapping) in + if temp = "" then + temp + else + temp ^ " ") + in + concatS [ +(" " ^ Ml_bindings.hex_string_of_nat_pad2 i) + ; " " + ; str + ] + ) pht) + in + concatS (intercalate "\n" map1)) + +(*val harness_string_of_elf32_program_headers : (natural -> string) -> (natural -> string) -> elf32_header -> elf32_program_header_table -> elf32_section_header_table -> string_table -> byte_sequence -> string*) +let harness_string_of_elf32_program_headers os proc hdr pht sht stbl bs0:string= + (let pht_len = (List.length pht) in + if pht_len = 0 then + "\nThere are no program headers in this file." + else + unlines [ + "" + ; ("Elf file type is " ^ string_of_elf_file_type default_os_specific_print default_proc_specific_print (Nat_big_num.of_string (Uint32.to_string hdr.elf32_type))) + ; ("Entry point " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_entry)))) + ; ("There are " ^ (Pervasives.string_of_int (List.length pht) ^ (" program headers, starting at offset " ^ Uint32.to_string hdr.elf32_phoff))) + ; "" + ; "Program Headers:" + ; harness_string_of_elf32_pht os proc pht bs0 + ; "" + ; " Section to Segment mapping:" + ; " Segment Sections..." + ; harness_string_of_elf32_segment_section_mappings hdr pht sht stbl + ]) + +(*val harness_string_of_elf64_program_headers : (natural -> string) -> (natural -> string) -> elf64_header -> elf64_program_header_table -> elf64_section_header_table -> string_table -> byte_sequence -> string*) +let harness_string_of_elf64_program_headers os proc hdr pht sht stbl bs0:string= + (let pht_len = (List.length pht) in + if pht_len = 0 then + "\nThere are no program headers in this file." + else + unlines [ + "" + ; ("Elf file type is " ^ string_of_elf_file_type default_os_specific_print default_proc_specific_print (Nat_big_num.of_string (Uint32.to_string hdr.elf64_type))) + ; ("Entry point " ^ ("0x" ^ unsafe_hex_string_of_natural( 1) (Ml_bindings.nat_big_num_of_uint64 hdr.elf64_entry))) + ; ("There are " ^ (Pervasives.string_of_int (List.length pht) ^ (" program headers, starting at offset " ^ Uint64.to_string hdr.elf64_phoff))) + ; "" + ; "Program Headers:" + ; harness_string_of_elf64_pht os proc pht bs0 + ; "" + ; " Section to Segment mapping:" + ; " Segment Sections..." + ; harness_string_of_elf64_segment_section_mappings hdr pht sht stbl + ]) + +(*val harness_sht32_flag_legend : string*) +let harness_sht32_flag_legend:string= + "\nKey to Flags: + W (write), A (alloc), X (execute), M (merge), S (strings) + I (info), L (link order), G (group), T (TLS), E (exclude), x (unknown) + O (extra OS processing required) o (OS specific), p (processor specific)" + +(*val harness_sht64_flag_legend : natural -> string*) +let harness_sht64_flag_legend mach:string= + (if Nat_big_num.equal mach elf_ma_x86_64 || (Nat_big_num.equal + mach elf_ma_l10m || Nat_big_num.equal + mach elf_ma_k10m) then + "\nKey to Flags: + W (write), A (alloc), X (execute), M (merge), S (strings), l (large) + I (info), L (link order), G (group), T (TLS), E (exclude), x (unknown) + O (extra OS processing required) o (OS specific), p (processor specific)" + else + "\nKey to Flags: + W (write), A (alloc), X (execute), M (merge), S (strings) + I (info), L (link order), G (group), T (TLS), E (exclude), x (unknown) + O (extra OS processing required) o (OS specific), p (processor specific)") + +(*val harness_string_of_elf32_sht : (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_section_header_table -> string_table -> string*) +let harness_string_of_elf32_sht os proc usr sht stbl:string= + (" [Nr] Name Type Addr Off Size ES Flg Lk Inf Al\n" ^ + unlines (Lem_list.mapi (fun i -> fun sec -> + let is = +(let temp = (Pervasives.string_of_int i) in + if String.length temp = 1 then + " " ^ temp + else + temp) + in + let str = (" [" ^ (is ^ "]")) in + let ((gap : string), name1) = +((match String_table.get_string_at (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_name)) stbl with + | Fail err -> ("", ("ERR " ^ err)) + | Success nm -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_type)) sht_null then + let gap = (List.fold_right (^) (Missing_pervasives.replicate0(Nat_big_num.of_int 17) " ") " ") in + (gap, "") + else + let glen = (Nat_big_num.of_int ( Nat_num.nat_monus( 17) (String.length nm))) in + let gap = (List.fold_right (^) (Missing_pervasives.replicate0 glen " ") " ") in + (gap, nm) + )) + in + let str = (str ^ (" " ^ (name1 ^ gap))) in + let typ = (string_of_section_type os proc usr (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_type))) in + let str = (str ^ typ) in + let (gap, addr) = +(let mx = (Nat_big_num.of_int ( Nat_num.nat_monus( 15) (String.length typ))) in + let gap = (List.fold_right (^) (Missing_pervasives.replicate0 mx " ") " ") in + (gap, unsafe_hex_string_of_natural( 8) (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_addr)))) + in + let str = (str ^ (gap ^ addr)) in + let off = (unsafe_hex_string_of_natural( 6) (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_offset))) in + let str = (str ^ (" " ^ off)) in + let size2 = (unsafe_hex_string_of_natural( 6) (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_size))) in + let str = (str ^ (" " ^ size2)) in + let es = (unsafe_hex_string_of_natural( 2) (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_entsize))) in + let str = (str ^ (" " ^ es)) in + let flg = (string_of_section_flags os proc (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_flags))) in + let str = (str ^ (" " ^ flg)) in + let (gap, lnk) = +(let l = (Nat_big_num.to_string (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_link))) in + let gp = (Nat_big_num.of_int ( Nat_num.nat_monus( 2) (String.length l))) in + let gp = (List.fold_right (^) (replicate0 gp " ") " ") in + (gp, l)) + in + let str = (str ^ (gap ^ lnk)) in + let (gap, info) = +(let i = (Nat_big_num.to_string (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_info))) in + let gp = (Nat_big_num.of_int ( Nat_num.nat_monus( 3) (String.length i))) in + let gp = (List.fold_right (^) (replicate0 gp " ") " ") in + (gp, i)) + in + let str = (str ^ (gap ^ info)) in + let (gap, align) = +(let a = (Nat_big_num.to_string (Nat_big_num.of_string (Uint32.to_string sec.elf32_sh_addralign))) in + let gp = (Nat_big_num.of_int ( Nat_num.nat_monus( 2) (String.length a))) in + let gp = (List.fold_right (^) (replicate0 gp " ") " ") in + (gp, a)) + in + let str = (str ^ (gap ^ align)) in + str) sht)) + +(*val harness_string_of_elf64_sht : (natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_section_header_table -> string_table -> string*) +let harness_string_of_elf64_sht os proc usr sht stbl:string= + (" [Nr] Name Type Address Off Size ES Flg Lk Inf Al\n" ^ + unlines (Lem_list.mapi (fun i -> fun sec -> + let is = +(let temp = (Pervasives.string_of_int i) in + if String.length temp = 1 then + " " ^ temp + else + temp) + in + let str = (" [" ^ (is ^ "]")) in + let ((gap : string), name1) = +((match String_table.get_string_at (Nat_big_num.of_string (Uint32.to_string sec.elf64_sh_name)) stbl with + | Fail err -> ("", ("ERR " ^ err)) + | Success nm -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string sec.elf64_sh_type)) sht_null then + let gap = (List.fold_right (^) (Missing_pervasives.replicate0(Nat_big_num.of_int 17) " ") " ") in + (gap, "") + else + let glen = (Nat_big_num.of_int ( Nat_num.nat_monus( 17) (String.length nm))) in + let gap = (List.fold_right (^) (Missing_pervasives.replicate0 glen " ") " ") in + (gap, nm) + )) + in + let str = (str ^ (" " ^ (name1 ^ gap))) in + let typ = (string_of_section_type os proc usr (Nat_big_num.of_string (Uint32.to_string sec.elf64_sh_type))) in + let str = (str ^ typ) in + let (gap, addr) = +(let mx = (Nat_big_num.of_int ( Nat_num.nat_monus( 15) (String.length typ))) in + let gap = (List.fold_right (^) (Missing_pervasives.replicate0 mx " ") " ") in + (gap, unsafe_hex_string_of_natural( 16) (Ml_bindings.nat_big_num_of_uint64 sec.elf64_sh_addr))) + in + let str = (str ^ (gap ^ addr)) in + let off = (unsafe_hex_string_of_natural( 6) (Nat_big_num.of_string (Uint64.to_string sec.elf64_sh_offset))) in + let str = (str ^ (" " ^ off)) in + let size2 = (unsafe_hex_string_of_natural( 6) (Ml_bindings.nat_big_num_of_uint64 sec.elf64_sh_size)) in + let str = (str ^ (" " ^ size2)) in + let es = (unsafe_hex_string_of_natural( 2) (Ml_bindings.nat_big_num_of_uint64 sec.elf64_sh_entsize)) in + let str = (str ^ (" " ^ es)) in + let flg = (string_of_section_flags os proc (Ml_bindings.nat_big_num_of_uint64 sec.elf64_sh_flags)) in + let str = (str ^ (" " ^ flg)) in + let (gap, lnk) = +(let l = (Nat_big_num.to_string (Nat_big_num.of_string (Uint32.to_string sec.elf64_sh_link))) in + let gp = (Nat_big_num.of_int ( Nat_num.nat_monus( 2) (String.length l))) in + let gp = (List.fold_right (^) (replicate0 gp " ") " ") in + (gp, l)) + in + let str = (str ^ (gap ^ lnk)) in + let (gap, info) = +(let i = (Nat_big_num.to_string (Nat_big_num.of_string (Uint32.to_string sec.elf64_sh_info))) in + let gp = (Nat_big_num.of_int ( Nat_num.nat_monus( 3) (String.length i))) in + let gp = (List.fold_right (^) (replicate0 gp " ") " ") in + (gp, i)) + in + let str = (str ^ (gap ^ info)) in + let (gap, align) = +(let a = (Nat_big_num.to_string (Ml_bindings.nat_big_num_of_uint64 sec.elf64_sh_addralign)) in + let gp = (Nat_big_num.of_int ( Nat_num.nat_monus( 2) (String.length a))) in + let gp = (List.fold_right (^) (replicate0 gp " ") " ") in + (gp, a)) + in + let str = (str ^ (gap ^ align)) in + str) sht)) + + +(*val harness_string_of_elf32_section_headers : (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table -> string*) +let harness_string_of_elf32_section_headers os proc usr hdr sht stbl:string= + (unlines [ +("There are " ^ (Pervasives.string_of_int (List.length sht) ^ (" section headers, starting at offset 0x" ^ (unsafe_hex_string_of_natural( 0) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shoff)) ^ ":")))) + ; "" + ; "Section Headers:" + ; harness_string_of_elf32_sht os proc usr sht stbl + ] ^ harness_sht32_flag_legend) + +(*val harness_string_of_elf64_section_headers : (natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> string*) +let harness_string_of_elf64_section_headers os proc usr hdr sht stbl:string= + (unlines [ +("There are " ^ (Pervasives.string_of_int (List.length sht) ^ (" section headers, starting at offset 0x" ^ (unsafe_hex_string_of_natural( 0) (Nat_big_num.of_string (Uint64.to_string hdr.elf64_shoff)) ^ ":")))) + ; "" + ; "Section Headers:" + ; harness_string_of_elf64_sht os proc usr sht stbl + ] ^ harness_sht64_flag_legend (Nat_big_num.of_string (Uint32.to_string hdr.elf64_machine))) + +(*val harness_string_of_elf32_reloc_entry : (natural -> string) -> elf32_section_header_table -> + elf32_symbol_table -> string_table -> string_table -> elf32_relocation -> string*) +let harness_string_of_elf32_reloc_entry os sht symtab stbl sechdr_stbl rel:string= + (let off = (Nat_big_num.of_string (Uint32.to_string rel.elf32_r_offset)) in + let inf = (Nat_big_num.of_string (Uint32.to_string rel.elf32_r_info)) in + let typ = (Missing_pervasives.unsafe_string_take(Nat_big_num.of_int 22) (os (extract_elf32_relocation_r_type rel.elf32_r_info))) in + let typs = +(let len = (Nat_big_num.of_int ( Nat_num.nat_monus( 22) (String.length typ))) in + concatS (replicate0 len " ")) + in + let idx1 = (extract_elf32_relocation_r_sym rel.elf32_r_info) in + (match Lem_list.list_index symtab (Nat_big_num.to_int idx1) with + | None -> "harness_string_of_elf32_reloc_entry: Nothing returned" + | Some sym -> + let (nm, value, symtyp, secthdr) = +((match Lem_list.list_index symtab (Nat_big_num.to_int idx1) with + | None -> (stn_undef,Nat_big_num.of_int 0,Nat_big_num.of_int 0,Nat_big_num.of_int 0) + | Some sym -> (Nat_big_num.of_string (Uint32.to_string sym.elf32_st_name), + Nat_big_num.of_string (Uint32.to_string sym.elf32_st_value), get_elf32_symbol_type sym, + Nat_big_num.of_string (Uint32.to_string sym.elf32_st_shndx)) + )) + in + if Nat_big_num.equal symtyp stt_section then + let vlu = (" " ^ unsafe_hex_string_of_natural( 8) value) in + let nm = +((match Lem_list.list_index sht (Nat_big_num.to_int secthdr) with + | None -> "XXX" + | Some shdr -> + (match String_table.get_string_at (Nat_big_num.of_string (Uint32.to_string shdr.elf32_sh_name)) sechdr_stbl with + | Fail f -> f + | Success n -> n + ) + )) + in + concatS [ + unsafe_hex_string_of_natural( 8) off + ; " " + ; unsafe_hex_string_of_natural( 8) inf + ; " " + ; typ + ; typs + ; vlu + ; " " + ; nm + ] + else if Nat_big_num.equal nm stn_undef then + concatS [ + unsafe_hex_string_of_natural( 8) off + ; " " + ; unsafe_hex_string_of_natural( 8) inf + ; " " + ; typ + ; typs + ] + else + let vlu = (" " ^ unsafe_hex_string_of_natural( 8) (Nat_big_num.of_string (Uint32.to_string sym.elf32_st_value))) in + let nm = +((match String_table.get_string_at nm stbl with + | Fail f -> f + | Success n -> n + )) + in + concatS [ + unsafe_hex_string_of_natural( 8) off + ; " " + ; unsafe_hex_string_of_natural( 8) inf + ; " " + ; typ + ; typs + ; vlu + ; " " + ; nm + ] + )) + +(*val harness_string_of_elf64_reloc_a_entry : (natural -> string) -> elf64_symbol_table -> + elf64_section_header_table -> string_table -> string_table -> elf64_relocation_a -> string*) +let harness_string_of_elf64_reloc_a_entry os symtab sht stbl sechdr_stbl rel:string= + (let off = (Ml_bindings.nat_big_num_of_uint64 rel.elf64_ra_offset) in + let inf = (Ml_bindings.nat_big_num_of_uint64 rel.elf64_ra_info) in + let add = (Nat_big_num.of_int64 rel.elf64_ra_addend) in + let typ = (Missing_pervasives.unsafe_string_take(Nat_big_num.of_int 22) (os (extract_elf64_relocation_r_type rel.elf64_ra_info))) in + let typs = +(let len = (Nat_big_num.of_int ( Nat_num.nat_monus( 22) (String.length typ))) in + concatS (replicate0 len " ")) + in + let idx1 = (extract_elf64_relocation_r_sym rel.elf64_ra_info) in + let (nm, value, symtyp, secthdr) = +((match Lem_list.list_index symtab (Nat_big_num.to_int idx1) with + | None -> (stn_undef,Nat_big_num.of_int 0,Nat_big_num.of_int 0,Nat_big_num.of_int 0) + | Some sym -> (Nat_big_num.of_string (Uint32.to_string sym.elf64_st_name), + Ml_bindings.nat_big_num_of_uint64 sym.elf64_st_value, get_elf64_symbol_type sym, + Nat_big_num.of_string (Uint32.to_string sym.elf64_st_shndx)) + )) + in + if Nat_big_num.equal symtyp stt_section then + let vlu = (" " ^ unsafe_hex_string_of_natural( 16) value) in + let nm = +((match Lem_list.list_index sht (Nat_big_num.to_int secthdr) with + | None -> "XXX" + | Some shdr -> + (match String_table.get_string_at (Nat_big_num.of_string (Uint32.to_string shdr.elf64_sh_name)) sechdr_stbl with + | Fail f -> f + | Success n -> n + ) + )) + in + concatS [ + unsafe_hex_string_of_natural( 16) off + ; " " + ; unsafe_hex_string_of_natural( 16) inf + ; " " + ; typ + ; typs + ; vlu + ; " " + ; nm + ; " + " + ; Ml_bindings.hex_string_of_big_int_no_padding add + ] + else if Nat_big_num.equal nm stn_undef then + concatS [ + unsafe_hex_string_of_natural( 16) off + ; " " + ; unsafe_hex_string_of_natural( 16) inf + ; " " + ; typ + ; typs + ; " " + ; Ml_bindings.hex_string_of_big_int_no_padding add + ] + else + let vlu = (" " ^ unsafe_hex_string_of_natural( 16) value) in + let nm = +((match String_table.get_string_at nm stbl with + | Fail f -> f + | Success n -> n + )) + in + concatS [ + unsafe_hex_string_of_natural( 16) off + ; " " + ; unsafe_hex_string_of_natural( 16) inf + ; " " + ; typ + ; typs + ; vlu + ; " " + ; nm + ; " + " + ; Ml_bindings.hex_string_of_big_int_no_padding add + ]) + +(*val harness_string_of_elf32_relocs' : endianness -> (natural -> string) -> elf32_file -> elf32_section_header_table -> + elf32_section_header_table -> string_table -> string_table -> byte_sequence -> string*) +let harness_string_of_elf32_relocs' endian os f1 sht_relocs sht shdr stbl bs0:string= + (let rels = +(mapM (fun ent -> + let off = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_size)) in + let lnk = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_link)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rels -> + Elf_relocation.read_elf32_relocation_section' endian rels >>= (fun sect -> + Elf_file.get_elf32_symbol_table_by_index f1 lnk >>= (fun symtab -> + return (sect, ent, symtab)))) + ) sht_relocs + >>= + mapM (fun (rels, ent, symtab) -> + let nm = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_name)) in + let off = (unsafe_hex_string_of_natural( 0) (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_offset))) in + let len = (Pervasives.string_of_int (List.length rels)) in + String_table.get_string_at nm shdr >>= (fun nm -> + let hdr = ("Relocation section '" ^ (nm ^ ("' at offset 0x" ^ (off ^ (" contains " ^ (len ^ " entries:\n")))))) in + let ttl = " Offset Info Type Sym. Value Symbol's Name\n" in + let body = (concatS (intercalate "\n" (Lem_list.map (harness_string_of_elf32_reloc_entry os sht symtab stbl shdr) rels))) in + return (hdr ^ (ttl ^ body))))) + in + (match rels with + | Fail err -> err + | Success s -> concatS (intercalate "\n\n" s) + )) + +(*val harness_string_of_elf64_relocs' : endianness -> (natural -> string) -> elf64_file -> + elf64_section_header_table -> elf64_section_header_table -> + string_table -> string_table -> byte_sequence -> string*) +let harness_string_of_elf64_relocs' endian os f1 reloc_sht sht shdr stbl bs0:string= + (let rels = +(mapM (fun ent -> + let off = (Nat_big_num.of_string (Uint64.to_string ent.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 ent.elf64_sh_size) in + let lnk = (Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_link)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rels -> + Elf_relocation.read_elf64_relocation_a_section' endian rels >>= (fun sect -> + Elf_file.get_elf64_symbol_table_by_index f1 lnk >>= (fun symtab -> + return (sect, ent, symtab)))) + ) reloc_sht + >>= + mapM (fun (rels, ent, symtab) -> + let nm = (Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_name)) in + let off = (unsafe_hex_string_of_natural( 0) (Nat_big_num.of_string (Uint64.to_string ent.elf64_sh_offset))) in + let len = (Pervasives.string_of_int (List.length rels)) in + String_table.get_string_at nm shdr >>= (fun nm -> + let hdr = ("Relocation section '" ^ (nm ^ ("' at offset 0x" ^ (off ^ (" contains " ^ (len ^ " entries:\n")))))) in + let ttl = " Offset Info Type Symbol's Value Symbol's Name + Addend\n" in + let body = (concatS (intercalate "\n" (Lem_list.map (harness_string_of_elf64_reloc_a_entry os symtab sht stbl shdr) rels))) in + return (hdr ^ (ttl ^ body))))) + in + (match rels with + | Fail err -> err + | Success s -> concatS (intercalate "\n\n" s) + )) + +(*val harness_string_of_elf32_relocs : elf32_file -> (natural -> string) -> byte_sequence -> string*) +let harness_string_of_elf32_relocs f1 os bs0:string= + (let hdr = (f1.elf32_file_header) in + let sht = (f1.elf32_file_section_header_table) in + let endian = (get_elf32_header_endianness hdr) in + let rel_secs = (List.filter (fun x -> + x.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string sht_rel)) sht) in + if List.length rel_secs = 0 then + "\nThere are no relocations in this file." + else + (match get_elf32_file_symbol_string_table f1 with + | Fail err -> err + | Success stbl -> + (match get_elf32_file_section_header_string_table f1 with + | Fail err -> err + | Success shdr -> "\n" ^ harness_string_of_elf32_relocs' endian os f1 rel_secs sht shdr stbl bs0 + ) + )) + +(*val harness_string_of_elf64_relocs : elf64_file -> (natural -> string) -> byte_sequence -> string*) +let harness_string_of_elf64_relocs f1 os bs0:string= + (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 rel_secs = (List.filter (fun x -> + x.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string sht_rela)) sht) in + if List.length rel_secs = 0 then + "\nThere are no relocations in this file." + else + (match get_elf64_file_symbol_string_table f1 with + | Fail err -> err + | Success stbl -> + (match get_elf64_file_section_header_string_table f1 with + | Fail err -> err + | Success shdr -> "\n" ^ harness_string_of_elf64_relocs' endian os f1 rel_secs sht shdr stbl bs0 + ) + )) + +(*val harness_string_of_elf32_symbol_table_entry : nat -> (natural -> string) -> + (natural -> string) -> byte_sequence -> string_table -> elf32_symbol_table_entry -> string*) +let harness_string_of_elf32_symbol_table_entry num os proc bs0 stbl ent:string= + (let vlu = (unsafe_hex_string_of_natural( 8) (Nat_big_num.of_string (Uint32.to_string ent.elf32_st_value))) in + let siz = (Nat_big_num.to_string (Nat_big_num.of_string (Uint32.to_string ent.elf32_st_size))) in + let siz_pad = + (let pad = (Nat_num.nat_monus( 5) (String.length siz)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let typ = (string_of_symbol_type (get_elf32_symbol_type ent) os proc) in + let bnd = (string_of_symbol_binding (get_elf32_symbol_binding ent) os proc) in + let bnd_pad = +(let pad = (Nat_num.nat_monus( 6) (String.length typ)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let vis = (string_of_symbol_visibility (Nat_big_num.of_string (Uint32.to_string ent.elf32_st_other))) in + let vis_pad = +(let pad = (Nat_num.nat_monus( 6) (String.length bnd)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let ndx = +(let tmp = (Nat_big_num.of_string (Uint32.to_string ent.elf32_st_shndx)) in + if Nat_big_num.equal tmp shn_undef then + "UND" + else if Nat_big_num.equal tmp shn_abs then + "ABS" + else + Nat_big_num.to_string tmp) + in + let ndx_pad = +(let pad = (Nat_num.nat_monus( 3) (String.length ndx)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let nm = +(let idx1 = (Nat_big_num.of_string (Uint32.to_string ent.elf32_st_name)) in + if Nat_big_num.equal idx1(Nat_big_num.of_int 0) then + "" + else + (match String_table.get_string_at idx1 stbl with + | Fail err -> err + | Success s -> s + )) + in + let sym = "" in + let num = +(let temp = (Pervasives.string_of_int num) in + let pad = (Nat_num.nat_monus( 3) (String.length temp)) in + if pad = 0 then + temp + else + let spcs = (concatS (replicate0 (Nat_big_num.of_int pad) " ")) in + spcs ^ temp) + in + concatS [ + " " + ; (num ^ ":") + ; " " + ; vlu + ; " " + ; siz_pad; siz + ; " " + ; typ + ; " " + ; bnd_pad; bnd + ; " " + ; vis_pad; vis + ; " " + ; ndx_pad; ndx + ; " " + ; nm + ; sym + ]) + +(*val harness_string_of_elf32_syms' : endianness -> (natural -> string) -> (natural -> string) -> elf32_file -> elf32_section_header_table -> elf32_section_header_table -> string_table -> byte_sequence -> string*) +let harness_string_of_elf32_syms' endian os proc f1 filtered_sht sht shdr bs0:string= + (let rels = +(mapM (fun ent -> + let off = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_size)) in + let lnk = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_link)) in + let typ = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_type)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun syms -> + Elf_symbol_table.read_elf32_symbol_table endian syms >>= (fun sect -> + Elf_file.get_elf32_string_table_by_index f1 lnk >>= (fun strtab -> + return (sect, ent, strtab, typ)))) + ) filtered_sht >>= (fun sects -> + mapM (fun (syms, ent, strtab, typ) -> + let nm = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_name)) in + let len = (Pervasives.string_of_int (List.length syms)) in + String_table.get_string_at nm shdr >>= (fun nm -> + let hdr = ("Symbol table '" ^ (nm ^ ("' contains " ^ (len ^ " entries:\n")))) in + let ttl = " Num: Value Size Type Bind Vis Ndx Name\n" in + let body = (concatS (intercalate "\n" (Lem_list.mapi (fun n -> + harness_string_of_elf32_symbol_table_entry n os proc bs0 strtab) syms))) + in + return (hdr ^ (ttl ^ body)))) sects)) + in + (match rels with + | Fail err -> err + | Success s -> concatS (intercalate "\n\n" s) + )) + +(*val harness_string_of_elf32_syms : elf32_file -> (natural -> string) -> (natural -> string) -> byte_sequence -> string*) +let harness_string_of_elf32_syms f1 os proc bs0:string= + (let hdr = (f1.elf32_file_header) in + let sht = (f1.elf32_file_section_header_table) in + let endian = (get_elf32_header_endianness hdr) in + let sym_secs = (List.filter (fun x -> +(x.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string sht_dynsym)) || +(x.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string sht_symtab))) sht) + in + if List.length sym_secs = 0 then + "\nThere are no symbols in this file." + else + (match get_elf32_file_section_header_string_table f1 with + | Fail err -> err + | Success shdr -> + "\n" ^ + harness_string_of_elf32_syms' endian os proc f1 sym_secs sht shdr bs0 + )) + +(*val harness_string_of_elf64_symbol_table_entry : nat -> (natural -> string) -> (natural -> string) -> string_table -> elf64_symbol_table_entry -> string*) +let harness_string_of_elf64_symbol_table_entry num os proc stbl ent:string= + (let vlu = (unsafe_hex_string_of_natural( 16) (Ml_bindings.nat_big_num_of_uint64 ent.elf64_st_value)) in + let siz = (Nat_big_num.to_string (Ml_bindings.nat_big_num_of_uint64 ent.elf64_st_size)) in + let siz_pad = + (let pad = (Nat_num.nat_monus( 5) (String.length siz)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let typ = (string_of_symbol_type (get_elf64_symbol_type ent) os proc) in + let bnd = (string_of_symbol_binding (get_elf64_symbol_binding ent) os proc) in + let bnd_pad = +(let pad = (Nat_num.nat_monus( 8) (String.length typ)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let vis = (string_of_symbol_visibility (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_other))) in + let vis_pad = +(let pad = (Nat_num.nat_monus( 6) (String.length bnd)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let ndx = +(let tmp = (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_shndx)) in + if Nat_big_num.equal tmp shn_undef then + "UND" + else if Nat_big_num.equal tmp shn_abs then + "ABS" + else + Nat_big_num.to_string tmp) + in + let ndx_pad = +(let pad = (Nat_num.nat_monus( 3) (String.length ndx)) in + if pad = 0 then + "" + else + concatS (replicate0 (Nat_big_num.of_int pad) " ")) + in + let nm = +(let idx1 = (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_name)) in + if Nat_big_num.equal idx1(Nat_big_num.of_int 0) then + "" + else + (match String_table.get_string_at idx1 stbl with + | Fail err -> err + | Success s -> s + )) + in + let num = +(let temp = (Pervasives.string_of_int num) in + let pad = (Nat_num.nat_monus( 3) (String.length temp)) in + if pad = 0 then + temp + else + let spcs = (concatS (replicate0 (Nat_big_num.of_int pad) " ")) in + spcs ^ temp) + in + concatS [ + " " + ; (num ^ ":") + ; " " + ; vlu + ; " " + ; siz_pad; siz + ; " " + ; typ + ; bnd_pad; bnd + ; " " + ; vis_pad; vis + ; " " + ; ndx_pad; ndx + ; " " + ; nm + ]) + +(*val harness_string_of_elf64_syms' : endianness -> (natural -> string) -> (natural -> string) -> elf64_file -> elf64_section_header_table -> elf64_section_header_table -> string_table -> byte_sequence -> string*) +let harness_string_of_elf64_syms' endian os proc f1 filtered_sht sht shdr bs0:string= + (let rels = +(mapM (fun ent -> + let off = (Nat_big_num.of_string (Uint64.to_string ent.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 ent.elf64_sh_size) in + let lnk = (Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_link)) in + let typ = (Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_type)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun syms -> + Elf_symbol_table.read_elf64_symbol_table endian syms >>= (fun sect -> + Elf_file.get_elf64_string_table_by_index f1 lnk >>= (fun strtab -> + return (sect, ent, strtab, typ)))) + ) filtered_sht + >>= + mapM (fun (syms, ent, strtab, typ) -> + let nm = (Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_name)) in + let len = (Pervasives.string_of_int (List.length syms)) in + String_table.get_string_at nm shdr >>= (fun nm -> + let hdr = ("Symbol table '" ^ (nm ^ ("' contains " ^ (len ^ " entries:\n")))) in + let ttl = " Num: Value Size Type Bind Vis Ndx Name\n" in + let body = (concatS (intercalate "\n" (Lem_list.mapi (fun n -> + harness_string_of_elf64_symbol_table_entry n os proc strtab) syms))) + in + return (hdr ^ (ttl ^ body))))) + in + (match rels with + | Fail err -> err + | Success s -> concatS (intercalate "\n\n" s) + )) + +(*val harness_string_of_elf64_syms : elf64_file -> (natural -> string) -> (natural -> string) -> byte_sequence -> string*) +let harness_string_of_elf64_syms f1 os proc bs0:string= + (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 sym_secs = (List.filter (fun x -> +(x.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string sht_dynsym)) || +(x.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string sht_symtab))) sht) + in + if List.length sym_secs = 0 then + "\nThere are no symbols in this file." + else + (match get_elf64_file_section_header_string_table f1 with + | Fail err -> err + | Success shdr -> + "\n" ^ + harness_string_of_elf64_syms' endian os proc f1 sym_secs sht shdr bs0 + )) + +(*val string_of_unix_time : natural -> string*) + +(*val string_of_dyn_value : forall 'addr 'size. dyn_value 'addr 'size -> + ('addr -> string) -> ('size -> string) -> string*) +let string_of_dyn_value dyn addr size2:string= + ((match dyn with + | Address a -> addr a + | Size s -> size2 s + | FName f -> f + | Path p -> p + | SOName f -> "Library soname: [" ^ (f ^ "]") + | RPath p -> "Library rpath: [" ^ (p ^ "]") + | RunPath p -> "Library runpath: [" ^ (p ^ "]") + | Flags f -> string_of_dt_flag f + | Flags1 f -> "Flags: " ^ gnu_string_of_dt_flag_1 f + | Ignored -> "" + | Checksum s -> "0x" ^ unsafe_hex_string_of_natural( 0) s + | Library l -> "Shared library: [" ^ (l ^ "]") + | Numeric n -> Nat_big_num.to_string n + | RelType r -> string_of_rel_type r + | Timestamp t -> Ml_bindings.string_of_unix_time t + | Null -> "0x0" + )) + +(*val string_of_elf32_dyn_value : elf32_dyn_value -> string*) +let string_of_elf32_dyn_value dyn:string= + (string_of_dyn_value + dyn + (fun a -> "0x" ^ unsafe_hex_string_of_natural( 0) (Nat_big_num.of_string (Uint32.to_string a))) + (fun s -> Uint32.to_string s ^ " (bytes)")) + +(*val string_of_elf64_dyn_value : elf64_dyn_value -> string*) +let string_of_elf64_dyn_value dyn:string= + (string_of_dyn_value + dyn + (fun a -> "0x" ^ unsafe_hex_string_of_natural( 0) (Ml_bindings.nat_big_num_of_uint64 a)) + (fun s -> Uint64.to_string s ^ " (bytes)")) + +(*val harness_string_of_elf32_dyn_entry : bool -> elf32_dyn -> (natural -> bool) -> (natural -> string) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> string_table -> string*) +let harness_string_of_elf32_dyn_entry shared_object dyn os_additional_tags typ os_dyn proc_dyn stbl:string= + (let tag = (unsafe_hex_string_of_natural( 8) (Nat_big_num.abs (Nat_big_num.of_int32 dyn.elf32_dyn_tag))) in + let typ = ("(" ^ (typ (Nat_big_num.abs (Nat_big_num.of_int32 dyn.elf32_dyn_tag)) ^ ")")) in + let vlu = +((match get_value_of_elf32_dyn shared_object dyn os_additional_tags os_dyn proc_dyn stbl with + | Fail f -> f + | Success v -> string_of_elf32_dyn_value v + )) + in + let vlu_pad = +(let pad = (Nat_num.nat_monus( 29) (String.length typ)) in + if pad = 0 then + "" + else + let reps = (replicate0 (Nat_big_num.of_int pad) " ") in + concatS reps) + in + concatS [ + " " + ; ("0x" ^ tag) + ; " " + ; typ + ; vlu_pad; vlu + ]) + +(*val harness_string_of_elf32_dynamic_section' : elf32_file -> elf32_program_header_table_entry -> + byte_sequence -> (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> (natural -> string) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> string*) +let harness_string_of_elf32_dynamic_section' f1 dyn bs0 os_additional_ranges os proc os_print os_dyn proc_dyn:string= + (let endian = (get_elf32_header_endianness f1.elf32_file_header) in + let sht = (f1.elf32_file_section_header_table) in + let off = (Nat_big_num.of_string (Uint32.to_string dyn.elf32_p_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string dyn.elf32_p_filesz)) in + let shared_object = (is_elf32_shared_object_file f1.elf32_file_header) in + let res = +(Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + obtain_elf32_dynamic_section_contents f1 os_additional_ranges os proc bs0 >>= (fun dyns -> + get_string_table_of_elf32_dyn_section endian dyns sht bs0 >>= (fun stbl -> + return (Lem_list.map (fun x -> harness_string_of_elf32_dyn_entry shared_object x os_additional_ranges os_print os_dyn proc_dyn stbl) dyns))))) + in + (match res with + | Fail f -> f + | Success s -> + let off = (unsafe_hex_string_of_natural( 0) off) in + let entries = (Pervasives.string_of_int (List.length s)) in + concatS [ + "\n" + ; ("Dynamic section at offset 0x" ^ (off ^ (" contains " ^ (entries ^ " entries:\n")))) + ; " Tag Type Name/Value\n" + ; concatS (intercalate "\n" s) + ] + )) + +(*val harness_string_of_elf32_dynamic_section : elf32_file -> byte_sequence -> + (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> (natural -> string) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> string*) +let harness_string_of_elf32_dynamic_section f1 bs0 os_additional_ranges os proc os_print os_dyn proc_dyn:string= + (let pht = (f1.elf32_file_program_header_table) in + let dyn = +(List.filter (fun x -> + x.elf32_p_type = Uint32.of_string (Nat_big_num.to_string elf_pt_dynamic) + ) pht) + in + let print_msg = (is_elf32_shared_object_file f1.elf32_file_header || + is_elf32_executable_file f1.elf32_file_header) + in + (match dyn with + | [] -> + if print_msg then + "\nThere is no dynamic section in this file." + else + "" + | [x] -> harness_string_of_elf32_dynamic_section' f1 x bs0 os_additional_ranges os proc os_print os_dyn proc_dyn + | _ -> "Multiple dynamic sections detected." + )) + +(*val harness_string_of_elf64_dyn_entry : bool -> elf64_dyn -> (natural -> bool) -> (natural -> string) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> string_table -> string*) +let harness_string_of_elf64_dyn_entry shared_object dyn os_additional_ranges typ os_dyn proc_dyn stbl:string= + (let tag = (unsafe_hex_string_of_natural( 16) (Nat_big_num.abs (Nat_big_num.of_int64 dyn.elf64_dyn_tag))) in + let typ = ("(" ^ (typ (Nat_big_num.abs (Nat_big_num.of_int64 dyn.elf64_dyn_tag)) ^ ")")) in + let vlu = +((match get_value_of_elf64_dyn shared_object dyn os_additional_ranges os_dyn proc_dyn stbl with + | Fail f -> f + | Success v -> string_of_elf64_dyn_value v + )) + in + let vlu_pad = +(let pad = (Nat_num.nat_monus( 21) (String.length typ)) in + if pad = 0 then + "" + else + let reps = (replicate0 (Nat_big_num.of_int pad) " ") in + concatS reps) + in + concatS [ + " " + ; ("0x" ^ tag) + ; " " + ; typ + ; vlu_pad; vlu + ]) + +(*val harness_string_of_elf64_dynamic_section' : elf64_file -> elf64_program_header_table_entry -> + byte_sequence -> (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> (natural -> string) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> string*) +let harness_string_of_elf64_dynamic_section' f1 dyn bs0 os_additional_ranges os proc os_print os_dyn proc_dyn:string= + (let endian = (get_elf64_header_endianness f1.elf64_file_header) in + let sht = (f1.elf64_file_section_header_table) in + let off = (Nat_big_num.of_string (Uint64.to_string dyn.elf64_p_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 dyn.elf64_p_filesz) in + let shared_object = (is_elf64_shared_object_file f1.elf64_file_header) in + let res = +(Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + obtain_elf64_dynamic_section_contents f1 os_additional_ranges os proc bs0 >>= (fun dyns -> + get_string_table_of_elf64_dyn_section endian dyns sht bs0 >>= (fun stbl -> + return (Lem_list.map (fun x -> harness_string_of_elf64_dyn_entry shared_object x os_additional_ranges os_print os_dyn proc_dyn stbl) dyns))))) + in + (match res with + | Fail f -> f + | Success s -> + let off = (unsafe_hex_string_of_natural( 0) off) in + let entries = (Pervasives.string_of_int (List.length s)) in + concatS [ + "\n" + ; ("Dynamic section at offset 0x" ^ (off ^ (" contains " ^ (entries ^ " entries:\n")))) + ; " Tag Type Name/Value\n" + ; concatS (intercalate "\n" s) + ] + )) + +(*val harness_string_of_elf64_dynamic_section : elf64_file -> byte_sequence -> + (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> (natural -> string) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> string*) +let harness_string_of_elf64_dynamic_section f1 bs0 os_additional_ranges os proc os_print os_dyn proc_dyn:string= + (let pht = (f1.elf64_file_program_header_table) in + let print_msg = (is_elf64_shared_object_file f1.elf64_file_header || + is_elf64_executable_file f1.elf64_file_header) + in + let dyn = +(List.filter (fun x -> + x.elf64_p_type = Uint32.of_string (Nat_big_num.to_string elf_pt_dynamic) + ) pht) + in + (match dyn with + | [] -> + if print_msg then + "\nThere is no dynamic section in this file." + else + "" + | [x] -> harness_string_of_elf64_dynamic_section' f1 x bs0 os_additional_ranges os proc os_print os_dyn proc_dyn + | _ -> "Multiple dynamic sections detected." + )) + + diff --git a/lib/ocaml_rts/linksem/adaptors/sail_interface.ml b/lib/ocaml_rts/linksem/adaptors/sail_interface.ml new file mode 100644 index 00000000..f3024467 --- /dev/null +++ b/lib/ocaml_rts/linksem/adaptors/sail_interface.ml @@ -0,0 +1,250 @@ +(*Generated by Lem from adaptors/sail_interface.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +open Lem_tuple + +open Lem_assert_extra + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +open Elf_header +open Elf_file +open Elf_interpreted_section +open Elf_interpreted_segment +open String_table +open Elf_symbol_table +open Elf_program_header_table +open Elf_types_native_uint + +open Hex_printing + +type executable_process_image = + | ELF_Class_32 of elf32_executable_process_image + | ELF_Class_64 of elf64_executable_process_image + +(*val string_of_segment_provenance : segment_provenance -> string*) +let string_of_segment_provenance p:string= + ((match p with + | FromELF -> "Segment from ELF file" + | AutoGenerated -> "Segment auto generated" + )) + +(*val string_of_executable_process_image : executable_process_image -> string*) +let string_of_executable_process_image img2:string= + ((match img2 with + | ELF_Class_32 (segs, entry_point, machine_type) -> + let machine_type = (string_of_elf_machine_architecture machine_type) in + let entry_point = (unsafe_hex_string_of_natural( 16) entry_point) in + let segs = (Lem_list.map (fun (seg, prov) -> + let prov = (string_of_segment_provenance prov) in + let seg = (string_of_elf32_interpreted_segment seg) in + "Segment provenance: " ^ (prov ^ ("\n" ^ seg)) + ) segs) + in + unlines ( List.rev_append (List.rev [ + "32-bit ELF executable image" + ; ("Machine type: " ^ machine_type) + ; ("Entry point: " ^ entry_point) + ; "" + ]) segs) + | ELF_Class_64 (segs, entry_point, machine_type) -> + let machine_type = (string_of_elf_machine_architecture machine_type) in + let entry_point = (unsafe_hex_string_of_natural( 16) entry_point) in + let segs = (intercalate "\n" (Lem_list.map (fun (seg, prov) -> + let prov = (string_of_segment_provenance prov) in + let seg = (string_of_elf64_interpreted_segment seg) in + "Segment provenance: " ^ (prov ^ ("\n" ^ seg)) + ) segs)) + in + unlines ( List.rev_append (List.rev [ + "64-bit ELF executable image" + ; ("Machine type: " ^ machine_type) + ; ("Entry point: " ^ entry_point) + ; "" + ]) segs) + )) + +(*val populate : string -> error executable_process_image*) +let populate fname1:(executable_process_image)error= +( + (* Acquire the data from the file... *)Byte_sequence.acquire fname1 >>= (fun bs0 -> + (* Read the magic number and the flags in the header... *) + repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "populate: ELF ident transcription error" + | Some c -> + (* Calculate whether we are dealing with a 32- or 64-bit file based on + * what we have read... + *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + Elf_file.read_elf32_file bs0 >>= (fun ef5 -> + if Elf_program_header_table.get_elf32_static_linked ef5.elf32_file_program_header_table then + Elf_file.get_elf32_executable_image ef5 >>= (fun img2 -> + return (ELF_Class_32 img2)) + else + fail "populate: not a statically linked executable") + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + Elf_file.read_elf64_file bs0 >>= (fun ef5 -> + if Elf_program_header_table.get_elf64_static_linked ef5.elf64_file_program_header_table then + Elf_file.get_elf64_executable_image ef5 >>= (fun img2 -> + return (ELF_Class_64 img2)) + else + fail "populate: not a statically linked executable") + else + fail "populate: ELF class unrecognised" + )))) + +(*val populate' : byte_sequence -> error executable_process_image*) +let populate' bs0:(executable_process_image)error= +( + (* Read the magic number and the flags in the header... *)repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "populate': ELF ident transcription error" + | Some c -> + (* Calculate whether we are dealing with a 32- or 64-bit file based on + * what we have read... + *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + Elf_file.read_elf32_file bs0 >>= (fun ef5 -> + if Elf_program_header_table.get_elf32_static_linked ef5.elf32_file_program_header_table then + Elf_file.get_elf32_executable_image ef5 >>= (fun img2 -> + return (ELF_Class_32 img2)) + else + fail "populate': not a statically linked executable") + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + Elf_file.read_elf64_file bs0 >>= (fun ef5 -> + if Elf_program_header_table.get_elf64_static_linked ef5.elf64_file_program_header_table then + Elf_file.get_elf64_executable_image ef5 >>= (fun img2 -> + return (ELF_Class_64 img2)) + else + fail "populate': not a statically linked executable") + else + fail "populate': ELF class unrecognised" + ))) + +(*val obtain_global_symbol_init_info : string -> error global_symbol_init_info*) +let obtain_global_symbol_init_info fname1:((string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*(byte_sequence)option*Nat_big_num.num))list)error= +( + (* Acquire the data from the file... *)Byte_sequence.acquire fname1 >>= (fun bs0 -> + (* Read the magic number and the flags in the header... *) + repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "obtain_global_symbol_init_info: ELF ident transcription error" + | Some c -> + (* Calculate whether we are dealing with a 32- or 64-bit file based on + * what we have read... + *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf32_static_linked f1.elf32_file_program_header_table then + Elf_file.get_elf32_file_global_symbol_init f1 >>= (fun init1 -> + return init1) + else + fail "obtain_global_symbol_init_info: not a statically linked executable") + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf64_static_linked f1.elf64_file_program_header_table then + Elf_file.get_elf64_file_global_symbol_init f1 >>= (fun init1 -> + return init1) + else + fail "obtain_global_symbol_init_info: not a statically linked executable") + else + fail "obtain_global_symbol_init_info: ELF class unrecognised" + )))) + +(*val obtain_global_symbol_init_info' : byte_sequence -> error global_symbol_init_info*) +let obtain_global_symbol_init_info' bs0:((string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*(byte_sequence)option*Nat_big_num.num))list)error= +( + (* Read the magic number and the flags in the header... *)repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "obtain_global_symbol_init_info': ELF ident transcription error" + | Some c -> + (* Calculate whether we are dealing with a 32- or 64-bit file based on + * what we have read... + *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf32_static_linked f1.elf32_file_program_header_table then + Elf_file.get_elf32_file_global_symbol_init f1 >>= (fun init1 -> + return init1) + else + fail "obtain_global_symbol_init_info': not a statically linked executable") + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf64_static_linked f1.elf64_file_program_header_table then + Elf_file.get_elf64_file_global_symbol_init f1 >>= (fun init1 -> + return init1) + else + fail "obtain_global_symbol_init_info': not a statically linked executable") + else + fail "obtain_global_symbol_init_info': ELF class unrecognised" + ))) + +(*val populate_and_obtain_global_symbol_init_info : string -> error (elf_file * executable_process_image * global_symbol_init_info)*) +let populate_and_obtain_global_symbol_init_info fname1:(elf_file*executable_process_image*(string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*(byte_sequence)option*Nat_big_num.num))list)error= +( + (* Acquire the data from the file... *)Byte_sequence.acquire fname1 >>= (fun bs0 -> + (* Read the magic number and the flags in the header... *) + repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "populate_and_obtain_global_symbol_init_info: ELF ident transcription error" + | Some c -> + (* Calculate whether we are dealing with a 32- or 64-bit file based on + * what we have read... + *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf32_static_linked f1.elf32_file_program_header_table then + Elf_file.get_elf32_file_global_symbol_init f1 >>= (fun init1 -> + Elf_file.get_elf32_executable_image f1 >>= (fun img2 -> + return ((ELF_File_32 f1), (ELF_Class_32 img2), init1))) + else + fail "populate_and_obtain_global_symbol_init_info: not a statically linked executable") + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf64_static_linked f1.elf64_file_program_header_table then + Elf_file.get_elf64_file_global_symbol_init f1 >>= (fun init1 -> + Elf_file.get_elf64_executable_image f1 >>= (fun img2 -> + return ((ELF_File_64 f1), (ELF_Class_64 img2), init1))) + else + fail "populate_and_obtain_global_symbol_init_info: not a statically linked executable") + else + fail "populate_and_obtain_global_symbol_init_info: ELF class unrecognised" + )))) + +(*val populate_and_obtain_global_symbol_init_info' : byte_sequence -> error (elf_file * executable_process_image * global_symbol_init_info)*) +let populate_and_obtain_global_symbol_init_info' bs0:(elf_file*executable_process_image*(string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*(byte_sequence)option*Nat_big_num.num))list)error= +( + (* Read the magic number and the flags in the header... *)repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "populate_and_obtain_global_symbol_init_info': ELF ident transcription error" + | Some c -> + (* Calculate whether we are dealing with a 32- or 64-bit file based on + * what we have read... + *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf32_static_linked f1.elf32_file_program_header_table then + Elf_file.get_elf32_file_global_symbol_init f1 >>= (fun init1 -> + Elf_file.get_elf32_executable_image f1 >>= (fun img2 -> + return ((ELF_File_32 f1), (ELF_Class_32 img2), init1))) + else + fail "populate_and_obtain_global_symbol_init_info': not a statically linked executable") + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + if Elf_program_header_table.get_elf64_static_linked f1.elf64_file_program_header_table then + Elf_file.get_elf64_file_global_symbol_init f1 >>= (fun init1 -> + Elf_file.get_elf64_executable_image f1 >>= (fun img2 -> + return ((ELF_File_64 f1), (ELF_Class_64 img2), init1))) + else + fail "populate_and_obtain_global_symbol_init_info': not a statically linked executable") + else + fail "populate_and_obtain_global_symbol_init_info': ELF class unrecognised" + ))) diff --git a/lib/ocaml_rts/linksem/archive.ml b/lib/ocaml_rts/linksem/archive.ml new file mode 100644 index 00000000..cd4480b4 --- /dev/null +++ b/lib/ocaml_rts/linksem/archive.ml @@ -0,0 +1,150 @@ +(*Generated by Lem from archive.lem.*) +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Lem_string +open Show +open Lem_assert_extra + +open Missing_pervasives +open Byte_sequence +open Error + +type archive_entry_header = + { name : string + ; timestamp : Nat_big_num.num + ; uid : int + ; gid : int + ; mode : int + ; size : int (* 1GB should be enough *) + } + +type archive_global_header = char + list + +(*val string_of_byte_sequence : byte_sequence -> string*) +let string_of_byte_sequence0 seq:string= + ((match seq with + | Sequence bs -> Xstring.implode (Lem_list.map (fun x-> x) bs) + )) + +(*val read_archive_entry_header : natural -> byte_sequence -> error (archive_entry_header * natural * byte_sequence)*) +let read_archive_entry_header seq_length seq:(archive_entry_header*Nat_big_num.num*byte_sequence)error= + (let magic_bytes = ([Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 96)) (* 0x60 *); Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 10)) (* 0x0a *)]) in + let header_length =(Nat_big_num.of_int 60) in + (* let _ = Missing_pervasives.errs ("Archive entry header? " ^ (show (take 16 bs)) ^ "? ") in *) + partition_with_length header_length seq_length seq >>= (fun (header, rest) -> + offset_and_cut(Nat_big_num.of_int 58)(Nat_big_num.of_int 2) header >>= (fun magic -> + offset_and_cut(Nat_big_num.of_int 0)(Nat_big_num.of_int 16) header >>= (fun name1 -> + offset_and_cut(Nat_big_num.of_int 16)(Nat_big_num.of_int 12) header >>= (fun timestamp_str -> + offset_and_cut(Nat_big_num.of_int 28)(Nat_big_num.of_int 6) header >>= (fun uid_str -> + offset_and_cut(Nat_big_num.of_int 34)(Nat_big_num.of_int 6) header >>= (fun gid_str -> + offset_and_cut(Nat_big_num.of_int 40)(Nat_big_num.of_int 8) header >>= (fun mode_str -> + offset_and_cut(Nat_big_num.of_int 48)(Nat_big_num.of_int 10) header >>= (fun size_str -> + let size2 = (natural_of_decimal_string (string_of_byte_sequence0 size_str)) in + (* let _ = Missing_pervasives.errln (": yes, size " ^ (show size)) in *) + return ({ name = (string_of_byte_sequence0 name1); timestamp = ((Nat_big_num.of_int 0 : Nat_big_num.num)) (* FIXME *); + uid =( 0) (* FIXME *) ; gid =( 0) (* FIXME *) ; mode =( 0) (* FIXME *); + size = (Nat_big_num.to_int size2) (* FIXME *) }, Nat_big_num.sub_nat seq_length header_length, rest)))))))))) + +(*val read_archive_global_header : byte_sequence -> error (archive_global_header * byte_sequence)*) +let read_archive_global_header seq:((char)list*byte_sequence)error= + ((match seq with + | Sequence bs -> + (* let _ = Missing_pervasives.errs ("Archive? " ^ (show (take 16 bs)) ^ "? ") + in*) + let chars = (Lem_list.map (fun x-> x) (take0(Nat_big_num.of_int 8) bs)) in + if Xstring.implode chars = "!<arch>\n" then + (* let _ = Missing_pervasives.errln ": yes" in *) + return (chars, Sequence(drop0(Nat_big_num.of_int 8) bs)) + else + (* let _ = Missing_pervasives.errln ": no" in *) + fail "read_archive_global_header: not an archive" + )) + +(*val accum_archive_contents : (list (string * byte_sequence)) -> maybe string -> natural -> byte_sequence -> error (list (string * byte_sequence))*) +let rec accum_archive_contents accum extended_filenames whole_seq_length whole_seq:((string*byte_sequence)list)error= +( + (* let _ = Missing_pervasives.errs "Can read a header? " in *)if not (Nat_big_num.equal (Byte_sequence.length0 whole_seq) whole_seq_length) then +(assert false) (* invariant: whole_seq_length always equal to length of whole_seq, so the length is only + computed one. This "fail" needed for Isabelle termination proofs... *) + else + (match (read_archive_entry_header whole_seq_length whole_seq) with + | Fail _ -> return accum + | Success (hdr, (seq_length : Nat_big_num.num), seq) -> + (match seq with + | Sequence next_bs -> + (* let _ = Missing_pervasives.errln ("yes; next_bs has length " ^ (show (List.length next_bs))) in *) + let amount_to_drop = +(if (hdr.size mod 2) = 0 then + (Nat_big_num.of_int hdr.size) + else Nat_big_num.add + (Nat_big_num.of_int hdr.size)(Nat_big_num.of_int 1)) + in + if Nat_big_num.equal amount_to_drop(Nat_big_num.of_int 0) then + fail "accum_archive_contents: amount to drop from byte sequence is 0" + else + (*let _ = Missing_pervasives.errln ("amount_to_drop is " ^ (show amount_to_drop)) in*) + let chunk = (Sequence(Lem_list.take hdr.size next_bs)) + in + (*let _ = Missing_pervasives.errs ("Processing archive header named " ^ hdr.name) + in*) + let (new_accum, (new_extended_filenames : string option)) = +(let name1 = (Xstring.explode hdr.name) in + if (listEqualBy (=) name1 ['/'; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' '; ' ']) then + (* SystemV symbol lookup table; we skip this *) (accum, extended_filenames) + else + (match name1 with + | x::xs -> + if x = '/' then + (match xs with + | y::ys -> + if y = '/' then + (accum, Some (string_of_byte_sequence0 chunk)) + else + let index = (natural_of_decimal_string (Xstring.implode xs)) in + (match extended_filenames with + | None -> failwith "corrupt archive: reference to non-existent extended filenames" + | Some s -> + let table_suffix = ((match Ml_bindings.string_suffix index s with Some x -> x | None -> "" )) in + let index = ((match Ml_bindings.string_index_of '/' table_suffix with Some x -> x | None -> (Nat_big_num.of_int (String.length table_suffix)) )) in + let ext_name = ((match Ml_bindings.string_prefix index table_suffix with Some x -> x | None -> "" )) in + (*let _ = Missing_pervasives.errln ("Got ext_name " ^ ext_name) in*) + (((ext_name, chunk) :: accum), extended_filenames) + ) + | [] -> + let index = (natural_of_decimal_string (Xstring.implode xs)) in + (match extended_filenames with + | None -> failwith "corrupt archive: reference to non-existent extended filenames" + | Some s -> + let table_suffix = ((match Ml_bindings.string_suffix index s with Some x -> x | None -> "" )) in + let index = ((match Ml_bindings.string_index_of '/' table_suffix with Some x -> x | None -> (Nat_big_num.of_int (String.length table_suffix)) )) in + let ext_name = ((match Ml_bindings.string_prefix index table_suffix with Some x -> x | None -> "" )) in + (*let _ = Missing_pervasives.errln ("Got ext_name " ^ ext_name) in*) + (((ext_name, chunk) :: accum), extended_filenames) + ) + ) + else + (((hdr.name, chunk) :: accum), extended_filenames) + | [] -> (((hdr.name, chunk) :: accum), extended_filenames) + )) + in + (match (Byte_sequence.dropbytes amount_to_drop seq) with + | Fail _ -> return accum + | Success new_seq -> + accum_archive_contents new_accum new_extended_filenames ( Nat_big_num.sub_nat seq_length amount_to_drop) new_seq + ) + ) + )) + +(*val read_archive : byte_sequence -> error (list (string * byte_sequence))*) +let read_archive bs:((string*byte_sequence)list)error= + (read_archive_global_header bs >>= (fun (hdr, seq) -> + let result = (accum_archive_contents [] None (Byte_sequence.length0 seq) seq) in + (* let _ = Missing_pervasives.errln "Finished reading archive" in *) + (match result with + Success r -> Success (List.rev r) + | Fail x -> Fail x + ))) diff --git a/lib/ocaml_rts/linksem/byte_sequence.ml b/lib/ocaml_rts/linksem/byte_sequence.ml new file mode 100644 index 00000000..27eb6d81 --- /dev/null +++ b/lib/ocaml_rts/linksem/byte_sequence.ml @@ -0,0 +1,335 @@ +(*Generated by Lem from byte_sequence.lem.*) +(** [byte_sequence.lem], a list of bytes used for ELF I/O and other basic tasks + * in the ELF model. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_string +open Lem_assert_extra + +open Error +open Missing_pervasives +open Show + +(** A [byte_sequence], [bs], denotes a consecutive list of bytes. Can be read + * from or written to a binary file. Most basic type in the ELF formalisation. + *) +type byte_sequence = + Sequence of ( char list) + +(** [byte_list_of_byte_sequence bs] obtains the underlying list of bytes of the + * byte sequence [bs]. + *) +(*val byte_list_of_byte_sequence : byte_sequence -> list byte*) +let byte_list_of_byte_sequence bs0:(char)list= + ((match bs0 with + | Sequence xs -> xs + )) + +(** [compare_byte_sequence bs1 bs2] is an ordering comparison function for byte + * sequences, suitable for constructing sets, maps and other ordered types + * with. + *) +(*val compare_byte_sequence : byte_sequence -> byte_sequence -> ordering*) +let compare_byte_sequence s1 s2:int= +(lexicographic_compare compare_byte (byte_list_of_byte_sequence s1) (byte_list_of_byte_sequence s2)) + +let instance_Basic_classes_Ord_Byte_sequence_byte_sequence_dict:(byte_sequence)ord_class= ({ + + compare_method = compare_byte_sequence; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_byte_sequence f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> let result = (compare_byte_sequence f1 f2) in Lem.orderingEqual result (-1) || Lem.orderingEqual result 0)); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_byte_sequence f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> let result = (compare_byte_sequence f1 f2) in Lem.orderingEqual result 1 || Lem.orderingEqual result 0))}) + +(** [acquire_byte_list fname] exhaustively reads in a list of bytes from a file + * pointed to by filename [fname]. Fails if the file does not exist, or if the + * transcription otherwise fails. Implemented as a primitive in OCaml. + *) +(*val acquire_byte_list : string -> error (list byte)*) + +(** [acquire fname] exhaustively reads in a byte_sequence from a file pointed to + * by filename [fname]. Fails if the file does not exist, or if the transcription + * otherwise fails. + *) +(*val acquire : string -> error byte_sequence*) +let acquire fname1:(byte_sequence)error= + (Byte_sequence_wrapper.acquire_char_list fname1 >>= (fun bs -> + return (Sequence bs))) + +(** [serialise_byte_list fname bs] writes a list of bytes, [bs], to a binary file + * pointed to by filename [fname]. Fails if the transcription fails. Implemented + * as a primitive in OCaml. + *) +(*val serialise_byte_list : string -> list byte -> error unit*) + +(** [serialise fname bs0] writes a byte sequence, [bs0], to a binary file pointed + * to by filename [fname]. Fails if the transcription fails. + *) +(*val serialise : string -> byte_sequence -> error unit*) +let serialise fname1 ss:(unit)error= + ((match ss with + | Sequence ts -> Byte_sequence_wrapper.serialise_char_list fname1 ts + )) + +(** [empty], the empty byte sequence. + *) +(*val empty : byte_sequence*) +let empty:byte_sequence= (Sequence []) + +(** [read_char bs0] reads a single byte from byte sequence [bs0] and returns the + * remainder of the byte sequence. Fails if [bs0] is empty. + * TODO: rename to read_byte, probably. + *) +(*val read_char : byte_sequence -> error (byte * byte_sequence)*) +let read_char (Sequence ts):(char*byte_sequence)error= + ((match ts with + | [] -> fail "read_char: sequence is empty" + | x::xs -> return (x, Sequence xs) + )) + +(** [repeat cnt b] creates a list of length [cnt] containing only [b]. + * TODO: move into missing_pervasives.lem. + *) +(*val repeat' : natural -> byte -> list byte -> list byte*) +let rec repeat' count c acc:(char)list= + ( + if(Nat_big_num.equal count (Nat_big_num.of_int 0)) then acc else + (repeat' ( Nat_big_num.sub_nat count (Nat_big_num.of_int 1)) c (c :: acc))) + +(*val repeat : natural -> byte -> list byte*) +let repeat count c:(char)list= (repeat' count c []) + +(** [create cnt b] creates a byte sequence of length [cnt] containing only [b]. + *) +(*val create : natural -> byte -> byte_sequence*) +let create count c:byte_sequence= + (Sequence (repeat count c)) + +(** [zeros cnt] creates a byte sequence of length [cnt] containing only 0, the + * null byte. + *) +(*val zeros : natural -> byte_sequence*) +let zeros m:byte_sequence= + (create m '\000') + +(** [length bs0] returns the length of [bs0]. + *) +(*val length : byte_sequence -> natural*) +let length0 (Sequence ts):Nat_big_num.num= + (Nat_big_num.of_int (List.length ts)) + + +(** [concat bs] concatenates a list of byte sequences, [bs], into a single byte + * sequence, maintaining byte order across the sequences. + *) +(*val concat : list byte_sequence -> byte_sequence*) +let rec concat0 ts:byte_sequence= + ((match ts with + | [] -> Sequence [] + | ((Sequence x)::xs) -> + (match concat0 xs with + | Sequence tail -> Sequence ( List.rev_append (List.rev x) tail) + ) + )) + +(** [zero_pad_to_length len bs0] pads (on the right) consecutive zeros until the + * resulting byte sequence is [len] long. Returns [bs0] if [bs0] is already of + * greater length than [len]. + *) +(*val zero_pad_to_length : natural -> byte_sequence -> byte_sequence*) +let zero_pad_to_length len bs:byte_sequence= + (let curlen = (length0 bs) in + if Nat_big_num.greater_equal curlen len then + bs + else + concat0 [bs ; (zeros ( Nat_big_num.sub_nat len curlen))]) + +(** [from_byte_lists bs] concatenates a list of bytes [bs] and creates a byte + * sequence from their contents. Maintains byte order in [bs]. + *) +(*val from_byte_lists : list (list byte) -> byte_sequence*) +let from_byte_lists ts:byte_sequence= + (Sequence (List.concat ts)) + +(** [string_of_char_list cs] converts a list of characters into a string. + * Implemented as a primitive in OCaml. + *) +(*val string_of_char_list : list char -> string*) + +(** [char_list_of_byte_list bs] converts byte list [bs] into a list of characters. + * Implemented as a primitive in OCaml and Isabelle. + * TODO: is this actually being used in the Isabelle backend? All string functions + * should be factored out by target-specific definitions. + *) +(*val char_list_of_byte_list : list byte -> list char*) + +(** [string_of_byte_sequence bs0] converts byte sequence [bs0] into a string + * representation. + *) +(*val string_of_byte_sequence : byte_sequence -> string*) +let string_of_byte_sequence (Sequence ts):string= + (let cs = ( ts) in + Xstring.implode cs) + +(** [equal bs0 bs1] checks whether two byte sequences, [bs0] and [bs1], are equal. + *) +(*val equal : byte_sequence -> byte_sequence -> bool*) +let rec equal left right:bool= + ((match (left, right) with + | (Sequence [], Sequence []) -> true + | (Sequence (x::xs), Sequence (y::ys)) -> +(x = y) && equal (Sequence xs) (Sequence ys) + | (_, _) -> false + )) + +(** [dropbytes cnt bs0] drops [cnt] bytes from byte sequence [bs0]. Fails if + * [cnt] is greater than the length of [bs0]. + *) +(*val dropbytes : natural -> byte_sequence -> error byte_sequence*) +let rec dropbytes count (Sequence ts):(byte_sequence)error= + (if Nat_big_num.equal count Nat_big_num.zero then + return (Sequence ts) + else + (match ts with + | [] -> fail "dropbytes: cannot drop more bytes than are contained in sequence" + | x::xs -> dropbytes ( Nat_big_num.sub_nat count(Nat_big_num.of_int 1)) (Sequence xs) + )) + +(*val takebytes_r_with_length: nat -> natural -> byte_sequence -> error byte_sequence*) +let rec takebytes_r_with_length count ts_length (Sequence ts):(byte_sequence)error= + (if Nat_big_num.greater_equal ts_length (Nat_big_num.of_int count) then + return (Sequence (list_take_with_accum count [] ts)) + else + fail "takebytes: cannot take more bytes than are contained in sequence") + +(*val takebytes : natural -> byte_sequence -> error byte_sequence*) +let takebytes count (Sequence ts):(byte_sequence)error= + (let result = (takebytes_r_with_length (Nat_big_num.to_int count) (Missing_pervasives.length ts) (Sequence ts)) in + result) + +(*val takebytes_with_length : natural -> natural -> byte_sequence -> error byte_sequence*) +let takebytes_with_length count ts_length (Sequence ts):(byte_sequence)error= +( + (* let _ = Missing_pervasives.errs ("Trying to take " ^ (show count) ^ " bytes from sequence of " ^ (show (List.length ts)) ^ "\n") in *)let result = (takebytes_r_with_length (Nat_big_num.to_int count) ts_length (Sequence ts)) in + (*let _ = Missing_pervasives.errs ("Succeeded\n") in *) + result) + +(** [read_2_bytes_le bs0] reads two bytes from [bs0], returning them in + * little-endian order, and returns the remainder of [bs0]. Fails if [bs0] has + * length less than 2. + *) +(*val read_2_bytes_le : byte_sequence -> error ((byte * byte) * byte_sequence)*) +let read_2_bytes_le bs0:((char*char)*byte_sequence)error= + (read_char bs0 >>= (fun (b0, bs1) -> + read_char bs1 >>= (fun (b1, bs2) -> + return ((b1, b0), bs2)))) + +(** [read_2_bytes_be bs0] reads two bytes from [bs0], returning them in + * big-endian order, and returns the remainder of [bs0]. Fails if [bs0] has + * length less than 2. + *) +(*val read_2_bytes_be : byte_sequence -> error ((byte * byte) * byte_sequence)*) +let read_2_bytes_be bs0:((char*char)*byte_sequence)error= + (read_char bs0 >>= (fun (b0, bs1) -> + read_char bs1 >>= (fun (b1, bs2) -> + return ((b0, b1), bs2)))) + +(** [read_4_bytes_le bs0] reads four bytes from [bs0], returning them in + * little-endian order, and returns the remainder of [bs0]. Fails if [bs0] has + * length less than 4. + *) +(*val read_4_bytes_le : byte_sequence -> error ((byte * byte * byte * byte) * byte_sequence)*) +let read_4_bytes_le bs0:((char*char*char*char)*byte_sequence)error= + (read_char bs0 >>= (fun (b0, bs1) -> + read_char bs1 >>= (fun (b1, bs2) -> + read_char bs2 >>= (fun (b2, bs3) -> + read_char bs3 >>= (fun (b3, bs4) -> + return ((b3, b2, b1, b0), bs4)))))) + +(** [read_4_bytes_be bs0] reads four bytes from [bs0], returning them in + * big-endian order, and returns the remainder of [bs0]. Fails if [bs0] has + * length less than 4. + *) +(*val read_4_bytes_be : byte_sequence -> error ((byte * byte * byte * byte) * byte_sequence)*) +let read_4_bytes_be bs0:((char*char*char*char)*byte_sequence)error= + (read_char bs0 >>= (fun (b0, bs1) -> + read_char bs1 >>= (fun (b1, bs2) -> + read_char bs2 >>= (fun (b2, bs3) -> + read_char bs3 >>= (fun (b3, bs4) -> + return ((b0, b1, b2, b3), bs4)))))) + +(** [read_8_bytes_le bs0] reads eight bytes from [bs0], returning them in + * little-endian order, and returns the remainder of [bs0]. Fails if [bs0] has + * length less than 8. + *) +(*val read_8_bytes_le : byte_sequence -> error ((byte * byte * byte * byte * byte * byte * byte * byte) * byte_sequence)*) +let read_8_bytes_le bs0:((char*char*char*char*char*char*char*char)*byte_sequence)error= + (read_char bs0 >>= (fun (b0, bs1) -> + read_char bs1 >>= (fun (b1, bs2) -> + read_char bs2 >>= (fun (b2, bs3) -> + read_char bs3 >>= (fun (b3, bs4) -> + read_char bs4 >>= (fun (b4, bs5) -> + read_char bs5 >>= (fun (b5, bs6) -> + read_char bs6 >>= (fun (b6, bs7) -> + read_char bs7 >>= (fun (b7, bs8) -> + return ((b7, b6, b5, b4, b3, b2, b1, b0), bs8)))))))))) + +(** [read_8_bytes_be bs0] reads eight bytes from [bs0], returning them in + * big-endian order, and returns the remainder of [bs0]. Fails if [bs0] has + * length less than 8. + *) +(*val read_8_bytes_be : byte_sequence -> error ((byte * byte * byte * byte * byte * byte * byte * byte) * byte_sequence)*) +let read_8_bytes_be bs0:((char*char*char*char*char*char*char*char)*byte_sequence)error= + (read_char bs0 >>= (fun (b0, bs1) -> + read_char bs1 >>= (fun (b1, bs2) -> + read_char bs2 >>= (fun (b2, bs3) -> + read_char bs3 >>= (fun (b3, bs4) -> + read_char bs4 >>= (fun (b4, bs5) -> + read_char bs5 >>= (fun (b5, bs6) -> + read_char bs6 >>= (fun (b6, bs7) -> + read_char bs7 >>= (fun (b7, bs8) -> + return ((b0, b1, b2, b3, b4, b5, b6, b7), bs8)))))))))) + +(** [partition pnt bs0] splits [bs0] into two parts at index [pnt]. Fails if + * [pnt] is greater than the length of [bs0]. + *) +(*val partition : natural -> byte_sequence -> error (byte_sequence * byte_sequence)*) +let partition0 idx1 bs0:(byte_sequence*byte_sequence)error= + (takebytes idx1 bs0 >>= (fun l -> + dropbytes idx1 bs0 >>= (fun r -> + return (l, r)))) + +(*val partition_with_length : natural -> natural -> byte_sequence -> error (byte_sequence * byte_sequence)*) +let partition_with_length idx1 bs0_length bs0:(byte_sequence*byte_sequence)error= + (takebytes_with_length idx1 bs0_length bs0 >>= (fun l -> + dropbytes idx1 bs0 >>= (fun r -> + return (l, r)))) + +(** [offset_and_cut off cut bs0] first cuts [off] bytes off [bs0], then cuts + * the resulting byte sequence to length [cut]. Fails if [off] is greater than + * the length of [bs0] and if [cut] is greater than the length of the intermediate + * byte sequence. + *) +(*val offset_and_cut : natural -> natural -> byte_sequence -> error byte_sequence*) +let offset_and_cut off cut bs0:(byte_sequence)error= + (dropbytes off bs0 >>= (fun bs1 -> + takebytes cut bs1 >>= (fun res -> + return res))) + +let instance_Show_Show_Byte_sequence_byte_sequence_dict:(byte_sequence)show_class= ({ + + show_method = string_of_byte_sequence}) + +let instance_Basic_classes_Eq_Byte_sequence_byte_sequence_dict:(byte_sequence)eq_class= ({ + + isEqual_method = equal; + + isInequal_method = (fun l r->not (equal l r))}) diff --git a/lib/ocaml_rts/linksem/byte_sequence_wrapper.ml b/lib/ocaml_rts/linksem/byte_sequence_wrapper.ml new file mode 100644 index 00000000..69efcc8d --- /dev/null +++ b/lib/ocaml_rts/linksem/byte_sequence_wrapper.ml @@ -0,0 +1,33 @@ +open Big_int + +open Error + +let acquire_char_list (fname : string) = + let char_list = ref [] in + try + let ic = open_in_bin fname in + while true do + let c = input_char ic in + let _ = char_list := c :: !char_list in + () + done; + let _ = close_in ic in + Fail "acquire_char_list: the impossible happened" + with End_of_file -> + Success (List.rev !char_list) +;; + +let serialise_char_list (fname : string) bytes = + let rec go oc bytes = + match bytes with + | [] -> () + | x::xs -> output_char oc x; go oc xs + in + try + let oc = open_out_bin fname in + let _ = go oc bytes in + let _ = close_out oc in + Success () + with _ -> + Fail "serialise_char_list: unable to open file for writing" +;;
\ No newline at end of file diff --git a/lib/ocaml_rts/linksem/command_line.ml b/lib/ocaml_rts/linksem/command_line.ml new file mode 100644 index 00000000..62d4b87e --- /dev/null +++ b/lib/ocaml_rts/linksem/command_line.ml @@ -0,0 +1,671 @@ +(*Generated by Lem from command_line.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_string_extra +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_list_extra +(*import Set*) +(*import Set_extra*) +open Lem_sorting +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show + +(* Here we try to model the command line of GNU ld.bfd. + * + * Some options are global modifiers affecting the link output. + * Others have effect only for some subset of input files. + * Typically some mutually-exclusive possibilities exist + * whereby each argument selects one such possibility for all subsequent input files, + * until a different argument selects another possibility for ensuring inputs. + *) + +type input_file_spec = Filename of string (* /path/to/file.{o,a,so,...} -- might be script! *) + | Libname of string (* -llib *) + +(*val string_of_input_file_spec : input_file_spec -> string*) +let string_of_input_file_spec spec:string= + ((match spec with + Filename(s) -> "file `" ^ (s ^ "'") + | Libname(s) -> "library `" ^ (s ^ "'") + )) + +let instance_Show_Show_Command_line_input_file_spec_dict:(input_file_spec)show_class= ({ + + show_method = string_of_input_file_spec}) + +type input_file_options = { input_fmt : string + ; input_libpath : string list + ; input_link_sharedlibs : bool (* -Bstatic *) + ; input_check_sections : bool + ; input_copy_dt_needed : bool + ; input_whole_archive : bool + ; input_as_needed : bool + } + +(*val null_input_file_options : input_file_options*) +let null_input_file_options:input_file_options= + ({ input_fmt = "" + ; input_libpath = ([]) + ; input_link_sharedlibs = false + ; input_check_sections = false + ; input_copy_dt_needed = false + ; input_whole_archive = false + ; input_as_needed = false + }) + +type output_kind = Executable + | SharedLibrary + +type link_option = OutputFilename of string + | OutputKind of output_kind + | ForceCommonDefined of bool (* -d, -dc, -dp *) + | Soname of string (* -soname *) + | EntryAddress of Nat_big_num.num + | TextSegmentStart of Nat_big_num.num + | RodataSegmentStart of Nat_big_num.num + | LdataSegmentStart of Nat_big_num.num + | BindFunctionsEarly (* -Bsymbolic-functions *) + | BindNonFunctionsEarly (* the remainder of -Bsymbolic *) + (* more here! *) + +(*val tagEqual : link_option -> link_option -> bool*) +let tagEqual opt1 opt2:bool= ((match (opt1, opt2) with + (* FIXME: Lem BUG here! says "duplicate binding" *) + (OutputFilename(_), OutputFilename(_)) -> true + | (OutputKind(_), OutputKind(_)) -> true + (* | (ForceCommonDefined, ForceCommonDefined) -> true *) + | (Soname(_), Soname(_)) -> true + (* | (EntryAddress, EntryAddress) -> true *) + | (TextSegmentStart(_), TextSegmentStart(_)) -> true + | (RodataSegmentStart(_), RodataSegmentStart(_)) -> true + | (LdataSegmentStart(_), LdataSegmentStart(_)) -> true + (* | (BindFunctionsEarly, BindFunctionsEarly) -> true *) + (* | (BindNonFunctionsEarly, BindNonFunctionsEarly) -> true *) + | _ -> false +)) + +(* To allow filtering out a previous setting for a given option, we define + * an equality relation that is true if options are of the same constructor. + * Seems like a bit of a HACK. *) +let instance_Basic_classes_Eq_Command_line_link_option_dict:(link_option)eq_class= ({ + + isEqual_method = (fun opt1 -> + (fun opt2 -> + (match (opt1, opt2) with + | (OutputFilename(_), OutputFilename(_)) -> true + | (ForceCommonDefined(_), ForceCommonDefined(_)) -> true + | (Soname(_), Soname(_)) -> true + | (EntryAddress(_), EntryAddress(_)) -> true + | _ -> false + ) + )); + + isInequal_method = (fun opt1 -> (fun opt2 -> not ( ((fun opt1 -> + (fun opt2 -> + (match (opt1, opt2) with + | (OutputFilename(_), OutputFilename(_)) -> true + | (ForceCommonDefined(_), ForceCommonDefined(_)) -> true + | (Soname(_), Soname(_)) -> true + | (EntryAddress(_), EntryAddress(_)) -> true + | _ -> false + ) + ))opt1 opt2))))}) + +type input_file_and_options = input_file_spec * input_file_options +type input_unit = File of input_file_and_options + | Group of (input_file_and_options) list (* NOT recursive *) + | BuiltinControlScript (* for uniformity when processing script defs *) + +(*val string_of_input_unit : input_unit -> string*) +let string_of_input_unit u:string= + ((match u with + File(spec, opts) -> + "single " ^ (string_of_input_file_spec spec) + | Group(spec_opt_list) -> + "group: [" ^ ((string_of_list + instance_Show_Show_Command_line_input_file_spec_dict (Lem_list.map (fun (spec, opts) -> spec) spec_opt_list)) ^ "]") + | BuiltinControlScript -> "(built-in control script)" + )) + +let instance_Show_Show_Command_line_input_unit_dict:(input_unit)show_class= ({ + + show_method = string_of_input_unit}) + +(* Reading the command-line: + * we encode the meaning of a linker command token + * using a reader function interpreting a list of argument definitions. + * Lookahead is necessary: sometimes the interpretation of an option + * depends on the next argument (e.g. whether it's a file, directory or another option). + * The list of argument definitions is from lists of strings to constructor function invocations. + * We use lists of strings since many options have synonyms. + * The strings are interpreted as regular expressions and any matched groups are collected together + * as a second argument list; this is because some arguments are of the form --blah=NUM or similar. *) + +(* As we read the command line, we keep a current state which is the collection + * of seen input files, seen whole-link options, and input file options that will + * apply to any input files we add subsequently. *) +type command_state = { input_units : input_unit list + ; link_options : link_option Pset.set + ; current_input_options : input_file_options + ; current_group : ( input_file_and_options list)option + } + +(* This is the "default state" when we start reading input options *) +(*val initial_state : list command_state*) (* the stack *) +let initial_state0:(command_state)list= ([{ input_units = ([]) + ; link_options =(Pset.from_list compare [OutputFilename("a.out"); OutputKind(Executable)]) + ; current_input_options = ({ input_fmt = "elf64-x86-64" (* FIXME *) + ; input_libpath = (["/usr/lib"]) (* FIXME: this probably isn't the right place to supply the default search path *) + ; input_link_sharedlibs = true + ; input_check_sections = true + ; input_copy_dt_needed = false + ; input_whole_archive = false + ; input_as_needed = true (* FIXME *) + }) + ; current_group = None + }]) + +type interpreted_command_line = input_unit list * link_option Pset.set + +(*val add_input_file : list command_state -> string -> list command_state*) +let add_input_file (state1 :: more) s:(command_state)list= + (let chars = (Xstring.explode s) + in + let spec = ((match chars with + '-' :: 'l' :: more -> Libname(Xstring.implode more) + | '-' :: more -> failwith ("not a valid option or input file: " ^ s) + | _ -> Filename(s) + )) + in + if (Lem.option_equal (listEqualBy (Lem.pair_equal (=) (=))) state1.current_group None) + then + { input_units = (List.rev_append (List.rev state1.input_units) [File(spec, state1.current_input_options)]) + ; link_options = (state1.link_options) + ; current_input_options = (state1.current_input_options) + ; current_group = (state1.current_group) + } :: more + else + { input_units = (state1.input_units) + ; link_options = (state1.link_options) + ; current_input_options = (state1.current_input_options) + ; current_group = (let toAppend = ([(spec, state1.current_input_options)]) in + (match state1.current_group with Some l -> Some( List.rev_append (List.rev l) toAppend) | None -> Some(toAppend) + )) + } :: more) + +(*val start_group : list command_state -> list command_state*) +let start_group (state1 :: more):(command_state)list= ({ + input_units = (state1.input_units) + ; link_options = (state1.link_options) + ; current_input_options = (state1.current_input_options) + ; current_group = ((match state1.current_group with + None -> Some [] + | _ -> failwith "cannot nest groups" + )) + } :: more) + +(*val end_group : list command_state -> list command_state*) +let end_group (state1 :: more):(command_state)list= ({ + input_units = (List.rev_append (List.rev state1.input_units) ((match state1.current_group with + Some l -> [Group(l)] + | None -> failwith "end group without start group" + ))) + ; link_options = (state1.link_options) + ; current_input_options = (state1.current_input_options) + ; current_group = None + } :: more) + +type option_token = string +type option_argspecs = string list * string list +type option_argvals = string list * string list + +(*val set_or_replace_option : link_option -> list command_state -> list command_state*) +let set_or_replace_option opt state_list:(command_state)list= + ((match state_list with + [] -> failwith "error: no state" + | state1 :: more -> + { input_units = (state1.input_units) + ; link_options = (Pset.add opt (Pset.filter (fun existing -> ((fun opt1 -> (fun opt2 -> not ( ((fun opt1 -> + (fun opt2 -> + (match (opt1, opt2) with + | (OutputFilename(_), OutputFilename(_)) -> true + | (ForceCommonDefined(_), ForceCommonDefined(_)) -> true + | (Soname(_), Soname(_)) -> true + | (EntryAddress(_), EntryAddress(_)) -> true + | _ -> false + ) + ))opt1 opt2)))) existing opt)) state1.link_options)) + ; current_input_options = (state1.current_input_options) + ; current_group = (state1.current_group) + } :: more + )) + +(*val find_option_matching_tag : link_option -> set link_option -> maybe link_option*) +let rec find_option_matching_tag tag options:(link_option)option= + (Lem_list.list_find_opt (tagEqual tag) (Pset.elements options)) + +(*val extract_hex_addend : char -> maybe natural*) +let extract_hex_addend x:(Nat_big_num.num)option= + (if x = '0' then + Some(Nat_big_num.of_int 0) + else if x = '1' then + Some(Nat_big_num.of_int 1) + else if x = '2' then + Some(Nat_big_num.of_int 2) + else if x = '3' then + Some(Nat_big_num.of_int 3) + else if x = '4' then + Some(Nat_big_num.of_int 4) + else if x = '5' then + Some(Nat_big_num.of_int 5) + else if x = '6' then + Some(Nat_big_num.of_int 6) + else if x = '7' then + Some(Nat_big_num.of_int 7) + else if x = '8' then + Some(Nat_big_num.of_int 8) + else if x = '9' then + Some(Nat_big_num.of_int 9) + else if x = 'a' then + Some(Nat_big_num.of_int 10) + else if x = 'b' then + Some(Nat_big_num.of_int 11) + else if x = 'c' then + Some(Nat_big_num.of_int 12) + else if x = 'd' then + Some(Nat_big_num.of_int 13) + else if x = 'e' then + Some(Nat_big_num.of_int 14) + else if x = 'f' then + Some(Nat_big_num.of_int 15) + else + None) + +(*val accumulate_hex_chars : natural -> list char -> natural*) +let rec accumulate_hex_chars acc chars:Nat_big_num.num= + ((match chars with + | [] -> acc + | x::xs -> + (match extract_hex_addend x with + | None -> acc + | Some addend -> + accumulate_hex_chars ( Nat_big_num.add (Nat_big_num.mul acc(Nat_big_num.of_int 16)) addend) xs + ) + )) + +(*val extract_dec_addend : char -> maybe natural*) +let extract_dec_addend x:(Nat_big_num.num)option= + (if x = '0' then + Some(Nat_big_num.of_int 0) + else if x = '1' then + Some(Nat_big_num.of_int 1) + else if x = '2' then + Some(Nat_big_num.of_int 2) + else if x = '3' then + Some(Nat_big_num.of_int 3) + else if x = '4' then + Some(Nat_big_num.of_int 4) + else if x = '5' then + Some(Nat_big_num.of_int 5) + else if x = '6' then + Some(Nat_big_num.of_int 6) + else if x = '7' then + Some(Nat_big_num.of_int 7) + else if x = '8' then + Some(Nat_big_num.of_int 8) + else if x = '9' then + Some(Nat_big_num.of_int 9) + else + None) + +(*val accumulate_dec_chars : natural -> list char -> natural*) +let rec accumulate_dec_chars acc chars:Nat_big_num.num= + ((match chars with + | [] -> acc + | x::xs -> + (match extract_dec_addend x with + | None -> acc + | Some addend -> + accumulate_hex_chars ( Nat_big_num.add (Nat_big_num.mul acc(Nat_big_num.of_int 16)) addend) xs + ) + )) + +(*val parse_address : string -> natural*) +let parse_address s:Nat_big_num.num= ((match Xstring.explode s with + '0' :: 'x' :: more -> accumulate_hex_chars(Nat_big_num.of_int 0) more + | chars -> accumulate_dec_chars(Nat_big_num.of_int 0) chars +)) + +type option_def = ( option_token list) * option_argspecs * (option_argvals -> command_state list -> command_state list) * string + +(* the table is a list of: ... options and their arg names ... and the option's meaning as a function... and a help string *) +(*val command_line_table : list option_def*) +let command_line_table:((string)list*((string)list*(string)list)*((string)list*(string)list ->(command_state)list ->(command_state)list)*string)list= ([ + (* per-input options *) + (["-b"; "--format"], (["TARGET"], []), (fun args -> (fun state1 -> state1)), "Specify target for following input files"); + (["-L"; "--library-path"], (["DIRECTORY"], []), (fun args -> (fun state1 -> state1)), "Add DIRECTORY to library search path"); + (["--as-needed"], ([], []), (fun _ -> (fun state1 -> state1)), "Only set DT_NEEDED for following dynamic libs if used"); + (["--no-as-needed"], ([], []), (fun _ -> (fun state1 -> state1)), "Always set DT_NEEDED for dynamic libraries mentioned on the command line"); + (["-Bdynamic"; "-dy"; "-call_shared"], ([], []), (fun _ -> (fun state1 -> state1)), "Link against shared libraries"); + (["-Bstatic"; "-dn"; "-non_shared"; "-static"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not link against shared libraries"); + (["--check-sections"], ([], []), (fun _ -> (fun state1 -> state1)), "Check section addresses for overlaps (default) **srk** not sure it's per-input!"); + (["--no-check-sections"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not check section addresses for overlaps **srk** not sure it's per-input!"); + (["--copy-dt-needed-entries"], ([], []), (fun _ -> (fun state1 -> state1)), "Copy DT_NEEDED links mentioned inside DSOs that follow"); + (["--no-copy-dt-needed-entries"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not copy DT_NEEDED links mentioned inside DSOs that follow"); + (["--no-whole-archive"], ([], []), (fun _ -> (fun state1 -> state1)), "Turn off --whole-archive"); + (["-rpath-link"], (["PATH"], []), (fun _ -> (fun state1 -> state1)), "Set link time shared library search path **srk** not sure it's per-input!"); + (["--whole-archive"], ([], []), (fun _ -> (fun state1 -> state1)), "Include all objects from following archives"); + (* linker plugin control *) + (["-plugin"], (["PLUGIN"], []), (fun _ -> (fun state1 -> state1)), "Load named plugin"); + (["-plugin-opt"], (["ARG"], []), (fun _ -> (fun state1 -> state1)), "Send arg to last-loaded plugin"); + (* output / whole-job options (some may be repeated with different args, but most not): *) + (["-A"; "--architecture"], (["ARCH"], []), (fun _ -> (fun state1 -> state1)), "Set architecture"); + (["-EB"], ([], []), (fun _ -> (fun state1 -> state1)), "Link big-endian objects"); + (["-EL"], ([], []), (fun _ -> (fun state1 -> state1)), "Link little-endian objects"); + (["-R"; "--just-symbols"], (["DIR"], []), (fun _ -> (fun state1 -> state1)), "**srk** (if directory, same as --rpath)"); + (["-d"; "-dc"; "-dp"], ([], []), (fun _ -> (fun state1 -> state1)), "Force common symbols to be defined"); + (["-e"; "--entry"], (["ADDRESS"], []), (fun _ -> (fun state1 -> state1)), "Set start address"); + (["-E"; "--export-dynamic"], ([], []), (fun _ -> (fun state1 -> state1)), "Export all dynamic symbols"); + (["--no-export-dynamic"], ([], []), (fun _ -> (fun state1 -> state1)), "Undo the effect of --export-dynamic"); + (["-f"; "--auxiliary"], (["SHLIB"], []), (fun _ -> (fun state1 -> state1)), "Auxiliary filter for shared object symbol table"); + (["-F"; "--filter"], (["SHLIB"], []), (fun _ -> (fun state1 -> state1)), "Filter for shared object symbol table"); + (["-G"; "--gpsize"], (["SIZE"], []), (fun _ -> (fun state1 -> state1)), "Small data size (if no size, same as --shared) **srk NOTE this quirk!**"); + (["-h"; "-soname"], (["FILENAME"], []), (fun _ -> (fun state1 -> state1)), "Set internal name of shared library"); + (["-I"; "--dynamic-linker"], (["PROGRAM"], []), (fun _ -> (fun state1 -> state1)), "Set PROGRAM as the dynamic linker to use"); + (["--sysroot="], ([], ["DIRECTORY"]), (fun _ -> (fun state1 -> state1)), "Override the default sysroot location"); + (["-m"], (["EMULATION"], []), (fun _ -> (fun state1 -> state1)), "Set emulation"); + (["-n"; "--nmagic"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not page align data"); + (["-N"; "--omagic"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not page align data, do not make text readonly"); + (["--no-omagic"], ([], []), (fun _ -> (fun state1 -> state1)), "Page align data, make text readonly"); + (["-o"; "--output"], (["FILE"], []), (fun argvals -> set_or_replace_option (OutputFilename(List.hd (fst argvals)))), "Set output file name"); + (["-O"], ([], []), (fun _ -> (fun state1 -> state1)), "Optimise output file"); + (["-q"; "--emit-relocs"], ([], []), (fun _ -> (fun state1 -> state1)), "Generate relocations in final output"); + (["-r"; "-i"; "--relocatable"], ([], []), (fun _ -> (fun state1 -> state1)), "Generate relocatable output"); + (["-s"; "--strip-all"], ([], []), (fun _ -> (fun state1 -> state1)), "Strip all symbols"); + (["-S"; "--strip-debug"], ([], []), (fun _ -> (fun state1 -> state1)), "Strip debugging symbols"); + (["--strip-discarded"], ([], []), (fun _ -> (fun state1 -> state1)), "Strip symbols in discarded sections"); + (["--no-strip-discarded"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not strip symbols in discarded sections"); + (["--default-script"; "-dT"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Read default linker script"); + (["--unique="], ([], ["SECTION"]), (fun _ -> (fun state1 -> state1)), "Don't merge input [SECTION | orphan] sections"); + (["-Ur"], ([], []), (fun _ -> (fun state1 -> state1)), "Build global constructor/destructor tables ( **srk**: like -r, but... )"); + (["-x"; "--discard-all"], ([], []), (fun _ -> (fun state1 -> state1)), "Discard all local symbols"); + (["-X"; "--discard-locals"], ([], []), (fun _ -> (fun state1 -> state1)), "Discard temporary local symbols (default)"); + (["--discard-none"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't discard any local symbols"); + (["-Bsymbolic"], ([], []), (fun argvals -> (fun state1 -> set_or_replace_option BindFunctionsEarly (set_or_replace_option BindNonFunctionsEarly state1))), "Bind global references locally"); + (["-Bsymbolic-functions"], ([], []), (fun argvals -> set_or_replace_option (BindFunctionsEarly)), "Bind global function references locally"); + (["--force-exe-suffix"], ([], []), (fun _ -> (fun state1 -> state1)), "Force generation of file with .exe suffix"); + (["--gc-sections"], ([], []), (fun _ -> (fun state1 -> state1)), "**srk: uncertain: can repeat?** Remove unused sections (on some targets)"); + (["--no-gc-sections"], ([], []), (fun _ -> (fun state1 -> state1)), "**srk: uncertain: can repeat?** Don't remove unused sections (default)"); + (["--hash-size="], ([], ["NUMBER"]), (fun _ -> (fun state1 -> state1)), "Set default hash table size close to <NUMBER>"); + (["--no-define-common"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not define Common storage"); + (["--no-undefined"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not allow unresolved references in object files"); + (["--allow-shlib-undefined"], ([], []), (fun _ -> (fun state1 -> state1)), "Allow unresolved references in shared libraries"); + (["--no-allow-shlib-undefined"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not allow unresolved references in shared libs"); + (["--default-symver"], ([], []), (fun _ -> (fun state1 -> state1)), "Create default symbol version"); + (["--default-imported-symver"], ([], []), (fun _ -> (fun state1 -> state1)), "Create default symbol version for imported symbols"); + (["-nostdlib"], ([], []), (fun _ -> (fun state1 -> state1)), "Only use library directories specified on the command line"); + (["--oformat"], (["TARGET"], []), (fun _ -> (fun state1 -> state1)), "Specify target of output file"); + (["--relax"], ([], []), (fun _ -> (fun state1 -> state1)), "Reduce code size by using target specific optimisations"); + (["--no-relax"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not use relaxation techniques to reduce code size"); + (["--retain-symbols-file"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Keep only symbols listed in FILE"); + (["-rpath"], (["PATH"], []), (fun _ -> (fun state1 -> state1)), "Set runtime shared library search path"); + (["-shared"; "-Bshareable"], ([], []), (fun argvals -> set_or_replace_option (OutputKind(SharedLibrary))), "Create a shared library"); + (["-pie"; "--pic-executable"], ([], []), (fun _ -> (fun state1 -> state1)), "Create a position independent executable"); + (["--sort-common="],(* (ascending|descending) *)([], ["order"]), (fun _ -> (fun state1 -> state1)), "Sort common symbols by alignment [in specified order]"); + (["--sort-section="],(* (name|alignment) *) ([], ["key"]), (fun _ -> (fun state1 -> state1)), "Sort sections by name or maximum alignment"); + (["--spare-dynamic-tags"], (["COUNT"], []), (fun _ -> (fun state1 -> state1)), "How many tags to reserve in .dynamic section"); + (["--split-by-file="], ([], ["SIZE"]), (fun _ -> (fun state1 -> state1)), "Split output sections every SIZE octets"); + (["--split-by-reloc="], ([], ["COUNT"]), (fun _ -> (fun state1 -> state1)), "Split output sections every COUNT relocs"); + (["--traditional-format"], ([], []), (fun _ -> (fun state1 -> state1)), "Use same format as native linker"); + (["--unresolved-symbols="], ([], ["method"]), (fun _ -> (fun state1 -> state1)), "How to handle unresolved symbols. <method> is: ignore-all, report-all, ignore-in-object-files, ignore-in-shared-libs"); + (["--dynamic-list-data"], ([], []), (fun _ -> (fun state1 -> state1)), "Add data symbols to dynamic list"); + (["--dynamic-list-cpp-new"], ([], []), (fun _ -> (fun state1 -> state1)), "Use C++ operator new/delete dynamic list"); + (["--dynamic-list-cpp-typeinfo "], ([], []), (fun _ -> (fun state1 -> state1)), "Use C++ typeinfo dynamic list"); + (["--dynamic-list"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Read dynamic list"); + (["--wrap"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Use wrapper functions for SYMBOL"); + (* the following are specific to ELF emulations *) + (["--audit=(.*)"], ([], ["AUDITLIB"]), (fun _ -> (fun state1 -> state1)), "Specify a library to use for auditing"); + (["-Bgroup"], ([], []), (fun _ -> (fun state1 -> state1)), "Selects group name lookup rules for DSO"); + (["--build-id="], ([], ["STYLE"]), (fun _ -> (fun state1 -> state1)), "Generate build ID note"); + (["-P"], (["AUDITLIB"], []), (fun _ -> (fun state1 -> state1)), "Specify a library to use for auditing dependencies"); + (["--depaudit="], ([], ["AUDITLIB"]), (fun _ -> (fun state1 -> state1)), "Specify a library to use for auditing dependencies"); + (["--disable-new-dtags"], ([], []), (fun _ -> (fun state1 -> state1)), "Disable new dynamic tags"); + (["--enable-new-dtags"], ([], []), (fun _ -> (fun state1 -> state1)), "Enable new dynamic tags"); + (["--eh-frame-hdr"], ([], []), (fun _ -> (fun state1 -> state1)), "Create .eh_frame_hdr section"); + (["--exclude-libs="], ([], ["LIBS"]), (fun _ -> (fun state1 -> state1)), "Make all symbols in LIBS hidden"); + (["--hash-style="], ([], ["STYLE"]), (fun _ -> (fun state1 -> state1)), "Set hash style to sysv, gnu or both"); + (* NOTE: for these to work, we hack our word-splitter to merge -z options into a single word with a single space in *) + (["-z combreloc"], ([], []), (fun _ -> (fun state1 -> state1)), "Merge dynamic relocs into one section and sort"); + (["-z common-page-size="], ([], ["SIZE"]), (fun _ -> (fun state1 -> state1)), "Set common page size to SIZE"); + (["-z defs"], ([], []), (fun _ -> (fun state1 -> state1)), "Report unresolved symbols in object files."); + (["-z execstack"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark executable as requiring executable stack"); + (["-z global"], ([], []), (fun _ -> (fun state1 -> state1)), "Make symbols in DSO available for subsequently loaded objects"); + (["-z initfirst"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark DSO to be initialized first at runtime"); + (["-z interpose"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark object to interpose all DSOs but executable"); + (["-z lazy"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark object lazy runtime binding (default)"); + (["-z loadfltr"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark object requiring immediate process"); + (["-z max-page-size="], ([], ["SIZE"]), (fun _ -> (fun state1 -> state1)), "Set maximum page size to SIZE"); + (["-z nocombreloc"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't merge dynamic relocs into one section"); + (["-z nocopyreloc"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't create copy relocs"); + (["-z nodefaultlib"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark object not to use default search paths"); + (["-z nodelete"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark DSO non-deletable at runtime"); + (["-z nodlopen"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark DSO not available to dlopen"); + (["-z nodump"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark DSO not available to dldump"); + (["-z noexecstack"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark executable as not requiring executable stack"); + (["-z norelro"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't create RELRO program header"); + (["-z now"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark object non-lazy runtime binding"); + (["-z origin"], ([], []), (fun _ -> (fun state1 -> state1)), "Mark object requiring immediate $ORIGIN processing at runtime"); + (["-z relro"], ([], []), (fun _ -> (fun state1 -> state1)), "Create RELRO program header"); + (["-z stacksize="], ([], ["SIZE"]), (fun _ -> (fun state1 -> state1)), "Set size of stack segment"); + (["-z bndplt"], ([], []), (fun _ -> (fun state1 -> state1)), "Always generate BND prefix in PLT entries"); + (["--ld-generated-unwind-info"], ([], []), (fun _ -> (fun state1 -> state1)), "Generate exception handling info for PLT."); + (["--no-ld-generated-unwind-info"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't do so."); + (* quasi-input options (can be repeated): *) + (["-c"; "--mri-script"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Read MRI format linker script"); + (["-l"; "--library"], (["LIBNAME"], []), (fun _ -> (fun state1 -> state1)), "Search for library LIBNAME"); + (* (["-R" ,"--just-symbols"], (["FILE"], []), fun _ -> (fun state -> state), "Just link symbols"), *) (* Handled above! *) + (["-T"; "--script"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Read linker script"); + (["-u"; "--undefined"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Start with undefined reference to SYMBOL"); + (["-("; "--start-group"], ([], []), (fun _ -> (fun state1 -> start_group state1)), "Start a group"); + (["-)"; "--end-group"], ([], []), (fun _ -> (fun state1 -> end_group state1)), "End a group"); + (["--defsym"], (["SYMBOL=EXPRESSION"], []), (fun _ -> (fun state1 -> state1)), "Define a symbol"); + (["-fini"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Call SYMBOL at unload-time"); + (["-init"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Call SYMBOL at load-time"); + (["--section-start"], (["SECTION=ADDRESS"], []), (fun _ -> (fun state1 -> state1)), "Set address of named section"); + (["-Tbss"], (["ADDRESS"], []), (fun _ -> (fun state1 -> state1)), "Set address of .bss section"); + (["-Tdata"], (["ADDRESS"], []), (fun _ -> (fun state1 -> state1)), "Set address of .data section"); + (["-Ttext"], (["ADDRESS"], []), (fun _ -> (fun state1 -> state1)), "Set address of .text section"); + (["-Ttext-segment"], (["ADDRESS"], []), (fun argvals -> set_or_replace_option (TextSegmentStart(parse_address (List.hd (fst argvals))))), "Set address of text segment"); + (["-Trodata-segment"], (["ADDRESS"], []), (fun argvals -> set_or_replace_option (RodataSegmentStart(parse_address (List.hd (fst argvals))))), "Set address of rodata segment"); + (["-Tldata-segment"], (["ADDRESS"], []), (fun argvals -> set_or_replace_option (LdataSegmentStart(parse_address (List.hd (fst argvals))))), "Set address of ldata segment"); + (["--version-script"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Read version information script"); + (["--version-exports-section"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Take export symbols list from .exports, using SYMBOL as the version."); + (* linker internal debugging/diagnostics and performance tuning *) + (["-M"; "--print-map"], ([], []), (fun _ -> (fun state1 -> state1)), "Print map file on standard output"); + (["-t"; "--trace"], ([], []), (fun _ -> (fun state1 -> state1)), "Trace file opens"); + (["-v"; "--version"], ([], []), (fun _ -> (fun state1 -> state1)), "Print version information"); + (["-V"], ([], []), (fun _ -> (fun state1 -> state1)), "Print version and emulation information"); + (["-y"; "--trace-symbol"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Trace mentions of SYMBOL"); + (["--cref"], ([], []), (fun _ -> (fun state1 -> state1)), "Output cross reference table"); + (["--demangle="], ([], ["STYLE"]), (fun _ -> (fun state1 -> state1)), "Demangle symbol names [using STYLE]"); + (["--print-gc-sections"], ([], []), (fun _ -> (fun state1 -> state1)), "List removed unused sections on stderr"); + (["--no-print-gc-sections"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not list removed unused sections"); + (["-Map"], (["FILE"], []), (fun _ -> (fun state1 -> state1)), "Write a map file"); + (["-Map="], ([], ["FILE"]), (fun _ -> (fun state1 -> state1)), "Write a map file"); + (["--help"], ([], []), (fun _ -> (fun state1 -> state1)), "Print option help"); + (["--no-keep-memory"], ([], []), (fun _ -> (fun state1 -> state1)), "Use less memory and more disk I/O"); + (["--no-demangle"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not demangle symbol names"); + (["--print-output-format"], ([], []), (fun _ -> (fun state1 -> state1)), "Print default output format"); + (["--print-sysroot"], ([], []), (fun _ -> (fun state1 -> state1)), "Print current sysroot"); + (["--reduce-memory-overheads"], ([], []), (fun _ -> (fun state1 -> state1)), "Reduce memory overheads, possibly taking much longer"); + (["--stats"], ([], []), (fun _ -> (fun state1 -> state1)), "Print memory usage statistics"); + (["--target-help"], ([], []), (fun _ -> (fun state1 -> state1)), "Display target specific options"); + (["--verbose="], ([], ["NUMBER"]), (fun _ -> (fun state1 -> state1)), "Output lots of information during link"); + (* unknown *) + (["--embedded-relocs"], ([], []), (fun _ -> (fun state1 -> state1)), "Generate embedded relocs"); + (["--task-link"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Do task level linking"); + (* compatibility *) + (["-a"], (["KEYWORD"], []), (fun _ -> (fun state1 -> state1)), "Shared library control for HP/UX compatibility"); + (["-Y"], (["PATH"], []), (fun _ -> (fun state1 -> state1)), "Default search path for Solaris compatibility"); + (* permissiveness controls (tightening/loosening) *) + (["--accept-unknown-input-arch"], ([], []), (fun _ -> (fun state1 -> state1)), "Accept input files whose architecture cannot be determined"); + (["--no-accept-unknown-input-arch"], ([], []), (fun _ -> (fun state1 -> state1)), "Reject input files whose architecture is unknown"); + (["--fatal-warnings"], ([], []), (fun _ -> (fun state1 -> state1)), "Treat warnings as errors"); + (["--no-fatal-warnings"], ([], []), (fun _ -> (fun state1 -> state1)), "Do not treat warnings as errors (default)"); + (["--allow-multiple-definition"], ([], []), (fun _ -> (fun state1 -> state1)), "Allow multiple definitions"); + (["--no-undefined-version"], ([], []), (fun _ -> (fun state1 -> state1)), "Disallow undefined version"); + (["--noinhibit-exec"], ([], []), (fun _ -> (fun state1 -> state1)), "Create an output file even if errors occur"); + (["--error-unresolved-symbols"], ([], []), (fun _ -> (fun state1 -> state1)), "Report unresolved symbols as errors"); + (["--ignore-unresolved-symbol"], (["SYMBOL"], []), (fun _ -> (fun state1 -> state1)), "Unresolved SYMBOL will not cause an error or warning"); + (* permissiveness, specific to ELF emulation *) + (["-z muldefs"], ([], []), (fun _ -> (fun state1 -> state1)), "Allow multiple definitions"); + (* warnings (enabling/disabling) *) + (["--no-warn-mismatch"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't warn about mismatched input files"); + (["--no-warn-search-mismatch"], ([], []), (fun _ -> (fun state1 -> state1)), "Don't warn on finding an incompatible library"); + (["--warn-common"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn about duplicate common symbols"); + (["--warn-constructors"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn if global constructors/destructors are seen"); + (["--warn-multiple-gp"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn if the multiple GP values are used"); + (["--warn-once"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn only once per undefined symbol"); + (["--warn-section-align"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn if start of section changes due to alignment"); + (["--warn-shared-textrel"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn if shared object has DT_TEXTREL"); + (["--warn-alternate-em"], ([], []), (fun _ -> (fun state1 -> state1)), "Warn if an object has alternate ELF machine code"); + (["--warn-unresolved-symbols"], ([], []), (fun _ -> (fun state1 -> state1)), "Report unresolved symbols as warnings"); + (* meta-options *) + (["--push-state"], ([], []), (fun _ -> (fun state1 -> state1)), "Push state of flags governing input file handling"); + (["--pop-state"], ([], []), (fun _ -> (fun state1 -> state1)), "Pop state of flags governing input file handling") +(*(["@FILE"], [], fun _ -> (fun state -> state), "Read options from FILE") *) (* processed during word-splitting phase *); +]) + +(*val delete_trailing_equals: string -> maybe string*) +let delete_trailing_equals str:(string)option= + (let cs = (Xstring.explode str) + in + if (listEqualBy (=) ['='] (drop0 ( Nat_big_num.sub_nat(length cs)(Nat_big_num.of_int 1)) cs)) + then Some (Xstring.implode ((take0 ( Nat_big_num.sub_nat(length cs)(Nat_big_num.of_int 1)) cs))) + else (* let _ = Missing_pervasives.errln ("No trailing equals: " ^ str) + in *) + None) + +(*val string_following_equals_at : nat -> string -> maybe string*) +let string_following_equals_at pos str:(string)option= + (let (first, second) = (Lem_list.split_at pos (Xstring.explode str)) + in (match second with + '=' :: rest -> Some (Xstring.implode rest) + | _ -> (* let _ = Missing_pervasives.errln ("No trailing equals at " ^ (show pos) ^ ": " ^ str) + in *) + None + )) + +(*val equal_modulo_trailing_equals : string -> string -> bool*) +let equal_modulo_trailing_equals argstr argdef:bool= +( + (* we allow argdef to have a trailing equals; if it does, + * we allow the argstring to have the equals (or not) and trailing stuff, + * which will become an arg *)let result = ((match (delete_trailing_equals argdef) with + Some matched -> + let following_equals = (string_following_equals_at (String.length matched) argstr) + in + (match following_equals with + Some following -> (* okay; does the pre-equals part match? *) + matched = Xstring.implode (Lem_list.take ( Nat_num.nat_monus(String.length argdef)( 1)) (Xstring.explode argstr)) + | _ -> (* the argstr is allowed not to have a trailing equals *) argstr = matched + ) + | None -> (* no trailing equals *) argdef = argstr + )) + in + (* let _ = Missing_pervasives.errln ("Do '" ^ argstr ^ "' and '" ^ argdef ^ "' match modulo trailing equals? " ^ (show result)) + in *) result) + + +(*val matching_arg_and_alias : string -> list option_def -> maybe (string * option_def)*) +let rec matching_arg_and_alias arg options:(string*((string)list*((string)list*(string)list)*(option_argvals ->(command_state)list ->(command_state)list)*string))option= ((match options with + [] -> None + | (aliases, argspec, meaning, doc) :: more_opts -> + (match list_find_opt (fun alias -> equal_modulo_trailing_equals arg alias) aliases with + Some found_alias -> Some (found_alias, (aliases, argspec, meaning, doc)) + | None -> matching_arg_and_alias arg more_opts + ) + )) + +(* We don't try to convert from strings to other things here; + * everything we record is either a bool, meaning option -A was "present", for some A, + * or a string somearg, meaning option -A somearg was present, for some A. *) + +(* The above suffices to understand each concrete argument. + * Now we define an "interpreted command line" that includes + * some useful structure. *) + +(*val read_one_arg : list command_state -> list string -> (list command_state * list string)*) +let read_one_arg state_stack args:(command_state)list*(string)list= +( + (* Get the first string and look it up in our table. *)(match args with + [] -> (state_stack, []) + | some_arg :: more -> (match (matching_arg_and_alias some_arg command_line_table) with + (* We need to handle argdefs that have trailing equals. This means + * an extra arg might follow the equals. We need some helper functions. *) + Some (alias, (aliases, (argspec_extras, argspec_regex), meaning, doc)) -> + (* Return a new state, by applying the argument's meaning. + * We have to supply the option's argument strings to the meaning function. *) + let argstrings = (Lem_list.take (List.length argspec_extras) more) + in + let regex_matches = ((match delete_trailing_equals some_arg with + Some prefix -> + (match (string_following_equals_at ( Nat_num.nat_monus(String.length alias)( 1)) some_arg) with + Some following_equals -> [following_equals] + | None -> failwith "impossible: '=' not where it was a moment ago" + ) + | None -> [] + )) + in + let new_state_stack = (meaning (argstrings, regex_matches) state_stack) + in + (new_state_stack, drop0 (length argspec_extras) more) + | None -> + (* If we didn't match any args, we ought to be an input file. *) + (add_input_file state_stack some_arg, more) + ) + )) + +(* To fold over the command-line arguments we need a fold that passes + * suffixes of the list, not individual elements, and gives us back + * the continuation that we need to fold over: a pair of folded-value, new-list. *) +(*val foldl_suffix : forall 'a 'b. ('a -> list 'b -> ('a * list 'b)) -> 'a -> list 'b -> 'a*) (* originally foldl *) +let rec foldl_suffix f a l:'a= ((match l with + | [] -> a + | x :: xs -> + let (new_a, new_list) = (f a l) + in foldl_suffix f new_a new_list +)) + +(* the word-splitting in argv needs a little fixing up. *) +(*val cook_argv : list string -> list string -> list string*) +let rec cook_argv acc args:(string)list= + ((match args with + [] -> acc + | "-z" :: more -> (match more with + [] -> failwith "-z must be followed by another argument" + | something :: yetmore -> cook_argv ( List.rev_append (List.rev acc) [("-z " ^ something)]) yetmore + ) + | something :: more -> cook_argv ( List.rev_append (List.rev acc) [something]) more + )) + +(*val command_line : unit -> interpreted_command_line*) +let command_line:unit ->(input_unit)list*(link_option)Pset.set= (fun _ -> ( + let cooked_argv = (cook_argv [] (List.tl Ml_bindings.argv_list)) + in + (* Now we use our fold-alike. *) + (match foldl_suffix read_one_arg initial_state0 cooked_argv with + state1 :: rest_of_stack -> (state1.input_units, state1.link_options) + | _ -> failwith "no command state left" + ) +)) diff --git a/lib/ocaml_rts/linksem/default_printing.ml b/lib/ocaml_rts/linksem/default_printing.ml new file mode 100644 index 00000000..4bce7684 --- /dev/null +++ b/lib/ocaml_rts/linksem/default_printing.ml @@ -0,0 +1,28 @@ +(*Generated by Lem from default_printing.lem.*) +(** [default_printing] module is a small utility module providing default + * printing functions for when ABI-specific functions are not available. + * These functions were constantly being redefined and reused all over the + * place hence their placement in this module. + *) +open Lem_function + +(** [default_os_specific_print] is a default print function for OS specific + * functionality. + *) +(*val default_os_specific_print : forall 'a. 'a -> string*) +let default_os_specific_print:'a ->string= + ((fun y->"*Default OS specific print*")) + +(** [default_proc_specific_print] is a default print function for processor specific + * functionality. + *) +(*val default_proc_specific_print : forall 'a. 'a -> string*) +let default_proc_specific_print:'a ->string= + ((fun y->"*Default processor specific print*")) + +(** [default_user_specific_print] is a default print function for user specific + * functionality. + *) +(*val default_user_specific_print : forall 'a. 'a -> string*) +let default_user_specific_print:'a ->string= + ((fun y->"*Default user specific print*")) diff --git a/lib/ocaml_rts/linksem/dwarf.ml b/lib/ocaml_rts/linksem/dwarf.ml new file mode 100644 index 00000000..9e5a31aa --- /dev/null +++ b/lib/ocaml_rts/linksem/dwarf.ml @@ -0,0 +1,4619 @@ +(*Generated by Lem from dwarf.lem.*) +open Lem_basic_classes +open Lem_bool +open Lem_function +open Lem_maybe +open Lem_num +open Lem_string + +open Lem_list (* TODO: check why this is not imported in ELF *) + +open Byte_sequence +open Error +open Hex_printing +open Missing_pervasives +open Show + +open Default_printing + +open Endianness +open String_table + +open Elf_dynamic +open Elf_file +open Elf_header +open Elf_program_header_table +open Elf_relocation +open Elf_section_header_table +open Elf_symbol_table +open 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*) + +let my_debug s:unit= () (*print_endline s*) +let my_debug2 s:unit= () (*print_endline s*) +let my_debug3 s:unit= () (*print_endline s*) +let my_debug4 s:unit= () (*print_endline s*) +let my_debug5 s:unit= (print_endline s) + + +(** ************************************************************ *) +(** ** 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 Nat_big_num.num + | OAV_integer of Nat_big_num.num + | OAV_block of Nat_big_num.num * char list + +type operation_stack = Nat_big_num.num list + +type arithmetic_context = + { + ac_bitwidth: Nat_big_num.num; + ac_half: Nat_big_num.num; (* 2 ^ (ac_bitwidth -1) *) + ac_all: Nat_big_num.num; (* 2 ^ ac_bitwidth *) + ac_max: Nat_big_num.num; (* (2 ^ ac_bitwidth) -1 *) (* also the representation of -1 *) +} + +type operation_semantics = + | OpSem_lit + | OpSem_deref + | OpSem_stack of (arithmetic_context -> operation_stack -> operation_argument_value list -> operation_stack option) + | OpSem_not_supported + | OpSem_binary of (arithmetic_context -> Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num option) + | OpSem_unary of (arithmetic_context -> Nat_big_num.num -> Nat_big_num.num option) + | OpSem_opcode_lit of Nat_big_num.num + | 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: Nat_big_num.num; + op_string: string; + op_argument_values: operation_argument_value list; + op_semantics: operation_semantics; + } + + +(* the result of a location expression evaluation is a single_location (or failure) *) + +type simple_location = + | SL_memory_address of Nat_big_num.num + | SL_register of Nat_big_num.num + | SL_implicit of char list (* used for implicit and stack values *) + | SL_empty + +type composite_location_piece = + | CLP_piece of Nat_big_num.num * simple_location + | CLP_bit_piece of Nat_big_num.num * Nat_big_num.num * simple_location + +type single_location = + | SL_simple of simple_location + | SL_composite of composite_location_piece list + +(* 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: composite_location_piece list; + } + +(* location expression evaluation can involve register and memory reads, via the following interface *) + +type 'a register_read_result = + | RRR_result of Nat_big_num.num + | RRR_not_currently_available + | RRR_bad_register_number + +type 'a memory_read_result = + | MRR_result of Nat_big_num.num + | MRR_not_currently_available + | MRR_bad_address + +type evaluation_context = + { + read_register: Nat_big_num.num -> Nat_big_num.num register_read_result; + read_memory: Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num memory_read_result; + } + + +(* dwarf sections *) + +type dwarf_format = + | Dwarf32 + | Dwarf64 + +(* .debug_abbrev section *) + +type abbreviation_declaration = + { + ad_abbreviation_code: Nat_big_num.num; + ad_tag: Nat_big_num.num; + ad_has_children: bool; + ad_attribute_specifications: (Nat_big_num.num * Nat_big_num.num) list; + } + +type abbreviations_table = abbreviation_declaration list + +(* .debug_info section *) + +type attribute_value = + | AV_addr of Nat_big_num.num + | AV_block of Nat_big_num.num * char list + | AV_constantN of Nat_big_num.num * char list + | AV_constant_SLEB128 of Nat_big_num.num + | AV_constant_ULEB128 of Nat_big_num.num + | AV_exprloc of Nat_big_num.num * char list + | AV_flag of bool + | AV_ref of Nat_big_num.num + | AV_ref_addr of Nat_big_num.num (* dwarf_format dependent *) + | AV_ref_sig8 of Nat_big_num.num + | AV_sec_offset of Nat_big_num.num + | AV_string of char list (* not including terminating null *) + | AV_strp of Nat_big_num.num (* dwarf_format dependent *) + +type die = + { + die_offset: Nat_big_num.num; + die_abbreviation_code: Nat_big_num.num; + die_abbreviation_declaration: abbreviation_declaration; + die_attribute_values: (Nat_big_num.num (*pos*) * attribute_value) list; + die_children: die list; + } + +type compilation_unit_header = + { + cuh_offset: Nat_big_num.num; + cuh_dwarf_format: dwarf_format; + cuh_unit_length: Nat_big_num.num; + cuh_version: Nat_big_num.num; + cuh_debug_abbrev_offset: Nat_big_num.num; + cuh_address_size: Nat_big_num.num; + } + +type compilation_unit = + { + cu_header: compilation_unit_header; + cu_abbreviations_table: abbreviations_table; + cu_die: die; + } + +type compilation_units = compilation_unit list + +(* .debug_type section *) + +type type_unit_header = + { + tuh_cuh: compilation_unit_header; + tuh_type_signature: Nat_big_num.num; + tuh_type_offset: Nat_big_num.num; + } + +type type_unit = + { + tu_header: type_unit_header; + tu_abbreviations_table: abbreviations_table; + tu_die: die; + } + +type type_units = type_unit list + +(* .debug_loc section *) + +type single_location_description = char list + +type location_list_entry = + { + lle_beginning_address_offset: Nat_big_num.num; + lle_ending_address_offset: Nat_big_num.num; + lle_single_location_description: single_location_description; + } + +type base_address_selection_entry = + { + base_address: Nat_big_num.num; + } + +type location_list_item = + | LLI_lle of location_list_entry + | LLI_base of base_address_selection_entry + +type location_list = Nat_big_num.num (*offset*) * location_list_item list + +type location_list_list = location_list list + +(* .debug_ranges section *) + +type range_list_entry = + { + rle_beginning_address_offset: Nat_big_num.num; + rle_ending_address_offset: Nat_big_num.num; + } + +type range_list_item = + | RLI_rle of range_list_entry + | RLI_base of base_address_selection_entry + +type range_list = Nat_big_num.num (*offset*) * range_list_item list + +type range_list_list = range_list list + +(* .debug_frame section: call frame instructions *) + +type cfa_address = Nat_big_num.num +type cfa_block = char list +type cfa_delta = Nat_big_num.num +type cfa_offset = Nat_big_num.num +type cfa_register = Nat_big_num.num +type cfa_sfoffset = Nat_big_num.num + +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_unknown of char + +(* .debug_frame section: top-level *) + +type cie = + { + cie_offset: Nat_big_num.num; + cie_length: Nat_big_num.num; + cie_id: Nat_big_num.num; + cie_version: Nat_big_num.num; + cie_augmentation: char list; (* not including terminating null *) + cie_address_size: Nat_big_num.num option; + cie_segment_size: Nat_big_num.num option; + cie_code_alignment_factor: Nat_big_num.num; + cie_data_alignment_factor: Nat_big_num.num; + cie_return_address_register: cfa_register; + cie_initial_instructions_bytes: char list; + cie_initial_instructions: call_frame_instruction list; + } + +type fde = + { + fde_offset: Nat_big_num.num; + fde_length: Nat_big_num.num; + fde_cie_pointer: Nat_big_num.num; + fde_initial_location_segment_selector: Nat_big_num.num option; + fde_initial_location_address: Nat_big_num.num; + fde_address_range: Nat_big_num.num; + fde_instructions_bytes: char list; + fde_instructions: call_frame_instruction list; + } + +type frame_info_element = + | FIE_cie of cie + | FIE_fde of fde + +type frame_info = frame_info_element list + + +(* evaluated cfa data *) + +type cfa_rule = + | CR_undefined + | CR_register of cfa_register * Nat_big_num.num + | 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 Nat_big_num.num (* 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 Nat_big_num.num (* 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 Nat_big_num.num (* 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 = (cfa_register * register_rule) list + +type cfa_table_row = + { + ctr_loc: Nat_big_num.num; + ctr_cfa: cfa_rule; + ctr_regs: register_rule_map; + } + +type cfa_state = + { + cs_current_row: cfa_table_row; + cs_previous_rows: cfa_table_row list; + cs_initial_instructions_row: cfa_table_row; + cs_row_stack: cfa_table_row list; + } + + +type evaluated_frame_info = (fde * cfa_table_row list) + list + + +(* 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 Nat_big_num.num + | LNAV_ULEB128 of Nat_big_num.num + | LNAV_SLEB128 of Nat_big_num.num + | LNAV_uint16 of Nat_big_num.num + | LNAV_string of char list (* not including terminating null *) + +type line_number_operation = + (* standard *) + | DW_LNS_copy + | DW_LNS_advance_pc of Nat_big_num.num + | DW_LNS_advance_line of Nat_big_num.num + | DW_LNS_set_file of Nat_big_num.num + | DW_LNS_set_column of Nat_big_num.num + | DW_LNS_negate_stmt + | DW_LNS_set_basic_block + | DW_LNS_const_add_pc + | DW_LNS_fixed_advance_pc of Nat_big_num.num + | DW_LNS_set_prologue_end + | DW_LNS_set_epilogue_begin + | DW_LNS_set_isa of Nat_big_num.num + (* extended *) + | DW_LNE_end_sequence + | DW_LNE_set_address of Nat_big_num.num + | DW_LNE_define_file of ( char list) * Nat_big_num.num * Nat_big_num.num * Nat_big_num.num + | DW_LNE_set_discriminator of Nat_big_num.num + (* special *) + | DW_LN_special of Nat_big_num.num (* the adjusted opcode *) + +type line_number_file_entry = + { + lnfe_path: char list; + lnfe_directory_index: Nat_big_num.num; + lnfe_last_modification: Nat_big_num.num; + lnfe_length: Nat_big_num.num; + } + +type line_number_header = + { + lnh_offset: Nat_big_num.num; + lnh_dwarf_format: dwarf_format; + lnh_unit_length: Nat_big_num.num; + lnh_version: Nat_big_num.num; + lnh_header_length: Nat_big_num.num; + lnh_minimum_instruction_length: Nat_big_num.num; + lnh_maximum_operations_per_instruction: Nat_big_num.num; + lnh_default_is_stmt: bool; + lnh_line_base: Nat_big_num.num; + lnh_line_range: Nat_big_num.num; + lnh_opcode_base: Nat_big_num.num; + lnh_standard_opcode_lengths: Nat_big_num.num list; + lnh_include_directories: ( char list) list; + lnh_file_names: line_number_file_entry list; + } + +type line_number_program = + { + lnp_header: line_number_header; + lnp_operations: line_number_operation list; + } + +(* line number evaluation *) + +type line_number_registers = + { + lnr_address: Nat_big_num.num; + lnr_op_index: Nat_big_num.num; + lnr_file: Nat_big_num.num; + lnr_line: Nat_big_num.num; + lnr_column: Nat_big_num.num; + lnr_is_stmt: bool; + lnr_basic_block: bool; + lnr_end_sequence: bool; + lnr_prologue_end: bool; + lnr_epilogue_begin: bool; + lnr_isa: Nat_big_num.num; + lnr_discriminator: Nat_big_num.num; + } + + + + +(* top-level collection of dwarf data *) + +type dwarf = + { + d_endianness: Endianness.endianness; (* from the ELF *) + d_str: char list; + 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: line_number_program list; + } + +(* analysed location data *) + +type analysed_location_data = ((compilation_unit * ( die list) * die) * ( (Nat_big_num.num * Nat_big_num.num * single_location_description)list)option) list + +type analysed_location_data_at_pc = ((compilation_unit * ( die list) * die) * (Nat_big_num.num * Nat_big_num.num * single_location_description * single_location error)) list + +(* evaluated line data *) + +type evaluated_line_info = (line_number_header * line_number_registers list) list + +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; + } + +type dwarf_dynamic_at_pc = analysed_location_data_at_pc + +(** context for parsing and pp functions *) + +type p_context = + { + endianness: Endianness.endianness; + } + + + +(** ************************************************************ *) +(** ** missing pervasives ************************************ *) +(** ************************************************************ *) + +(** hex parsing *) + +(* this should be in lem, either built-in or in pervasives *) + +(*val natural_of_char : char -> natural*) +let natural_of_char c:Nat_big_num.num= + (let naturalOrd c'= (Nat_big_num.of_int (Char.code c')) in + let n = (naturalOrd c) in + if Nat_big_num.greater_equal n (naturalOrd '0') && Nat_big_num.less_equal n (naturalOrd '9') then Nat_big_num.sub_nat n (naturalOrd '0') + else if Nat_big_num.greater_equal n (naturalOrd 'A') && Nat_big_num.less_equal n (naturalOrd 'F') then Nat_big_num.add (Nat_big_num.sub_nat n (naturalOrd 'A'))(Nat_big_num.of_int 10) + else if Nat_big_num.greater_equal n (naturalOrd 'a') && Nat_big_num.less_equal n (naturalOrd 'f') then Nat_big_num.add (Nat_big_num.sub_nat n (naturalOrd 'a'))(Nat_big_num.of_int 10) + else failwith ("natural_of_char argument #'" ^ (Xstring.implode [c] ^ "' not in 0-9,A-F,a-f"))) + +(*val natural_of_hex' : list char -> natural*) +let rec natural_of_hex' cs:Nat_big_num.num= + ((match cs with + | c :: cs' -> Nat_big_num.add (natural_of_char c) (Nat_big_num.mul(Nat_big_num.of_int 16) (natural_of_hex' cs')) + | [] ->Nat_big_num.of_int 0 + )) + +(*val natural_of_hex : string -> natural*) +let natural_of_hex s:Nat_big_num.num= + (let cs = (Xstring.explode s) in + (match cs with + | '0'::'x'::cs' -> + (match cs' with + | c :: _ -> natural_of_hex' (List.rev cs') + | [] -> failwith ("natural_of_hex argument \"" ^ (s ^ "\" has no digits")) + ) + | _ -> failwith ("natural_of_hex argument \"" ^ (s ^ "\" does not begin 0x")) + )) + + +(* natural version of List.index *) +(*val index_natural : forall 'a. list 'a -> natural -> maybe 'a*) +let rec index_natural l n:'a option= ((match l with + | [] -> None + | x :: xs -> if Nat_big_num.equal n(Nat_big_num.of_int 0) then Some x else index_natural xs (Nat_big_num.sub_nat n(Nat_big_num.of_int 1)) +)) + +let partialNaturalFromInteger (i:Nat_big_num.num) : Nat_big_num.num= + (if Nat_big_num.less i(Nat_big_num.of_int 0) then failwith "partialNaturalFromInteger" else Nat_big_num.abs i) + +(*val natural_nat_shift_left : natural -> nat -> natural*) + +(*val natural_nat_shift_right : natural -> nat -> natural*) + + + +(** ************************************************************ *) +(** ** dwarf encodings *************************************** *) +(** ************************************************************ *) + +(* these encoding tables are pasted from the DWARF 4 specification *) + +(* tag encoding *) +let tag_encodings:(string*Nat_big_num.num)list= ([ + ("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:Nat_big_num.num= (natural_of_hex "0x00") +let vDW_CHILDREN_yes:Nat_big_num.num= (natural_of_hex "0x01") + + +(* attribute encoding *) + +let attribute_encodings:(string*Nat_big_num.num*(dwarf_attribute_classes)list)list= ([ + ("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_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:(string*Nat_big_num.num*(dwarf_attribute_classes)list)list= ([ + ("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:(string*Nat_big_num.num*(operation_argument_type)list*operation_semantics)list= ([ +("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 -> Some (v::(v::vs)) | _ -> None ))); (*0*) +("DW_OP_drop", natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> (match vs with v::vs -> Some vs | _ -> None ))); (*0*) +("DW_OP_over", natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> (match vs with v::v'::vs -> Some (v'::(v::(v'::vs))) | _ -> None ))); (*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 Some v -> Some (v::vs) | None -> None ) | _ -> None ))); (*1*) (* 1-byte stack index *) +("DW_OP_swap", natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> (match vs with v::v'::vs -> Some (v'::(v::vs)) | _ -> None ))); (*0*) +("DW_OP_rot", natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> (match vs with v::v'::v''::vs -> Some (v'::(v''::(v::vs))) | _ -> None ))); (*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 Nat_big_num.less v ac.ac_half then Some v else if Nat_big_num.equal v ac.ac_max then None else Some (Nat_big_num.sub_nat ac.ac_all v))); (*0*) +("DW_OP_and", natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Some (Nat_big_num.bitwise_and 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 -> Some (partialNaturalFromInteger ( Nat_big_num.modulus( Nat_big_num.sub( v1) ( v2)) ( ac.ac_all))))); (*0*) +("DW_OP_mod", natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Some ( Nat_big_num.modulus v1 v2))); (*0*) +("DW_OP_mul", natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Some (partialNaturalFromInteger ( Nat_big_num.modulus( Nat_big_num.mul( v1) ( v2)) ( ac.ac_all))))); (*0*) +("DW_OP_neg", natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if Nat_big_num.less v ac.ac_half then Some ( Nat_big_num.sub_nat ac.ac_max v) else if Nat_big_num.equal v ac.ac_half then None else Some ( Nat_big_num.sub_nat ac.ac_all v))); (*0*) +("DW_OP_not", natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Some (Nat_big_num.bitwise_xor v ac.ac_max))); (*0*) +("DW_OP_or", natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Some (Nat_big_num.bitwise_or v1 v2))); (*0*) +("DW_OP_plus", natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Some ( Nat_big_num.modulus( Nat_big_num.add v1 v2) 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' = (Nat_big_num.modulus (Nat_big_num.add v n) ac.ac_all) in Some (v'::vs) | [] -> None ) | _ -> None ))); (*1*) (* ULEB128 addend *) +("DW_OP_shl", natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if Nat_big_num.greater_equal v2 ac.ac_bitwidth then Some(Nat_big_num.of_int 0) else Some (Nat_big_num.shift_left v1 (Nat_big_num.to_int v2)))); (*0*) +("DW_OP_shr", natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if Nat_big_num.greater_equal v2 ac.ac_bitwidth then Some(Nat_big_num.of_int 0) else Some (Nat_big_num.shift_right v1 (Nat_big_num.to_int v2)))); (*0*) +("DW_OP_shra", natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if Nat_big_num.less v1 ac.ac_half then (if Nat_big_num.greater_equal v2 ac.ac_bitwidth then Some(Nat_big_num.of_int 0) else Some (Nat_big_num.shift_right v1 (Nat_big_num.to_int v2))) else (if Nat_big_num.greater_equal v2 ac.ac_bitwidth then Some ac.ac_max else Some ( Nat_big_num.sub_nat ac.ac_max (Nat_big_num.shift_right ( Nat_big_num.sub_nat ac.ac_max v1) (Nat_big_num.to_int v2)))))); (*0*) +("DW_OP_xor", natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Some (Nat_big_num.bitwise_xor 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", 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:Nat_big_num.num= (natural_of_hex "0x50") +let vDW_OP_breg0:Nat_big_num.num= (natural_of_hex "0x70") + + +(* call frame instruction encoding *) + +let call_frame_instruction_encoding : (string * Nat_big_num.num * Nat_big_num.num * call_frame_argument_type list * (( call_frame_argument_value list) -> call_frame_instruction option)) list= ([ +(* 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",Nat_big_num.of_int 0, natural_of_hex "0x00", [], +( (* *)fun avs -> (match avs with [] -> Some (DW_CFA_nop) | _ -> None ))); +("DW_CFA_set_loc",Nat_big_num.of_int 0, natural_of_hex "0x01", [CFAT_address], +( (* address *)fun avs -> (match avs with [CFAV_address a] -> Some (DW_CFA_set_loc a) | _ -> None ))); +("DW_CFA_advance_loc1",Nat_big_num.of_int 0, natural_of_hex "0x02", [CFAT_delta1], +( (* 1-byte delta *)fun avs -> (match avs with [CFAV_delta d] -> Some (DW_CFA_advance_loc1 d) | _ -> None ))); +("DW_CFA_advance_loc2",Nat_big_num.of_int 0, natural_of_hex "0x03", [CFAT_delta2], +( (* 2-byte delta *)fun avs -> (match avs with [CFAV_delta d] -> Some (DW_CFA_advance_loc2 d) | _ -> None ))); +("DW_CFA_advance_loc4",Nat_big_num.of_int 0, natural_of_hex "0x04", [CFAT_delta4], +( (* 4-byte delta *)fun avs -> (match avs with [CFAV_delta d] -> Some (DW_CFA_advance_loc4 d) | _ -> None ))); +("DW_CFA_offset_extended",Nat_big_num.of_int 0, natural_of_hex "0x05", [CFAT_register; CFAT_offset], +( (* ULEB128 register ULEB128 offset *)fun avs -> (match avs with [CFAV_register r; CFAV_offset n] -> Some (DW_CFA_offset_extended( r, n)) | _ -> None ))); +("DW_CFA_restore_extended",Nat_big_num.of_int 0, natural_of_hex "0x06", [CFAT_register], +( (* ULEB128 register *)fun avs -> (match avs with [CFAV_register r] -> Some (DW_CFA_restore_extended r) | _ -> None ))); +("DW_CFA_undefined",Nat_big_num.of_int 0, natural_of_hex "0x07", [CFAT_register], +( (* ULEB128 register *)fun avs -> (match avs with [CFAV_register r] -> Some (DW_CFA_undefined r) | _ -> None ))); +("DW_CFA_same_value",Nat_big_num.of_int 0, natural_of_hex "0x08", [CFAT_register], +( (* ULEB128 register *)fun avs -> (match avs with [CFAV_register r] -> Some (DW_CFA_same_value r) | _ -> None ))); +("DW_CFA_register",Nat_big_num.of_int 0, natural_of_hex "0x09", [CFAT_register; CFAT_register], +( (* ULEB128 register ULEB128 register *)fun avs -> (match avs with [CFAV_register r1; CFAV_register r2] -> Some (DW_CFA_register( r1, r2)) | _ -> None ))); +("DW_CFA_remember_state",Nat_big_num.of_int 0, natural_of_hex "0x0a", [], +( (* *)fun avs -> (match avs with [] -> Some (DW_CFA_remember_state) | _ -> None ))); +("DW_CFA_restore_state",Nat_big_num.of_int 0, natural_of_hex "0x0b", [], +( (* *)fun avs -> (match avs with [] -> Some (DW_CFA_restore_state) | _ -> None ))); +("DW_CFA_def_cfa",Nat_big_num.of_int 0, natural_of_hex "0x0c", [CFAT_register; CFAT_offset], +( (* ULEB128 register ULEB128 offset *)fun avs -> (match avs with [CFAV_register r; CFAV_offset n] -> Some (DW_CFA_def_cfa( r, n)) | _ -> None ))); +("DW_CFA_def_cfa_register",Nat_big_num.of_int 0, natural_of_hex "0x0d", [CFAT_register], +( (* ULEB128 register *)fun avs -> (match avs with [CFAV_register r] -> Some (DW_CFA_def_cfa_register r) | _ -> None ))); +("DW_CFA_def_cfa_offset",Nat_big_num.of_int 0, natural_of_hex "0x0e", [CFAT_offset], +( (* ULEB128 offset *)fun avs -> (match avs with [CFAV_offset n] -> Some (DW_CFA_def_cfa_offset n) | _ -> None ))); +("DW_CFA_def_cfa_expression",Nat_big_num.of_int 0, natural_of_hex "0x0f", [CFAT_block], +( (* BLOCK *)fun avs -> (match avs with [CFAV_block b] -> Some (DW_CFA_def_cfa_expression b) | _ -> None ))); +("DW_CFA_expression",Nat_big_num.of_int 0, natural_of_hex "0x10", [CFAT_register; CFAT_block], +( (* ULEB128 register BLOCK *)fun avs -> (match avs with [CFAV_register r; CFAV_block b] -> Some (DW_CFA_expression( r, b)) | _ -> None ))); +("DW_CFA_offset_extended_sf",Nat_big_num.of_int 0, natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], +( (* ULEB128 register SLEB128 offset *)fun avs -> (match avs with [CFAV_register r; CFAV_sfoffset i] -> Some (DW_CFA_offset_extended_sf( r, i)) | _ -> None ))); +("DW_CFA_def_cfa_sf",Nat_big_num.of_int 0, natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], +( (* ULEB128 register SLEB128 offset *)fun avs -> (match avs with [CFAV_register r; CFAV_sfoffset i] -> Some (DW_CFA_def_cfa_sf( r, i)) | _ -> None ))); +("DW_CFA_def_cfa_offset_sf",Nat_big_num.of_int 0, natural_of_hex "0x13", [CFAT_sfoffset], +( (* SLEB128 offset *)fun avs -> (match avs with [CFAV_sfoffset i] -> Some (DW_CFA_def_cfa_offset_sf i) | _ -> None ))); +("DW_CFA_val_offset",Nat_big_num.of_int 0, natural_of_hex "0x14", [CFAT_register; CFAT_offset], +( (* ULEB128 ULEB128 *)fun avs -> (match avs with [CFAV_register r; CFAV_offset n] -> Some (DW_CFA_val_offset( r, n)) | _ -> None ))); +("DW_CFA_val_offset_sf",Nat_big_num.of_int 0, natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], +( (* ULEB128 SLEB128 *)fun avs -> (match avs with [CFAV_register r; CFAV_sfoffset i] -> Some (DW_CFA_val_offset_sf( r, i)) | _ -> None ))); +("DW_CFA_val_expression",Nat_big_num.of_int 0, natural_of_hex "0x16", [CFAT_register; CFAT_block], +( (* ULEB128 BLOCK *)fun avs -> (match avs with [CFAV_register r; CFAV_block b] -> Some (DW_CFA_val_expression( r, b)) | _ -> None ))) +]) + +(* +("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:(string*Nat_big_num.num*(line_number_argument_type)list*((line_number_argument_value)list ->(line_number_operation)option))list= ([ + ("DW_LNS_copy" , natural_of_hex "0x01", [ ], + (fun lnvs -> (match lnvs with [] -> Some DW_LNS_copy | _ -> None ))); + ("DW_LNS_advance_pc" , natural_of_hex "0x02", [LNAT_ULEB128 ], + (fun lnvs -> (match lnvs with [LNAV_ULEB128 n] -> Some (DW_LNS_advance_pc n) | _ -> None ))); + ("DW_LNS_advance_line" , natural_of_hex "0x03", [LNAT_SLEB128 ], + (fun lnvs -> (match lnvs with [LNAV_SLEB128 i] -> Some (DW_LNS_advance_line i) | _ -> None ))); + ("DW_LNS_set_file" , natural_of_hex "0x04", [LNAT_ULEB128 ], + (fun lnvs -> (match lnvs with [LNAV_ULEB128 n] -> Some (DW_LNS_set_file n) | _ -> None ))); + ("DW_LNS_set_column" , natural_of_hex "0x05", [LNAT_ULEB128 ], + (fun lnvs -> (match lnvs with [LNAV_ULEB128 n] -> Some (DW_LNS_set_column n) | _ -> None ))); + ("DW_LNS_negate_stmt" , natural_of_hex "0x06", [ ], + (fun lnvs -> (match lnvs with [] -> Some (DW_LNS_negate_stmt) | _ -> None ))); + ("DW_LNS_set_basic_block" , natural_of_hex "0x07", [ ], + (fun lnvs -> (match lnvs with [] -> Some (DW_LNS_set_basic_block) | _ -> None ))); + ("DW_LNS_const_add_pc" , natural_of_hex "0x08", [ ], + (fun lnvs -> (match lnvs with [] -> Some (DW_LNS_const_add_pc) | _ -> None ))); + ("DW_LNS_fixed_advance_pc" , natural_of_hex "0x09", [LNAT_uint16 ], + (fun lnvs -> (match lnvs with [LNAV_uint16 n] -> Some (DW_LNS_fixed_advance_pc n) | _ -> None ))); + ("DW_LNS_set_prologue_end" , natural_of_hex "0x0a", [ ], +(fun lnvs -> (match lnvs with [] -> Some (DW_LNS_set_prologue_end) | _ -> None ))); + ("DW_LNS_set_epilogue_begin" , natural_of_hex "0x0b", [ ], +(fun lnvs -> (match lnvs with [] -> Some (DW_LNS_set_epilogue_begin) | _ -> None ))); + ("DW_LNS_set_isa" , natural_of_hex "0x0c", [LNAT_ULEB128 ], + (fun lnvs -> (match lnvs with [LNAV_ULEB128 n] -> Some (DW_LNS_set_isa n) | _ -> None ))) +]) + +let line_number_extended_encodings:(string*Nat_big_num.num*(line_number_argument_type)list*((line_number_argument_value)list ->(line_number_operation)option))list= ([ + ("DW_LNE_end_sequence" , natural_of_hex "0x01", [], + (fun lnvs -> (match lnvs with [] -> Some (DW_LNE_end_sequence) | _ -> None ))); + ("DW_LNE_set_address" , natural_of_hex "0x02", [LNAT_address], + (fun lnvs -> (match lnvs with [LNAV_address n] -> Some (DW_LNE_set_address n) | _ -> None ))); + ("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] -> Some (DW_LNE_define_file( s, n1, n2, n3)) | _ -> None ))); + ("DW_LNE_set_discriminator" , natural_of_hex "0x04", [LNAT_ULEB128], + (fun lnvs -> (match lnvs with [LNAV_ULEB128 n] -> Some (DW_LNE_set_discriminator n) | _ -> None ))) (* 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.â *) + + +(** ************************************************************ *) +(** ** 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:string= + ((match ss with + | [] -> "" + | s :: ss' -> + (match ss' with + | [] -> s + | _ -> s ^ (sep ^ myconcat sep ss') + ) + )) + +(*val myhead : forall 'a. list 'a -> 'a*) +let myhead l:'a= ((match l with | x::xs -> x | [] -> failwith "myhead of empty list" )) + + +(*val myfindNonPure : forall 'a. ('a -> bool) -> list 'a -> 'a*) +let myfindNonPure p0 l:'a= ((match (Lem_list.list_find_opt p0 l) with + | Some e -> e + | None -> failwith "myfindNonPure" +)) + +(*val myfindmaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> maybe 'b*) +let rec myfindmaybe f xs:'b option= + ((match xs with + | [] -> None + | x::xs' -> (match f x with Some y -> Some y | None -> myfindmaybe f xs' ) + )) + +(*val myfind : forall 'a. ('a -> bool) -> list 'a -> maybe 'a*) +let rec myfind f xs:'a option= + ((match xs with + | [] -> None + | x::xs' -> (match f x with true -> Some x | false -> myfind f xs' ) + )) + +(*val myfiltermaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b*) +let rec myfiltermaybe f xs:'b list= + ((match xs with + | [] -> [] + | x::xs' -> (match f x with Some y -> y::myfiltermaybe f xs'| None -> myfiltermaybe f xs' ) + )) + + + +(*val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> list byte*) +let bytes_of_natural en size2 n:(char)list= + (if Nat_big_num.equal size2(Nat_big_num.of_int 8) then + bytes_of_elf64_xword en (Uint64.of_string (Nat_big_num.to_string n)) + else if Nat_big_num.equal size2(Nat_big_num.of_int 4) then + bytes_of_elf32_word en (Uint32.of_string (Nat_big_num.to_string n)) + else + failwith "bytes_of_natural given size that is not 4 or 8") + +(* TODO: generalise *) +(*val natural_of_bytes: endianness -> list byte -> natural*) +let natural_of_bytes en bs:Nat_big_num.num= + ((match bs with + | b0::b1::b2::b3::b4::b5::b6::b7::[] -> + let v = (if en=Little then + Nat_big_num.add (Nat_big_num.add (Nat_big_num.add (Nat_big_num.add + (natural_of_byte b0)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b3))) (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))( Nat_big_num.add (Nat_big_num.add (Nat_big_num.add(natural_of_byte b4)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b5)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b6)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b7)))) + else + Nat_big_num.add (Nat_big_num.add (Nat_big_num.add (Nat_big_num.add +(natural_of_byte b7)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b6)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b5)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b4))) (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))( Nat_big_num.add (Nat_big_num.add (Nat_big_num.add(natural_of_byte b3)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b0))))) + in + v + | b0::b1::b2::b3::[] -> + let v = (if en=Little then Nat_big_num.add (Nat_big_num.add (Nat_big_num.add + (natural_of_byte b0)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b3)) + else Nat_big_num.add (Nat_big_num.add (Nat_big_num.add +(natural_of_byte b3)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b0))) + + in + v + | b0::b1::[] -> + let v = (if en=Little then Nat_big_num.add + (natural_of_byte b0)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b1)) + else Nat_big_num.add +(natural_of_byte b1)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b0))) + + in + v + | b0::[] -> + natural_of_byte b0 + | _ -> failwith "natural_of_bytes given not-8/4/2/1 bytes" + )) + + +(*val bigunionListMap : forall 'a 'b. SetType 'b => ('a -> set 'b) -> list 'a -> set 'b*) +let rec bigunionListMap dict_Basic_classes_SetType_b f xs:'b Pset.set= + ((match xs with + | [] ->(Pset.from_list + dict_Basic_classes_SetType_b.setElemCompare_method []) + | x::xs' -> Pset.(union) (f x) (bigunionListMap + dict_Basic_classes_SetType_b f xs') + )) + +let rec mytake' (n:Nat_big_num.num) acc xs:('a list*'a list)option= + ( + if(Nat_big_num.equal n (Nat_big_num.of_int 0)) then + (Some (List.rev acc, xs)) else + ((match xs with + [] -> None + | x::xs' -> mytake' (Nat_big_num.sub_nat n (Nat_big_num.of_int 1)) + (x :: acc) xs' + ))) + +(*val mytake : forall 'a. natural -> (list 'a) -> maybe (list 'a * list 'a)*) +let mytake n xs:('a list*'a list)option= (mytake' n [] xs) + +(*val mynth : forall 'a. natural -> (list 'a) -> maybe 'a*) +let rec mynth (n:Nat_big_num.num) xs:'a option= + ( (*Assert_extra.failwith "mynth"*) + if(Nat_big_num.equal n (Nat_big_num.of_int 0)) then + ((match xs with x::xs' -> Some x | [] -> None )) else + ((match xs with + x::xs' -> mynth (Nat_big_num.sub_nat n (Nat_big_num.of_int 1)) xs' + ))) + + +(** basic pretty printing *) + +let pphex n:string= ("0x" ^ unsafe_hex_string_of_natural( 0) n) + +let ppbytes dict_Show_Show_a xs:string= (string_of_list + instance_Show_Show_string_dict (Lem_list.map (fun x -> + dict_Show_Show_a.show_method x) xs)) + +let rec ppbytes2 dict_Show_Show_a n xs:string= ((match xs with | [] -> "" | x::xs' -> "<"^(pphex n^("> "^( + dict_Show_Show_a.show_method x^("\n"^ppbytes2 dict_Show_Show_a (Nat_big_num.add n(Nat_big_num.of_int 1)) xs')))) )) + +(* workaround: from String *) +(*val mytoString : list char -> string*) + +let string_of_bytes bs:string= (Xstring.implode (Lem_list.map (fun x-> x) bs)) + + +let just_one s xs:'a= + ((match xs with + | [] -> failwith ("no " ^ s) + | x1::x2::_ -> failwith ("more than one " ^ s) + | [x] -> x + )) + + + + +let max_address (as': Nat_big_num.num) : Nat_big_num.num= + ( + if(Nat_big_num.equal as' (Nat_big_num.of_int 4)) then + (natural_of_hex "0xffffffff") else + ( + if(Nat_big_num.equal as' (Nat_big_num.of_int 8)) then + (natural_of_hex "0xffffffffffffffff") else + (failwith "max_address size not 4 or 8"))) + + +(** lookup of encodings *) + +(*val lookup_Ab_b : forall 'a 'b. Eq 'a => 'a -> list ('a * 'b) -> maybe 'b*) +let rec lookup_Ab_b dict_Basic_classes_Eq_a x0 xys:'b option= + ((match xys with + | [] -> None + | (x,y)::xys' -> if + dict_Basic_classes_Eq_a.isEqual_method x x0 then Some y else lookup_Ab_b + dict_Basic_classes_Eq_a x0 xys' + )) + +(*val lookup_aB_a : forall 'a 'b. Eq 'b => 'b -> list ('a * 'b) -> maybe 'a*) +let rec lookup_aB_a dict_Basic_classes_Eq_b y0 xys:'a option= + ((match xys with + | [] -> None + | (x,y)::xys' -> if + dict_Basic_classes_Eq_b.isEqual_method y y0 then Some x else lookup_aB_a + dict_Basic_classes_Eq_b y0 xys' + )) + + +(*val lookup_aBc_a : forall 'a 'b 'c. Eq 'b => 'b -> list ('a * 'b * 'c) -> maybe 'a*) +let rec lookup_aBc_a dict_Basic_classes_Eq_b y0 xyzs:'a option= + ((match xyzs with + | [] -> None + | (x,y,_)::xyzs' -> if + dict_Basic_classes_Eq_b.isEqual_method y y0 then Some x else lookup_aBc_a + dict_Basic_classes_Eq_b y0 xyzs' + )) + +(*val lookup_aBc_ac : forall 'a 'b 'c. Eq 'b => 'b -> list ('a * 'b * 'c) -> maybe ('a*'c)*) +let rec lookup_aBc_ac dict_Basic_classes_Eq_b y0 xyzs:('a*'c)option= + ((match xyzs with + | [] -> None + | (x,y,z)::xyzs' -> if + dict_Basic_classes_Eq_b.isEqual_method y y0 then Some (x,z) else lookup_aBc_ac + dict_Basic_classes_Eq_b y0 xyzs' + )) + +(*val lookup_Abc_b : forall 'a 'b 'c. Eq 'a => 'a -> list ('a * 'b * 'c) -> maybe 'b*) +let rec lookup_Abc_b dict_Basic_classes_Eq_a x0 xyzs:'b option= + ((match xyzs with + | [] -> None + | (x,y,_)::xyzs' -> if + dict_Basic_classes_Eq_a.isEqual_method x x0 then Some y else lookup_Abc_b + dict_Basic_classes_Eq_a x0 xyzs' + )) + + + +(*val lookup_aBcd_a : forall 'a 'b 'c 'd. Eq 'b => 'b -> list ('a * 'b * 'c * 'd) -> maybe 'a*) +let rec lookup_aBcd_a dict_Basic_classes_Eq_b y0 xyzws:'a option= + ((match xyzws with + | [] -> None + | (x,y,_,_)::xyzws' -> if + dict_Basic_classes_Eq_b.isEqual_method y y0 then Some x else lookup_aBcd_a + dict_Basic_classes_Eq_b y0 xyzws' + )) + +(*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 dict_Basic_classes_Eq_b y0 xyzws:('a*'c*'d)option= + ((match xyzws with + | [] -> None + | (x,y,z,w)::xyzws' -> if + dict_Basic_classes_Eq_b.isEqual_method y y0 then Some (x,z,w) else lookup_aBcd_acd + dict_Basic_classes_Eq_b y0 xyzws' + )) + +(*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 dict_Basic_classes_Eq_c z0 xyzwus:('d*'e)option= + ((match xyzwus with + | [] -> None + | (x,y,z,w,u)::xyzwus' -> if + dict_Basic_classes_Eq_c.isEqual_method z z0 then Some (w,u) else lookup_abCde_de + dict_Basic_classes_Eq_c z0 xyzwus' + )) + + +let pp_maybe ppf n:string= ((match ppf n with Some s -> s | None -> "encoding not found: " ^ pphex n )) + +let pp_tag_encoding n:string= (pp_maybe (fun n -> lookup_aB_a + instance_Basic_classes_Eq_Num_natural_dict n tag_encodings) n) +let pp_attribute_encoding n:string= (pp_maybe (fun n -> lookup_aBc_a + instance_Basic_classes_Eq_Num_natural_dict n attribute_encodings) n) +let pp_attribute_form_encoding n:string= (pp_maybe (fun n -> lookup_aBc_a + instance_Basic_classes_Eq_Num_natural_dict n attribute_form_encodings) n) +let pp_operation_encoding n:string= (pp_maybe (fun n -> lookup_aBcd_a + instance_Basic_classes_Eq_Num_natural_dict n operation_encodings) n) + +let tag_encode (s: string) : Nat_big_num.num= + ((match lookup_Ab_b + instance_Basic_classes_Eq_string_dict s tag_encodings with + | Some n -> n + | None -> failwith "attribute_encode" + )) + + +let attribute_encode (s: string) : Nat_big_num.num= + ((match lookup_Abc_b + instance_Basic_classes_Eq_string_dict s attribute_encodings with + | Some n -> n + | None -> failwith "attribute_encode" + )) + +let attribute_form_encode (s: string) : Nat_big_num.num= + ((match lookup_Abc_b + instance_Basic_classes_Eq_string_dict s attribute_form_encodings with + | Some n -> n + | None -> failwith "attribute_form_encode" + )) + + + +(** ************************************************************ *) +(** ** parser combinators and primitives ********************* *) +(** ************************************************************ *) + +(* parsing combinators *) + +type parse_context = { pc_bytes: char list; pc_offset: Nat_big_num.num } + +type 'a parse_result = + | PR_success of 'a * parse_context + | PR_fail of string * parse_context + +type 'a parser = parse_context -> 'a parse_result + +let pp_parse_context pc:string= ("pc_offset = " ^ pphex pc.pc_offset) + +let pp_parse_fail s pc:string= + ("Parse fail\n" ^ (s ^ (" at " ^ (pp_parse_context pc ^ "\n")))) + +let pp_parse_result ppa pr:string= + ((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 + )) + +(* [(>>=)] 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:'b parse_result= + ((match x with + | PR_success( v, pc) -> f v pc + | PR_fail( err, pc) -> PR_fail( err, pc) + )) + +(*val pr_return : forall 'a. 'a -> (parser 'a)*) +let pr_return x pc:'a parse_result= (PR_success( x, pc)) + +(*val pr_map : forall 'a 'b. ('a -> 'b) -> parse_result 'a -> parse_result 'b*) +let pr_map f x:'b parse_result= + ((match x with + | PR_success( v, pc) -> PR_success( (f v), pc) + | PR_fail( err, pc) -> PR_fail( err, pc) + )) + +(*val pr_map2 : forall 'a 'b. ('a -> 'b) -> (parser 'a) -> (parser 'b)*) +let pr_map2 f p:parse_context ->'b parse_result= (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:'b parse_result= (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:parse_context ->'b parse_result= (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:parse_context ->(Nat_big_num.num*'a)parse_result= (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:parse_context ->('a*'b)parse_result= + (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'') + ))) + +(*val parse_triple : forall 'a 'b 'c. (parser 'a) -> (parser 'b) -> (parser 'c) -> parser ('a * ('b * 'c))*) +let parse_triple p1 p2 p3:parse_context ->('a*('b*'c))parse_result= + (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_context ->('a*('b*('c*'d)))parse_result= + (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_context ->('a*('b*('c*('d*'e))))parse_result= + (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_context ->('a*('b*('c*('d*('e*'f)))))parse_result= + (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:parse_context ->('a*'b)parse_result= + (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'') + ))) + +(*val parse_dependent : forall 'a 'b. (parser 'a) -> ('a -> parser 'b) -> (parser 'b)*) +let parse_dependent p1 p2:parse_context ->'b parse_result= + (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:'a list ->parse_context ->('a list)parse_result= + (fun acc pc -> let _ = (my_debug "list' ") in pr_bind (p1 pc) (fun mx pc' -> + (match mx with + | None -> PR_success( acc, pc') + | Some x -> parse_list' p1 (x :: acc) pc' + ))) + +(*val parse_list : forall 'a. (parser (maybe 'a)) -> (parser (list 'a))*) +let parse_list p1:parse_context ->('a list)parse_result= + (pr_post_map + (parse_list' p1 []) + (List.rev)) + +(*val parse_parser_list : forall 'a. (list (parser 'a)) -> (parser (list 'a))*) +let rec parse_parser_list ps:parse_context ->('a list)parse_result= + ((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'') + ))) + )) + +(*val parse_maybe : forall 'a. parser 'a -> parser (maybe 'a)*) +let parse_maybe p:parse_context ->('a option)parse_result= + (fun pc -> + (match pc.pc_bytes with + | [] -> pr_return None pc + | _ -> + (match p pc with + | PR_success( v, pc'') -> PR_success( (Some v), pc'') + | PR_fail( s, pc'') -> PR_fail( s, pc'') + ) + )) + +(*val parse_demaybe : forall 'a. string ->parser (maybe 'a) -> parser 'a*) +let parse_demaybe s p:parse_context ->'a parse_result= + (fun pc -> + (match p pc with + | PR_success( (Some v), pc'') -> PR_success( v, pc'') + | PR_success( (None), pc'') -> PR_fail( s, pc'') + | PR_fail( s, pc'') -> PR_fail( s, pc'') + + )) + + +(*val parse_restrict_length : forall 'a. natural -> parser 'a -> parser 'a*) +let parse_restrict_length n p:parse_context ->'a parse_result= + (fun pc -> + (match mytake n pc.pc_bytes with + | None -> failwith "parse_restrict_length not given enough bytes" + | Some (xs,ys) -> + let pc' = ({ pc_bytes = xs; pc_offset = (pc.pc_offset) }) in + p pc' + )) + + +(* parsing of basic types *) + + +let parse_n_bytes (n:Nat_big_num.num) : ( char list) parser= + (fun (pc:parse_context) -> + (match mytake n pc.pc_bytes with + | None -> PR_fail( ("parse_n_bytes n=" ^ pphex n), pc) + | Some (xs,bs) -> PR_success( xs, ({pc_bytes=bs; pc_offset= (Nat_big_num.add pc.pc_offset (Nat_big_num.of_int (List.length xs))) } )) + )) + +let rec mytakestring' acc xs:((char)list*(char)list)option= + ((match xs with + | [] -> None + | x::xs' -> if Nat_big_num.equal (natural_of_byte x)(Nat_big_num.of_int 0) then Some (List.rev acc, xs') else mytakestring' (x::acc) xs' + )) + +let parse_string : ( char list) parser= + (fun (pc:parse_context) -> + (match mytakestring' [] pc.pc_bytes with + | None -> PR_fail( "parse_string", pc) + | Some (xs,bs) -> PR_success( xs, ({pc_bytes=bs; pc_offset = (Nat_big_num.add (Nat_big_num.add pc.pc_offset (Nat_big_num.of_int (List.length xs))) (Nat_big_num.of_int( 1))) } )) + )) + +(* parse a null-terminated string; return Nothing if it is empty, Just s otherwise *) +let parse_non_empty_string : ( ( char list)option) parser= + (fun (pc:parse_context) -> + (match mytakestring' [] pc.pc_bytes with + | None -> PR_fail( "parse_string", pc) + | Some (xs,bs) -> + (*let _ = my_debug5 ("**" ^string_of_bytes xs ^ "**\n") in *) + let pc' = ({pc_bytes=bs; pc_offset = (Nat_big_num.add (Nat_big_num.add pc.pc_offset (Nat_big_num.of_int (List.length xs))) (Nat_big_num.of_int( 1))) } ) in + if (listEqualBy (=) xs []) then PR_success( (None), pc') + else PR_success( (Some xs), pc') + )) + + +let parse_uint8 : Nat_big_num.num parser= + (fun (pc:parse_context) -> + let _ = (my_debug "uint8 ") in + (match pc.pc_bytes with + | b0::bytes' -> + let v = (natural_of_byte b0) in + PR_success( v, ({ pc_bytes = bytes'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 1)) })) + | _ -> PR_fail( "parse_uint32 not given enough bytes", pc) + )) + +let parse_uint16 c : Nat_big_num.num parser= + (fun (pc:parse_context) -> + let _ = (my_debug "uint16 ") in + (match pc.pc_bytes with + | b0::b1::bytes' -> + let v = (if c.endianness=Little then Nat_big_num.add + (natural_of_byte b0)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b1)) + else Nat_big_num.add + (natural_of_byte b1)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b0))) in + PR_success( v, ({ pc_bytes = bytes'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 2)) })) + | _ -> PR_fail( "parse_uint32 not given enough bytes", pc) + )) + +let parse_uint32 c : Nat_big_num.num parser= + (fun (pc:parse_context) -> + let _ = (my_debug "uint32 ") in + (match pc.pc_bytes with + | b0::b1::b2::b3::bytes' -> + let v = (if c.endianness=Little then Nat_big_num.add (Nat_big_num.add (Nat_big_num.add + (natural_of_byte b0)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b3)) + else Nat_big_num.add (Nat_big_num.add (Nat_big_num.add + (natural_of_byte b3)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b0))) in + PR_success( v, ({ pc_bytes = bytes'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 4)) })) + | _ -> PR_fail( "parse_uint32 not given enough bytes", pc) + )) + +let parse_uint64 c : Nat_big_num.num parser= + (fun (pc:parse_context) -> + let _ = (my_debug "uint64 ") in + (match pc.pc_bytes with + | b0::b1::b2::b3::b4::b5::b6::b7::bytes' -> + let v = (if c.endianness=Little then + Nat_big_num.add (Nat_big_num.add (Nat_big_num.add (Nat_big_num.add + (natural_of_byte b0)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b3))) (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))( Nat_big_num.add (Nat_big_num.add (Nat_big_num.add(natural_of_byte b4)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b5)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b6)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b7)))) + else + Nat_big_num.add (Nat_big_num.add (Nat_big_num.add (Nat_big_num.add +(natural_of_byte b7)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b6)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b5)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b4))) (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))( Nat_big_num.add (Nat_big_num.add (Nat_big_num.add(natural_of_byte b3)(Nat_big_num.mul(Nat_big_num.of_int 256)(natural_of_byte b2)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(natural_of_byte b1)))(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(natural_of_byte b0))))) + in + PR_success( v, ({ pc_bytes = bytes'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 8)) })) + | _ -> PR_fail( "parse_uint64 not given enough bytes", pc) + )) + +let integerFromTwosComplementNatural (n:Nat_big_num.num) (half: Nat_big_num.num) (all:Nat_big_num.num) : Nat_big_num.num= + (if Nat_big_num.less n half then n else Nat_big_num.sub ( n) all) + +let partialTwosComplementNaturalFromInteger (i:Nat_big_num.num) (half: Nat_big_num.num) (all:Nat_big_num.num) : Nat_big_num.num= + (if Nat_big_num.greater_equal i(Nat_big_num.of_int 0) && Nat_big_num.less i ( half) then partialNaturalFromInteger i + else if Nat_big_num.greater_equal i (Nat_big_num.sub(Nat_big_num.of_int 0)( half)) && Nat_big_num.less i(Nat_big_num.of_int 0) then partialNaturalFromInteger ( Nat_big_num.add all i) + else failwith "partialTwosComplementNaturalFromInteger") + + +let parse_sint8 : Nat_big_num.num parser= + (pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural n(Nat_big_num.of_int 128)(Nat_big_num.of_int 256))) + +let parse_sint16 c : Nat_big_num.num parser= + (pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural n (Nat_big_num.mul(Nat_big_num.of_int 128)(Nat_big_num.of_int 256)) (Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256)))) + +let parse_sint32 c : Nat_big_num.num parser= + (pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural n (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 128)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256)) (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256)))) + +let parse_sint64 c : Nat_big_num.num parser= + (pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural n (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 128)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256)) (Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.mul(Nat_big_num.of_int 256)(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256))(Nat_big_num.of_int 256)))) + +let rec parse_ULEB128' (acc: Nat_big_num.num) (shift_factor: Nat_big_num.num) : Nat_big_num.num parser= + (fun (pc:parse_context) -> + let _ = (my_debug "ULEB128' ") in + (match pc.pc_bytes with + | b::bytes' -> + let n = (natural_of_byte b) in + let acc' = (Nat_big_num.add (Nat_big_num.mul (Nat_big_num.bitwise_and n(Nat_big_num.of_int 127)) shift_factor) acc) in + let finished = ( Nat_big_num.equal(Nat_big_num.bitwise_and n(Nat_big_num.of_int 128))(Nat_big_num.of_int 0)) in + let pc' = ({ pc_bytes = bytes'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 1)) }) in + if finished then + PR_success( acc', pc') + else + parse_ULEB128' acc' ( Nat_big_num.mul shift_factor(Nat_big_num.of_int 128)) pc' + | _ -> + PR_fail( "parse_ULEB128' not given enough bytes", pc) + )) + +let parse_ULEB128 : Nat_big_num.num parser= + (fun (pc:parse_context) -> + parse_ULEB128'(Nat_big_num.of_int 0)(Nat_big_num.of_int 1) pc) + +let rec parse_SLEB128' (acc: Nat_big_num.num) (shift_factor: Nat_big_num.num) : (bool * Nat_big_num.num * Nat_big_num.num) parser= + (fun (pc:parse_context) -> + let _ = (my_debug "SLEB128' ") in + (match pc.pc_bytes with + | b::bytes' -> + let n = (natural_of_byte b) in + let acc' = (Nat_big_num.add acc (Nat_big_num.mul (Nat_big_num.bitwise_and n(Nat_big_num.of_int 127)) shift_factor)) in + let shift_factor' = (Nat_big_num.mul shift_factor(Nat_big_num.of_int 128)) in + let finished = ( Nat_big_num.equal(Nat_big_num.bitwise_and n(Nat_big_num.of_int 128))(Nat_big_num.of_int 0)) in + let positive = ( Nat_big_num.equal(Nat_big_num.bitwise_and n(Nat_big_num.of_int 64))(Nat_big_num.of_int 0)) in + let pc' = ({ pc_bytes = bytes'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 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) + )) + +let parse_SLEB128 : Nat_big_num.num parser= + (pr_post_map (parse_SLEB128'(Nat_big_num.of_int 0)(Nat_big_num.of_int 1)) (fun (positive, shift_factor, acc) -> + if positive then acc else Nat_big_num.sub ( acc) ( shift_factor))) + +let parse_nonzero_ULEB128_pair : ( (Nat_big_num.num*Nat_big_num.num)option) parser= + (let _ = (my_debug "nonzero_ULEB128_pair ") in + pr_post_map + (parse_pair parse_ULEB128 parse_ULEB128) + (fun (n1,n2) -> if Nat_big_num.equal n1(Nat_big_num.of_int 0) &&Nat_big_num.equal n2(Nat_big_num.of_int 0) then None else Some (n1,n2))) + +let parse_zero_terminated_ULEB128_pair_list : ( (Nat_big_num.num*Nat_big_num.num)list) parser= + (let _ = (my_debug "zero_terminated_ULEB128_pair_list ") in + parse_list parse_nonzero_ULEB128_pair) + +let parse_uintDwarfN c (df: dwarf_format) : Nat_big_num.num parser= + ((match df with + | Dwarf32 -> (parse_uint32 c) + | Dwarf64 -> (parse_uint64 c) + )) + +let parse_uint_address_size c (as': Nat_big_num.num) : Nat_big_num.num parser= + ( + if(Nat_big_num.equal as' (Nat_big_num.of_int 4)) then (parse_uint32 c) else + ( + if(Nat_big_num.equal as' (Nat_big_num.of_int 8)) then (parse_uint64 c) + else + (failwith ("cuh_address_size not 4 or 8: " ^ Nat_big_num.to_string as')))) + +let parse_uint_segment_selector_size c (ss: Nat_big_num.num) : ( Nat_big_num.num option) parser= + ( + if(Nat_big_num.equal ss (Nat_big_num.of_int 0)) then (pr_return None) else + ( + if(Nat_big_num.equal ss (Nat_big_num.of_int 1)) then + (pr_post_map (parse_uint8) (fun n -> Some n)) else + ( + if(Nat_big_num.equal ss (Nat_big_num.of_int 2)) then + (pr_post_map (parse_uint16 c) (fun n -> Some n)) else + ( + if(Nat_big_num.equal ss (Nat_big_num.of_int 4)) then + (pr_post_map (parse_uint32 c) (fun n -> Some n)) else + ( + if(Nat_big_num.equal ss (Nat_big_num.of_int 8)) then + (pr_post_map (parse_uint64 c) (fun n -> Some n)) else + (failwith "cuh_address_size not 4 or 8")))))) + + + +(** ************************************************************ *) +(** ** parsing and pretty printing of .debug_* sections ****** *) +(** ************************************************************ *) + + +(** abbreviations table: pp and parsing *) + +let pp_abbreviation_declaration (x:abbreviation_declaration):string= + (" " + ^ (Nat_big_num.to_string 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"*) + ^ myconcat "" + (Lem_list.map + (fun (n1,n2) -> + " " ^ (pp_attribute_encoding n1 ^ (" " ^ (pp_attribute_form_encoding n2 ^ "\n")))) + x.ad_attribute_specifications)))))))) + +let pp_abbreviations_table (x:abbreviations_table):string= + (myconcat "" (Lem_list.map (pp_abbreviation_declaration) x)) + +let parse_abbreviation_declaration c : ( abbreviation_declaration option) parser= + (fun (pc: parse_context) -> + pr_bind (parse_ULEB128 pc) (fun n1 pc' -> + if Nat_big_num.equal n1(Nat_big_num.of_int 0) then + PR_success( None, 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 -> + Some ( let ad = + ({ + ad_abbreviation_code = n1; + ad_tag = n2; + ad_has_children = (not (Nat_big_num.equal c(Nat_big_num.of_int 0))); + ad_attribute_specifications = l; + }) in let _ = (my_debug2 (pp_abbreviation_declaration ad)) in ad) + ))))) + +let parse_abbreviations_table c:parse_context ->((abbreviation_declaration)list)parse_result= + (parse_list (parse_abbreviation_declaration c)) + + +(** debug_str entry *) + +(*val mydrop : forall 'a. natural -> list 'a -> maybe (list 'a)*) +let rec mydrop n xs:('a list)option= + (if Nat_big_num.equal n(Nat_big_num.of_int 0) then Some xs + else + (match xs with + | x::xs' -> mydrop (Nat_big_num.sub_nat n(Nat_big_num.of_int 1)) xs' + | [] -> None + )) + +let rec null_terminated_list (acc: char list) (xs: char list) : char list= + ((match xs with + | [] -> List.rev acc (* TODO: flag failure? *) + | x::xs' -> if Nat_big_num.equal (natural_of_byte x)(Nat_big_num.of_int 0) then List.rev acc else null_terminated_list (x::acc) xs' + )) + +let pp_debug_str_entry (str: char list) (n: Nat_big_num.num):string= + ((match mydrop n str with + | None -> "strp beyond .debug_str extent" + | Some xs -> string_of_bytes (null_terminated_list [] xs) + )) + +(** operations: pp and parsing *) + +let pp_operation_argument_value (oav:operation_argument_value) : string= + ((match oav with + | OAV_natural n -> pphex n + | OAV_integer n -> Nat_big_num.to_string n + | OAV_block( n, bs) -> pphex n ^ (" " ^ ppbytes + instance_Show_Show_Missing_pervasives_byte_dict bs) + )) + +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" + )) + +let pp_operation (op: operation) : string= + (op.op_string ^ (" " ^ (myconcat " " (Lem_list.map pp_operation_argument_value op.op_argument_values) ^ (" (" ^ (pp_operation_semantics op.op_semantics ^ ")"))))) + +let pp_operations (ops: operation list) : string= + (myconcat "; " (Lem_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:parse_context ->(operation_argument_value)parse_result= + ((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 n pc'))) + )) + +(*val parse_operation : p_context -> compilation_unit_header -> parser (maybe operation)*) +let parse_operation c cuh pc:((operation)option)parse_result= + ((match parse_uint8 pc with + | PR_fail( s, pc') -> PR_success( None, pc) + | PR_success( code, pc') -> + (match lookup_aBcd_acd + instance_Basic_classes_Eq_Num_natural_dict code operation_encodings with + | None -> PR_fail( ("encoding not found: " ^ pphex code), pc) + | Some (s,oats,opsem) -> + let ps = (Lem_list.map (parser_of_operation_argument_type c cuh) oats) in + (pr_post_map + (parse_parser_list ps) + (fun oavs -> Some { op_code = code; op_string = s; op_argument_values = oavs; op_semantics = opsem }) + ) + pc' + ) + )) + +(*val parse_operations : p_context -> compilation_unit_header -> parser (list operation)*) +let parse_operations c cuh:parse_context ->((operation)list)parse_result= + (parse_list (parse_operation c cuh)) + +(*val parse_and_pp_operations : p_context -> compilation_unit_header -> list byte -> string*) +let parse_and_pp_operations c cuh bs:string= + (let pc = ({pc_bytes = bs; pc_offset =(Nat_big_num.of_int 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 not ((listEqualBy (=) pc'.pc_bytes [])) then " Warning: extra non-parsed bytes" else "") + )) + + +(** attribute values: pp and parsing *) + +(*val pp_attribute_value : p_context -> compilation_unit_header -> list byte -> natural (*attribute tag*) -> attribute_value -> string*) +let pp_attribute_value c cuh str at av:string= + ((match av with + | AV_addr x -> "AV_addr " ^ pphex x + | AV_block( n, bs) -> "AV_block " ^ (Nat_big_num.to_string n ^ (" " ^ (ppbytes + instance_Show_Show_Missing_pervasives_byte_dict bs + ^ (if Nat_big_num.equal at (attribute_encode "DW_AT_location") then " " ^ parse_and_pp_operations c cuh bs else "")))) + | AV_constantN( n, bs) -> "AV_constantN " ^ (Nat_big_num.to_string n ^ (" " ^ ppbytes + instance_Show_Show_Missing_pervasives_byte_dict bs)) + | AV_constant_SLEB128 i -> "AV_constant_SLEB128 " ^ Nat_big_num.to_string i + | AV_constant_ULEB128 n -> "AV_constant_ULEB128 " ^ Nat_big_num.to_string n + | AV_exprloc( n, bs) -> "AV_exprloc " ^ (Nat_big_num.to_string n ^ (" " ^ (ppbytes + instance_Show_Show_Missing_pervasives_byte_dict bs + ^ (" " ^ parse_and_pp_operations c cuh bs)))) + | AV_flag b -> "AV_flag " ^ string_of_bool 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_bytes bs + | AV_strp n -> "AV_sec_offset " ^ (pphex n ^ (" " + ^ pp_debug_str_entry str n)) + )) + + +(*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:parse_context ->(attribute_value)parse_result= +( +(* address*)if Nat_big_num.equal 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 Nat_big_num.equal n (attribute_form_encode "DW_FORM_block1") then + (fun pc -> pr_bind (parse_uint8 pc) (fun n pc' -> + pr_map (fun bs -> AV_block( n, bs)) (parse_n_bytes n pc'))) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_block2") then + (fun pc -> pr_bind (parse_uint16 c pc) (fun n pc' -> + pr_map (fun bs -> AV_block( n, bs)) (parse_n_bytes n pc'))) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_block4") then + (fun pc -> pr_bind (parse_uint32 c pc) (fun n pc' -> + pr_map (fun bs -> AV_block( n, bs)) (parse_n_bytes n pc'))) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_block") then + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> + pr_map (fun bs -> AV_block( n, bs)) (parse_n_bytes n pc'))) +(* constant *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_data1") then + pr_map2 (fun bs -> AV_block((Nat_big_num.of_int 1), bs)) (parse_n_bytes(Nat_big_num.of_int 1)) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_data2") then + pr_map2 (fun bs -> AV_block((Nat_big_num.of_int 2), bs)) (parse_n_bytes(Nat_big_num.of_int 2)) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_data4") then + pr_map2 (fun bs -> AV_block((Nat_big_num.of_int 4), bs)) (parse_n_bytes(Nat_big_num.of_int 4)) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_data8") then + pr_map2 (fun bs -> AV_block((Nat_big_num.of_int 8), bs)) (parse_n_bytes(Nat_big_num.of_int 8)) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_sdata") then + pr_map2 (fun i -> AV_constant_SLEB128 i) parse_SLEB128 + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_udata") then + pr_map2 (fun n -> AV_constant_ULEB128 n) parse_ULEB128 +(* exprloc *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_exprloc") then + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> + pr_map (fun bs -> AV_exprloc( n, bs)) (parse_n_bytes n pc'))) +(* flag *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_flag") then + pr_map2 (fun n -> AV_flag (not (Nat_big_num.equal n(Nat_big_num.of_int 0)))) (parse_uint8) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_flag_present") then + pr_map2 (fun () -> AV_flag true) (pr_return ()) +(* lineptr, loclistptr, macptr, rangelistptr *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_sec_offset") then + pr_map2 (fun n -> AV_sec_offset n) (parse_uintDwarfN c cuh.cuh_dwarf_format) +(* reference - first type *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref1") then + pr_map2 (fun n -> AV_ref n) (parse_uint8) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref2") then + pr_map2 (fun n -> AV_ref n) (parse_uint16 c) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref4") then + pr_map2 (fun n -> AV_ref n) (parse_uint32 c) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref8") then + pr_map2 (fun n -> AV_ref n) (parse_uint64 c) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref_udata") then + pr_map2 (fun n -> AV_ref n) parse_ULEB128 +(* reference - second type *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref_addr") then + pr_map2 (fun n -> AV_ref_addr n) (parse_uintDwarfN c cuh.cuh_dwarf_format) +(* reference - third type *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_ref_sig8") then + pr_map2 (fun n -> AV_ref_sig8 n) (parse_uint64 c) +(* string *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_string") then + pr_map2 (fun bs -> AV_string bs) parse_string + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_strp") then + pr_map2 (fun n -> AV_strp n) (parse_uintDwarfN c cuh.cuh_dwarf_format) +(* indirect (cycle detection) *) + else if Nat_big_num.equal n (attribute_form_encode "DW_FORM_indirect") then + failwith "DW_FORM_INDIRECT cycle" +(* unknown *) + else + failwith "parser_of_attribute_form_non_indirect: unknown attribute form") + + +let parser_of_attribute_form c cuh n:parse_context ->(attribute_value)parse_result= + (if Nat_big_num.equal 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) ) + else + parser_of_attribute_form_non_indirect c cuh n) + +(** attribute find *) + +let find_name str ats : string option= + (myfindmaybe + (fun (((at: Nat_big_num.num), (af: Nat_big_num.num)), ((pos: Nat_big_num.num),(av:attribute_value))) -> + if Nat_big_num.equal (attribute_encode "DW_AT_name") at then + let name1 = + ((match av with + | AV_string bs -> string_of_bytes bs + | AV_strp n -> pp_debug_str_entry str n + | _ -> "av_name AV not understood" + )) in + Some name1 + else + None) + ats) + +let find_name_of_die str die1 : string option= + (let ats = (Lem_list.list_combine + die1.die_abbreviation_declaration.ad_attribute_specifications + die1.die_attribute_values) in + find_name str ats) + +let find_attribute_value (an: string) (die1:die) : attribute_value option= + (let at = (attribute_encode an) in + let ats = (Lem_list.list_combine + die1.die_abbreviation_declaration.ad_attribute_specifications + die1.die_attribute_values) in + myfindmaybe + (fun (((at': Nat_big_num.num), (af: Nat_big_num.num)), ((pos: Nat_big_num.num),(av:attribute_value))) -> + if Nat_big_num.equal at' at then Some av else None) + ats) + +(** compilation unit header: pp and parsing *) + +let pp_dwarf_format df:string= ((match df with Dwarf32 -> "(32-bit)" | Dwarf64 -> "(64-bit)" )) + +let pp_unit_header (s:string) (x:compilation_unit_header) : string= + (" " ^ (s ^ (" Unit @ offset " ^ (pphex x.cuh_offset ^ (":\n" + ^ (" Length: " ^ (pphex x.cuh_unit_length ^ (" " ^ (pp_dwarf_format x.cuh_dwarf_format ^ ("\n" + ^ (" Version: " ^ (Nat_big_num.to_string x.cuh_version ^ ("\n" + ^ (" Abbrev Offset: " ^ (pphex x.cuh_debug_abbrev_offset ^ ("\n" + ^ (" Pointer Size: " ^ (Nat_big_num.to_string 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 : (dwarf_format * Nat_big_num.num) parser= + (fun (pc: parse_context) -> + pr_bind (parse_uint32 c pc) (fun x pc' -> + if Nat_big_num.less x (natural_of_hex "0xfffffff0") then PR_success( (Dwarf32,x), pc') + else if not (Nat_big_num.equal 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, x'), pc')))) + + +let parse_compilation_unit_header c : compilation_unit_header parser= + (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')))) -> + { + cuh_offset = offset; + cuh_dwarf_format = df; + cuh_unit_length = ul; + cuh_version = v; + cuh_debug_abbrev_offset = dao; + cuh_address_size = 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 : type_unit_header parser= + (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 = ts; + tuh_type_offset = 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) +*) + +let pp_pos pos:string= ("<" ^ (pphex pos ^">")) + +let indent_level (level: Nat_big_num.num):string= (Xstring.implode (replicate0 ( Nat_big_num.mul(Nat_big_num.of_int 3) level) ' ')) + +let pp_die_attribute c (cuh:compilation_unit_header) (str : char list) (level: Nat_big_num.num) (((at: Nat_big_num.num), (af: Nat_big_num.num)), ((pos: Nat_big_num.num),(av:attribute_value))) : string= + (indent_level ( Nat_big_num.add level(Nat_big_num.of_int 1)) ^ (pp_pos pos ^ (" " + ^ (pp_attribute_encoding at ^ (" : " + ^ ("(" ^ (pp_attribute_form_encoding af ^ (") " + ^ (pp_attribute_value c cuh str at av + ^ "\n"))))))))) + +(*val pp_die : p_context -> compilation_unit_header -> list byte -> natural -> bool -> die -> string*) +let rec pp_die c cuh str level (pp_children:bool) die1:string= + (indent_level level ^ ("<" ^ (Nat_big_num.to_string level ^ (">" + ^ (pp_pos die1.die_offset + ^ (": Abbrev Number: " ^ (Nat_big_num.to_string die1.die_abbreviation_code + ^ (" (" ^ (pp_tag_encoding die1.die_abbreviation_declaration.ad_tag ^(")\n" + ^ +(let ats = (Lem_list.list_combine + die1.die_abbreviation_declaration.ad_attribute_specifications + die1.die_attribute_values) in + (myconcat "" (Lem_list.map (pp_die_attribute c cuh str level) ats)) + ^ +(if pp_children then myconcat "" (Lem_list.map (pp_die c cuh str ( Nat_big_num.add level(Nat_big_num.of_int 1)) pp_children) die1.die_children) else "")))))))))))) + +(*val pp_die_abbrev : p_context -> compilation_unit_header -> list byte -> natural -> bool -> (list die) -> die -> string*) +let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die1:string= + (indent_level level + ^ (pp_tag_encoding die1.die_abbreviation_declaration.ad_tag + ^ (" (" ^ (pp_pos die1.die_offset ^ (") " +(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) + ^ +(let ats = (Lem_list.list_combine + die1.die_abbreviation_declaration.ad_attribute_specifications + die1.die_attribute_values) in + ((match find_name str ats with Some s -> s | None -> "-" )) + ^ (" : " ^ (myconcat " : " (Lem_list.map (fun die' -> pp_tag_encoding die'.die_abbreviation_declaration.ad_tag) parents) + ^ ("\n" + ^ + +( (*(myconcat "" (List.map (pp_die_abbrev_attribute c cuh str) ats))*)if pp_children then myconcat "" (Lem_list.map (pp_die_abbrev c cuh str ( Nat_big_num.add level(Nat_big_num.of_int 1)) pp_children (die1::parents)) die1.die_children) else "")))))))))) + + + +(*val parse_die : p_context -> list byte -> compilation_unit_header -> (natural->abbreviation_declaration) -> parser (maybe die)*) +let rec parse_die c str cuh find_abbreviation_declaration:parse_context ->((die)option)parse_result= + (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' -> + if Nat_big_num.equal abbreviation_code(Nat_big_num.of_int 0) then PR_success( None, 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 = (Lem_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 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( (Some ( let die1 = + ({ + 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 cuh str 999 die) in *)die1)), pc'''))))) + +let has_attribute (an: string) (die1: die) : bool= + (Lem_list.elem instance_Basic_classes_Eq_Num_natural_dict + (attribute_encode an) + (Lem_list.map fst die1.die_abbreviation_declaration.ad_attribute_specifications)) + + +(** compilation units: pp and parsing *) + +let pp_compilation_unit c (debug_str_section_body: char list) cu:string= + + ("*** 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(Nat_big_num.of_int 0) true cu.cu_die + ^ "\n")))))) + +let pp_compilation_units c debug_string_section_body (compilation_units1: compilation_unit list) : string= + (myconcat "" (Lem_list.map (pp_compilation_unit c debug_string_section_body) compilation_units1)) + + +let pp_compilation_unit_abbrev c (debug_str_section_body: char list) cu:string= + (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(Nat_big_num.of_int 0) true [] cu.cu_die) + +let pp_compilation_units_abbrev c debug_string_section_body (compilation_units1: compilation_unit list) : string= + (myconcat "" (Lem_list.map (pp_compilation_unit_abbrev c debug_string_section_body) compilation_units1)) + + +let parse_compilation_unit c (debug_str_section_body: char list) (debug_abbrev_section_body: char list) : ( compilation_unit option) parser= + (fun (pc:parse_context) -> + + if (listEqualBy (=) pc.pc_bytes []) then PR_success( None, pc) else + + let (cuh, pc') = + + ((match parse_compilation_unit_header c pc with + | PR_fail( s, pc') -> failwith ("parse_cuh_header fail: " ^ pp_parse_fail s pc') + | PR_success( cuh, pc') -> (cuh,pc') + )) in + + let _ = (my_debug4 (pp_compilation_unit_header cuh)) in + + let pc_abbrev = ({pc_bytes = ((match mydrop cuh.cuh_debug_abbrev_offset debug_abbrev_section_body with Some bs -> bs | None -> failwith "mydrop of debug_abbrev" )); pc_offset = (cuh.cuh_debug_abbrev_offset) }) in + + let abbreviations_table1 = + ((match parse_abbreviations_table c pc_abbrev with + | PR_fail( s, pc_abbrev') -> failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') + | PR_success( at, pc_abbrev') -> at + )) in + + let _ = (my_debug4 (pp_abbreviations_table abbreviations_table1)) in + + let find_abbreviation_declaration (ac:Nat_big_num.num) : abbreviation_declaration= + (let _ = (my_debug4 ("find_abbreviation_declaration "^pphex ac)) in + myfindNonPure (fun ad -> Nat_big_num.equal ad.ad_abbreviation_code ac) abbreviations_table1) in + + let _ = (my_debug3 (pp_abbreviations_table abbreviations_table1)) in + + (match parse_die c debug_str_section_body cuh find_abbreviation_declaration pc' with + | PR_fail( s, pc'') -> failwith ("parse_die fail: " ^ pp_parse_fail s pc'') + | PR_success( (None), pc'') -> failwith ("parse_die returned Nothing: " ^ pp_parse_context pc'') + | PR_success( (Some die1), pc'') -> + let cu = + ({ + cu_header = cuh; + cu_abbreviations_table = abbreviations_table1; + cu_die = die1; + }) in + PR_success( (Some cu), pc'') + )) + +let parse_compilation_units c (debug_str_section_body: char list) (debug_abbrev_section_body: char list): ( compilation_unit list) parser= + + (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: char list) tu:string= + (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(Nat_big_num.of_int 0) true tu.tu_die)) + +let pp_type_units c debug_string_section_body (type_units1: type_unit list) : string= + (myconcat "" (Lem_list.map (pp_type_unit c debug_string_section_body) type_units1)) + + +let parse_type_unit c (debug_str_section_body: char list) (debug_abbrev_section_body: char list) : ( type_unit option) parser= + (fun (pc:parse_context) -> + + if (listEqualBy (=) pc.pc_bytes []) then PR_success( None, pc) else + + let (tuh, pc') = + ((match parse_type_unit_header c pc with + | PR_fail( s, pc') -> failwith ("parse_tuh_header fail: " ^ pp_parse_fail s pc') + | PR_success( tuh, pc') -> (tuh,pc') + )) 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 mydrop n debug_abbrev_section_body with Some bs -> bs | None -> failwith "mydrop of debug_abbrev" )); pc_offset = n }) in + + let abbreviations_table1 = + ((match parse_abbreviations_table c pc_abbrev with + | PR_fail( s, pc_abbrev') -> failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') + | PR_success( at, pc_abbrev') -> at + )) in + + let _ = (my_debug4 (pp_abbreviations_table abbreviations_table1)) in + + let find_abbreviation_declaration (ac:Nat_big_num.num) : abbreviation_declaration= + (let _ = (my_debug4 ("find_abbreviation_declaration "^pphex ac)) in + myfindNonPure (fun ad -> Nat_big_num.equal ad.ad_abbreviation_code ac) abbreviations_table1) in + + let _ = (my_debug3 (pp_abbreviations_table abbreviations_table1)) in + + (match parse_die c debug_str_section_body tuh.tuh_cuh find_abbreviation_declaration pc' with + | PR_fail( s, pc'') -> failwith ("parse_die fail: " ^ pp_parse_fail s pc'') + | PR_success( (None), pc'') -> failwith ("parse_die returned Nothing: " ^ pp_parse_context pc'') + | PR_success( (Some die1), pc'') -> + let tu = + ({ + tu_header = tuh; + tu_abbreviations_table = abbreviations_table1; + tu_die = die1; + }) in + PR_success( (Some tu), pc'') + )) + +let parse_type_units c (debug_str_section_body: char list) (debug_abbrev_section_body: char list): ( type_unit list) parser= + + (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 <End of list> + 00000039 000000000040017c 0000000000400180 (DW_OP_lit1; DW_OP_stack_value) +*) + +let pp_location_list_entry c (cuh:compilation_unit_header) (offset:Nat_big_num.num) (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:Nat_big_num.num) (x:base_address_selection_entry) : string= + (" " ^ (pphex offset + ^ (" " ^ (pphex x.base_address + ^ "\n")))) + +let pp_location_list_item c (cuh: compilation_unit_header) (offset: Nat_big_num.num) (x:location_list_item):string= + ((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 + )) + +let pp_location_list c (cuh: compilation_unit_header) ((offset:Nat_big_num.num), (llis: location_list_item list)):string= + (myconcat "" (Lem_list.map (pp_location_list_item c cuh offset) llis)) +(* ^ " " ^ pphex offset ^ " <End of list>\n"*) + +let pp_loc c (cuh: compilation_unit_header) (lls: location_list list):string= + (" Offset Begin End Expression\n" + ^ myconcat "" (Lem_list.map (pp_location_list c cuh) lls)) + +(* Note that this is just pp'ing the raw location list data - Sectoin +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) : ( location_list_item option) parser= + (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: Nat_big_num.num),(a2:Nat_big_num.num)) pc' -> + let _ = (my_debug4 ("offset="^(pphex pc.pc_offset ^ (" begin=" ^ (pphex a1 ^ (" end=" ^ pphex a2)))))) in + if Nat_big_num.equal a1(Nat_big_num.of_int 0) &&Nat_big_num.equal a2(Nat_big_num.of_int 0) then + PR_success( None, pc') + else if Nat_big_num.equal a1 (max_address cuh.cuh_address_size) then + let x = (LLI_base { (*base_offset=pc.pc_offset;*) base_address=a1 }) in + PR_success( (Some x (*(pc.pc_offset, x)*)), pc') + else + pr_bind (parse_uint16 c pc') (fun n pc'' -> + pr_post_map1 + (parse_n_bytes n pc'') + (fun bs -> + let x = + (LLI_lle { + (*lle_offset = pc.pc_offset;*) + lle_beginning_address_offset = a1; + lle_ending_address_offset = a2; + lle_single_location_description = bs; + }) in + Some x (*(pc.pc_offset, x)*)) + ) + )) + +let parse_location_list c cuh : ( location_list option) parser= + (fun (pc: parse_context) -> + if (listEqualBy (=) pc.pc_bytes []) then + PR_success( None, pc) + else + pr_post_map1 + (parse_list (parse_location_list_item c cuh) pc) + (fun llis -> (Some (pc.pc_offset, llis)))) + +let parse_location_list_list c cuh : location_list_list parser= + (parse_list (parse_location_list c cuh)) + +let find_location_list dloc n : location_list= + (myfindNonPure (fun (n',_)->Nat_big_num.equal 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_address1: Nat_big_num.num) (llis: location_list_item list) : (Nat_big_num.num * Nat_big_num.num * single_location_description) list= + ((match llis with + | [] -> [] + | LLI_base base::llis' -> interpret_location_list base.base_address llis' + | LLI_lle lle :: llis' -> (Nat_big_num.add base_address1 lle.lle_beginning_address_offset,Nat_big_num.add base_address1 lle.lle_ending_address_offset, lle.lle_single_location_description) :: interpret_location_list base_address1 llis' + )) + + +(** range lists, pp and parsing *) + +(* readelf example +Contents of the .debug_aranges section: + + Length: 44 + Version: 2 + Offset into .debug_info: 0x0 + Pointer Size: 8 + Segment Size: 0 + + Address Length + 00000000100000e8 0000000000000090 + 0000000000000000 0000000000000000 + Length: 44 + Version: 2 + Offset into .debug_info: 0x1de + Pointer Size: 8 + Segment Size: 0 +*) + +let pp_range_list_entry c (cuh:compilation_unit_header) (offset:Nat_big_num.num) (x:range_list_entry) : string= + (" " ^ (pphex offset + ^ (" " ^ (pphex x.rle_beginning_address_offset + ^ (" " ^ (pphex x.rle_ending_address_offset + ^ "\n")))))) + +let pp_range_list_item c (cuh: compilation_unit_header) (offset: Nat_big_num.num) (x:range_list_item):string= + ((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 + )) + +let pp_range_list c (cuh: compilation_unit_header) ((offset:Nat_big_num.num), (rlis: range_list_item list)):string= + (myconcat "" (Lem_list.map (pp_range_list_item c cuh offset) rlis)) +(* ^ " " ^ pphex offset ^ " <End of list>\n"*) + +let pp_ranges c (cuh: compilation_unit_header) (rls: range_list list):string= + (" Offset Begin End Expression\n" + ^ myconcat "" (Lem_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) : ( range_list_item option) parser= + (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: Nat_big_num.num),(a2:Nat_big_num.num)) pc' -> + let _ = (my_debug4 ("offset="^(pphex pc.pc_offset ^ (" begin=" ^ (pphex a1 ^ (" end=" ^ pphex a2)))))) in + if Nat_big_num.equal a1(Nat_big_num.of_int 0) &&Nat_big_num.equal a2(Nat_big_num.of_int 0) then + PR_success( None, pc') + else if Nat_big_num.equal a1 (max_address cuh.cuh_address_size) then + let x = (RLI_base { base_address=a1 }) in + PR_success( (Some x), pc') + else + let x = + (RLI_rle { + rle_beginning_address_offset = a1; + rle_ending_address_offset = a2; + }) in + PR_success( (Some x (*(pc.pc_offset, x)*)), pc') + )) + +let parse_range_list c cuh : ( range_list option) parser= + (fun (pc: parse_context) -> + if (listEqualBy (=) pc.pc_bytes []) then + PR_success( None, pc) + else + pr_post_map1 + (parse_list (parse_range_list_item c cuh) pc) + (fun rlis -> (Some (pc.pc_offset, rlis)))) + +let parse_range_list_list c cuh : range_list_list parser= + (parse_list (parse_range_list c cuh)) + +let find_range_list dranges n : range_list= + (myfindNonPure (fun (n',_)->Nat_big_num.equal 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_address1: Nat_big_num.num) (rlis: range_list_item list) : (Nat_big_num.num * Nat_big_num.num) list= + ((match rlis with + | [] -> [] + | RLI_base base::rlis' -> interpret_range_list base.base_address rlis' + | RLI_rle rle :: rlis' -> (Nat_big_num.add base_address1 rle.rle_beginning_address_offset,Nat_big_num.add base_address1 rle.rle_ending_address_offset) :: interpret_range_list base_address1 rlis' + )) + +(** 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:string= (pphex a) +let pp_cfa_block dict_Show_Show_a b:string= (ppbytes + dict_Show_Show_a b) +let pp_cfa_delta d:string= (pphex d) +(*let pp_cfa_offset n = pphex n +let pp_cfa_register r = show r*) +let pp_cfa_sfoffset dict_Show_Show_a i:string= ( + dict_Show_Show_a.show_method i) + +let pp_cfa_register dict_Show_Show_a r:string= ("r"^ + dict_Show_Show_a.show_method r) (*TODO: arch-specific register names *) + +let pp_cfa_offset (i:Nat_big_num.num):string= (if Nat_big_num.equal i(Nat_big_num.of_int 0) then "" else if Nat_big_num.less i(Nat_big_num.of_int 0) then Nat_big_num.to_string i else "+" ^ Nat_big_num.to_string i) + +let pp_cfa_rule (cr:cfa_rule) : string= + ((match cr with + | CR_undefined -> "u" + | CR_register( r, i) -> pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ pp_cfa_offset i + | CR_expression bs -> "exp" + )) + +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 + instance_Show_Show_Num_natural_dict r + | RR_expression bs -> "exp" + | RR_val_expression bs -> "val(exp)" + | RR_architectural -> "" + )) + + + +let pp_call_frame_instruction i:string= + ((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 + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_offset ( n)))) + | DW_CFA_restore r -> "DW_CFA_restore" ^ (" " ^ pp_cfa_register + instance_Show_Show_Num_natural_dict 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 + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_offset ( n)))) + | DW_CFA_restore_extended r -> "DW_CFA_restore_extended" ^ (" " ^ pp_cfa_register + instance_Show_Show_Num_natural_dict r) + | DW_CFA_undefined r -> "DW_CFA_undefined" ^ (" " ^ pp_cfa_register + instance_Show_Show_Num_natural_dict r) + | DW_CFA_same_value r -> "DW_CFA_same_value" ^ (" " ^ pp_cfa_register + instance_Show_Show_Num_natural_dict r) + | DW_CFA_register( r1, r2) -> "DW_CFA_register" ^ (" " ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r1 ^ (" " ^ pp_cfa_register + instance_Show_Show_Num_natural_dict 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 + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_offset ( n)))) + | DW_CFA_def_cfa_register r -> "DW_CFA_def_cfa_register" ^ (" " ^ pp_cfa_register + instance_Show_Show_Num_natural_dict r) + | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ (" " ^ pp_cfa_offset ( n)) + | DW_CFA_def_cfa_expression b -> "DW_CFA_def_cfa_expression" ^ (" " ^ pp_cfa_block + instance_Show_Show_Missing_pervasives_byte_dict b) + | DW_CFA_expression( r, b) -> "DW_CFA_expression" ^ (" " ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_block + instance_Show_Show_Missing_pervasives_byte_dict b))) + | DW_CFA_offset_extended_sf( r, i) -> "DW_CFA_offset_extended_sf" ^ (" " ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_sfoffset + instance_Show_Show_Num_integer_dict i))) + | DW_CFA_def_cfa_sf( r, i) -> "DW_CFA_def_cfa_sf" ^ (" " ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_sfoffset + instance_Show_Show_Num_integer_dict i))) + | DW_CFA_def_cfa_offset_sf i -> "DW_CFA_def_cfa_offset_sf" ^ (" " ^ pp_cfa_sfoffset + instance_Show_Show_Num_integer_dict i) + | DW_CFA_val_offset( r, n) -> "DW_CFA_val_offset" ^ (" " ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_offset ( n)))) + | DW_CFA_val_offset_sf( r, i) -> "DW_CFA_val_offset_sf" ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_sfoffset + instance_Show_Show_Num_integer_dict i)) + | DW_CFA_val_expression( r, b) -> "DW_CFA_val_expression" ^ (" " ^ (pp_cfa_register + instance_Show_Show_Num_natural_dict r ^ (" " ^ pp_cfa_block + instance_Show_Show_Missing_pervasives_byte_dict b))) + | DW_CFA_unknown bt -> "DW_CFA_unknown" ^ (" " ^ hex_string_of_byte bt) + )) + +let pp_call_frame_instructions is:string= (myconcat "" (Lem_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) : call_frame_argument_value parser= + ((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 n pc'))) + )) + +let parse_call_frame_instruction c cuh : ( call_frame_instruction option) parser= + (fun pc -> + (match pc.pc_bytes with + | [] -> PR_success( None, pc) + | b::bs' -> + let pc' = ({ pc_bytes = bs'; pc_offset = (Nat_big_num.add pc.pc_offset(Nat_big_num.of_int 1)) }) in + let ch = (Uint32.of_int (Char.code b)) in + let high_bits = (Uint32.logand ch (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 192)))) in + let low_bits = (Nat_big_num.of_string (Uint32.to_string (Uint32.logand ch (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 63)))))) in + if high_bits = Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)) then + (match lookup_abCde_de + instance_Basic_classes_Eq_Num_natural_dict low_bits call_frame_instruction_encoding with + | Some ((args: call_frame_argument_type list), result) -> + let ps = (Lem_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( (Some cfi), pc'') -> PR_success( (Some cfi), pc'') + | PR_success( (None), pc'') -> failwith "bad call frame instruction argument 1" + | PR_fail( s, pc'') -> failwith "bad call frame instruction argument 2" + ) + | None -> + (*Assert_extra.failwith ("can't parse " ^ show b ^ " as call frame instruction")*) + PR_success( (Some (DW_CFA_unknown b)), pc') + ) + else + if high_bits = Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 64)) then + PR_success( (Some (DW_CFA_advance_loc low_bits)), pc') + else if high_bits = Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 192)) then + PR_success( (Some (DW_CFA_restore 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( (Some (DW_CFA_offset( low_bits, n))), pc'') + | PR_success( _, pc'') -> failwith "bad call frame instruction argument 3" + | PR_fail( s, pc'') -> failwith "bad call frame instruction argument 4" + ) + )) + +let parse_call_frame_instructions c cuh : ( call_frame_instruction list) parser= + (parse_list (parse_call_frame_instruction c cuh)) + +(*val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> list byte -> string*) +let parse_and_pp_call_frame_instructions c cuh bs:string= + (let pc = ({pc_bytes = bs; pc_offset =(Nat_big_num.of_int 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 not ((listEqualBy (=) pc'.pc_bytes [])) then " Warning: extra non-parsed bytes" else "") + )) + + + +let pp_call_frame_instructions' c cuh bs:string= +( + (* ppbytes bs ^ "\n" *)parse_and_pp_call_frame_instructions c cuh bs) + + + +let pp_cie c cuh cie1:string= + (pphex cie1.cie_offset + ^ (" " ^ (pphex cie1.cie_length + ^ (" " ^ (pphex cie1.cie_id + ^ (" CIE\n" + ^ (" Version: " ^ (Nat_big_num.to_string cie1.cie_version ^ ("\n" + ^ (" Augmentation: \""^ (string_of_string (Xstring.implode (Lem_list.map (fun x-> x) cie1.cie_augmentation)) ^ ("\"\n" + ^ (" Code alignment factor: " ^ (Nat_big_num.to_string cie1.cie_code_alignment_factor ^ ("\n" + ^ (" Data alignment factor: " ^ (Nat_big_num.to_string cie1.cie_data_alignment_factor ^ ("\n" + ^ (" Return address column: " ^ (Nat_big_num.to_string cie1.cie_return_address_register ^ ("\n" + ^ ("\n" + ^ (ppbytes instance_Show_Show_Missing_pervasives_byte_dict cie1.cie_initial_instructions_bytes ^ ("\n" + ^ pp_call_frame_instructions cie1.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 fde1:string= + (pphex fde1.fde_offset + ^ (" " ^ (pphex fde1.fde_length + ^ (" " ^ (pphex fde1.fde_cie_pointer (* not what this field of readelf output is *) + ^ (" FDE" + ^ (" cie=" ^ (pphex fde1.fde_cie_pointer (* duplicated?? *) + ^ (" pc=" ^ ((match fde1.fde_initial_location_segment_selector with None -> "" | Some segment_selector -> "("^(pphex segment_selector^")") ) ^ (pphex fde1.fde_initial_location_address ^ (".." ^ (pphex ( Nat_big_num.add fde1.fde_initial_location_address fde1.fde_address_range) ^ ("\n" + ^ (ppbytes instance_Show_Show_Missing_pervasives_byte_dict fde1.fde_instructions_bytes ^ ("\n" + ^ pp_call_frame_instructions fde1.fde_instructions)))))))))))))))) + +let pp_frame_info_element c cuh fie:string= + ((match fie with + | FIE_cie cie1 -> pp_cie c cuh cie1 + | FIE_fde fde1 -> pp_fde c cuh fde1 + )) + +let pp_frame_info c cuh fi:string= + ("Contents of the .debug_frame section:\n\n" + ^ (myconcat "\n" (Lem_list.map (pp_frame_info_element c cuh) fi) + ^ "\n")) + + + +let rec find_cie fi cie_id1:cie= + ((match fi with + | [] -> failwith "find_cie: cie_id not found" + | FIE_fde _ :: fi' -> find_cie fi' cie_id1 + | FIE_cie cie1 :: fi' -> if Nat_big_num.equal cie_id1 cie1.cie_offset then cie1 else find_cie fi' cie_id1 + )) + +let parse_initial_location c cuh mss mas' : (( Nat_big_num.num option) * Nat_big_num.num) parser= +( (*(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 Some n -> n | None ->Nat_big_num.of_int 0 ))) + (parse_uint_address_size c ((match mas' with Some n -> n | None -> cuh.cuh_address_size )))) + + +let parse_call_frame_instruction_bytes offset' ul:parse_context ->((char)list)parse_result= + (fun (pc: parse_context) -> + parse_n_bytes ( Nat_big_num.sub_nat ul ( Nat_big_num.sub_nat pc.pc_offset offset')) pc) + +let parse_frame_info_element c cuh (fi: frame_info_element list) : frame_info_element parser= + (parse_dependent + (pr_with_pos + (parse_dependent_pair + (parse_unit_length c) + (fun (df,ul) -> + pr_with_pos + (parse_uintDwarfN c df) (* CIE_id (cie) or CIE_pointer (fde) *) + ))) + (fun (offset,((df,ul),(offset',cie_id1))) -> + if ( Nat_big_num.equal cie_id1 + (match df with + | Dwarf32 -> natural_of_hex "0xffffffff" + | Dwarf64 -> natural_of_hex "0xffffffffffffffff" + )) + then + (* parse cie *) + pr_post_map + (parse_pair + (parse_dependent_pair + parse_uint8 (* version *) + (fun v -> + parse_triple + parse_string (* augmentation *) + (if Nat_big_num.equal v(Nat_big_num.of_int 4) ||Nat_big_num.equal v(Nat_big_num.of_int 46) then pr_post_map parse_uint8 (fun i->Some i) else pr_return None) (* address_size *) + (if Nat_big_num.equal v(Nat_big_num.of_int 4) ||Nat_big_num.equal v(Nat_big_num.of_int 46) then pr_post_map parse_uint8 (fun i->Some i) else pr_return None))) (* 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 =(Nat_big_num.of_int 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_id1; + 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, _) -> failwith s + ) + ) + + else + (* parse fde *) + let cie1 = (find_cie fi cie_id1) in + let _ = (my_debug4 (pp_cie c cuh cie1)) in + pr_post_map + (parse_triple + (parse_initial_location c cuh cie1.cie_segment_size cie1.cie_address_size) (*(segment selector and target address)*) + (parse_uint_address_size c ((match cie1.cie_address_size with Some n -> n | None -> cuh.cuh_address_size ))) (* address_range (target address) *) + (parse_call_frame_instruction_bytes offset' ul) + ) + (fun ( (ss,adr), (ar, bs)) -> + let pc = ({pc_bytes = bs; pc_offset =(Nat_big_num.of_int 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_id1; + 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, _) -> failwith s + ) + ) + )) + +(* 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:parse_context ->('a list)parse_result= + (fun pc -> + if (listEqualBy (=) pc.pc_bytes []) then + PR_success( (List.rev 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_context ->('a list)parse_result= (parse_dependent_list' p1 []) + + +let parse_frame_info c cuh : frame_info parser= + +(parse_dependent_list (parse_frame_info_element c cuh)) + + +(** line numbers .debug_line, pp and parsing *) + +let pp_line_number_file_entry lnfe:string= + ("lnfe_path = " ^ (string_of_bytes lnfe.lnfe_path ^ ("\n" +^ ("lnfe_directory_index " ^ (Nat_big_num.to_string lnfe.lnfe_directory_index ^ ("\n" +^ ("lnfe_last_modification = " ^ (Nat_big_num.to_string lnfe.lnfe_last_modification ^ ("\n" +^ ("lnfe_length = " ^ (Nat_big_num.to_string lnfe.lnfe_length ^ "\n"))))))))))) + + +let pp_line_number_header lnh:string= + ("offset = " ^ (pphex lnh.lnh_offset ^ ("\n" +^ ("dwarf_format = " ^ (pp_dwarf_format lnh.lnh_dwarf_format ^ ("\n" +^ ("unit_length = " ^ (Nat_big_num.to_string lnh.lnh_unit_length ^ ("\n" +^ ("version = " ^ (Nat_big_num.to_string lnh.lnh_version ^ ("\n" +^ ("header_length = " ^ (Nat_big_num.to_string lnh.lnh_header_length ^ ("\n" +^ ("minimum_instruction_length = " ^ (Nat_big_num.to_string lnh.lnh_minimum_instruction_length ^ ("\n" +^ ("maximum_operations_per_instruction = " ^ (Nat_big_num.to_string lnh.lnh_maximum_operations_per_instruction ^ ("\n" +^ ("default_is_stmt = " ^ (string_of_bool lnh.lnh_default_is_stmt ^ ("\n" +^ ("line_base = " ^ (Nat_big_num.to_string lnh.lnh_line_base ^ ("\n" +^ ("line_range = " ^ (Nat_big_num.to_string lnh.lnh_line_range ^ ("\n" +^ ("opcode_base = " ^ (Nat_big_num.to_string lnh.lnh_opcode_base ^ ("\n" +^ ("standard_opcode_lengths = " ^ (string_of_list + instance_Show_Show_Num_natural_dict lnh.lnh_standard_opcode_lengths ^ ("\n" +^ ("include_directories = " ^ (myconcat ", " (Lem_list.map string_of_bytes lnh.lnh_include_directories) ^ ("\n" +^ ("file_names = \n\n" ^ (myconcat "\n" (Lem_list.map pp_line_number_file_entry lnh.lnh_file_names) ^ "\n"))))))))))))))))))))))))))))))))))))))))) + +let pp_line_number_operation lno:string= + ((match lno with + | DW_LNS_copy -> "DW_LNS_copy" + | DW_LNS_advance_pc n -> "DW_LNS_advance_pc" ^ (" " ^ Nat_big_num.to_string n) + | DW_LNS_advance_line i -> "DW_LNS_advance_line" ^ (" " ^ Nat_big_num.to_string i) + | DW_LNS_set_file n -> "DW_LNS_set_file" ^ (" " ^ Nat_big_num.to_string n) + | DW_LNS_set_column n -> "DW_LNS_set_column" ^ (" " ^ Nat_big_num.to_string 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" ^ (" " ^ Nat_big_num.to_string 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" ^ (" " ^ Nat_big_num.to_string n) + | DW_LNE_end_sequence -> "DW_LNE_end_sequence" + | DW_LNE_set_address n -> "DW_LNE_set_address" ^ (" " ^ pphex n) + | DW_LNE_define_file( s, n1, n2, n3) -> "DW_LNE_define_file" ^ (" " ^ (string_of_list + instance_Show_Show_Missing_pervasives_byte_dict s ^ (" " ^ (Nat_big_num.to_string n1 ^ (" " ^ (Nat_big_num.to_string n2 ^ (" " ^ Nat_big_num.to_string n3))))))) + | DW_LNE_set_discriminator n -> "DW_LNE_set_discriminator" ^ (" " ^ Nat_big_num.to_string n) + | DW_LN_special n -> "DW_LN_special" ^ (" " ^ Nat_big_num.to_string n) + )) + +let pp_line_number_program lnp:string= + (pp_line_number_header lnp.lnp_header + ^ ("[" ^ (myconcat ", " (Lem_list.map pp_line_number_operation lnp.lnp_operations) ^ "]\n"))) + + + +let parse_line_number_file_entry : ( line_number_file_entry option) parser= + +(parse_dependent + (parse_non_empty_string) + (fun ms -> + (match ms with + | None -> + pr_return None + | Some s -> + pr_post_map + (parse_triple + parse_ULEB128 + parse_ULEB128 + parse_ULEB128 + ) + (fun (n1,(n2,n3)) -> + (Some + { + lnfe_path = s; + lnfe_directory_index = n1; + lnfe_last_modification = n2; + lnfe_length = n3; + } ) + ) + ) + )) + +let parse_line_number_header c : line_number_header parser= + (parse_dependent + ((pr_with_pos + (parse_unit_length c) )) + (fun (pos,(df,ul)) -> + parse_dependent + (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)))) -> + pr_post_map + (parse_triple + (pr_post_map (parse_n_bytes (Nat_big_num.sub_nat ob(Nat_big_num.of_int 1))) (Lem_list.map natural_of_byte)) (* 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 =(Nat_big_num.of_int 1) (*maxopi*); + lnh_default_is_stmt = (not (Nat_big_num.equal dis(Nat_big_num.of_int 0))); + lnh_line_base = lb; + lnh_line_range = lr; + lnh_opcode_base = ob; + lnh_standard_opcode_lengths = sols; + lnh_include_directories = ids; + lnh_file_names = fns; + } + ) + ) + ) + ) + +let parser_of_line_number_argument_type c (cuh: compilation_unit_header) (lnat: line_number_argument_type) : line_number_argument_value parser= + ((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) + )) + +let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_number_header) : line_number_operation parser= + (parse_dependent + parse_uint8 + (fun opcode -> + if Nat_big_num.equal opcode(Nat_big_num.of_int 0) then + (* parse extended opcode *) + parse_dependent + (parse_pair + parse_ULEB128 + parse_uint8) + (fun (size2,opcode') -> + (match lookup_aBcd_acd + instance_Basic_classes_Eq_Num_natural_dict opcode' line_number_extended_encodings with + | Some (_, arg_types, result) -> + let ps = (Lem_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 ) + | None -> + failwith ("parse_line_number_operation extended opcode not found: " ^ Nat_big_num.to_string opcode') + )) + (* 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 Nat_big_num.greater_equal opcode lnh.lnh_opcode_base then + (* parse special opcode *) + let adjusted_opcode = (Nat_big_num.sub_nat opcode lnh.lnh_opcode_base) in + pr_return (DW_LN_special adjusted_opcode) + else + (* parse standard opcode *) + (match lookup_aBcd_acd + instance_Basic_classes_Eq_Num_natural_dict opcode line_number_standard_encodings with + | Some (_, arg_types, result) -> + let ps = (Lem_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) + | None -> + failwith ("parse_line_number_operation standard opcode not found: " ^ Nat_big_num.to_string 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 *) + ))) + + +let parse_line_number_operations c (cuh:compilation_unit_header) (lnh:line_number_header) : ( line_number_operation list) parser= + (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) : line_number_program parser= + (parse_dependent + (parse_line_number_header c) + (fun lnh -> + let byte_count_of_operations = (Nat_big_num.sub_nat + lnh.lnh_unit_length ( Nat_big_num.add (Nat_big_num.add lnh.lnh_header_length(Nat_big_num.of_int 2)) ((match lnh.lnh_dwarf_format with Dwarf32 ->Nat_big_num.of_int 4 | Dwarf64 ->Nat_big_num.of_int 8 )))) 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; + }) + )) + +let parse_line_number_info c (d_line: char list) (cu: compilation_unit) : line_number_program= + (let f n= + (let d_line' = ((match mydrop n d_line with Some xs -> xs | None -> failwith "parse_line_number_info drop" )) in + let pc = ({ pc_bytes = d_line'; pc_offset = n}) in + (match parse_line_number_program c cu.cu_header pc with + | PR_success( lnp, pc') -> + (*let _ = print_endline (pp_line_number_program lnp) in*) + lnp + | PR_fail( s, pc') -> failwith ("parse_line_number_header failed: " ^ s) + )) in + (match find_attribute_value "DW_AT_stmt_list" cu.cu_die with + | Some (AV_sec_offset n) -> f n + | Some (AV_block( n, bs)) -> f (natural_of_bytes c.endianness bs) + (* a 32-bit MIPS example used a 4-byte AV_block not AV_sec_offset *) + | Some _ -> failwith "compilation unit DW_AT_stmt_list attribute was not an AV_sec_offset" + | _ -> failwith "compilation unit did not have a DW_AT_stmt_list attribute" + )) + + +let parse_line_number_infos c debug_line_section_body compilation_units1:(line_number_program)list= + + (Lem_list.map (parse_line_number_info c debug_line_section_body) compilation_units1) + +let pp_line_info li:string= + +(myconcat "\n" (Lem_list.map (pp_line_number_program) li)) + + +(** all dwarf info: pp and parsing *) + +let pp_dwarf d:string= + (let c : p_context = ({ endianness = (d.d_endianness) }) 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 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))))))))))) + + +let parse_dwarf c + (debug_info_section_body: char list) + (debug_abbrev_section_body: char list) + (debug_str_section_body: char list) + (debug_loc_section_body: char list) + (debug_ranges_section_body: char list) + (debug_frame_section_body: char list) + (debug_line_section_body: char list) + : dwarf= + + (let pc_info = ({pc_bytes = debug_info_section_body; pc_offset =(Nat_big_num.of_int 0) }) in + + let compilation_units1 = + ((match parse_compilation_units c debug_str_section_body debug_abbrev_section_body pc_info with + | PR_fail( s, pc_info') -> failwith ("parse_compilation_units: " ^ pp_parse_fail s pc_info') + | PR_success( cus, pc_info') -> cus + )) 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_units1) in cu.cu_header) in + + let pc_loc = ({pc_bytes = debug_loc_section_body; pc_offset =(Nat_big_num.of_int 0) }) in + + let loc = + ((match parse_location_list_list c cuh_default pc_loc with + | PR_fail( s, pc_info') -> failwith ("parse_location_list: " ^ pp_parse_fail s pc_info') + | PR_success( loc, pc_loc') -> loc + )) in + + let pc_ranges = ({pc_bytes = debug_ranges_section_body; pc_offset =(Nat_big_num.of_int 0) }) in + + let ranges = + ((match parse_range_list_list c cuh_default pc_ranges with + | PR_fail( s, pc_info') -> failwith ("parse_range_list: " ^ pp_parse_fail s pc_info') + | PR_success( r, pc_loc') -> r + )) in + + let pc_frame = ({pc_bytes = debug_frame_section_body; pc_offset =(Nat_big_num.of_int 0) }) in + + let fi = + (let _ = (my_debug5 ("debug_frame_section_body:\n" ^ ppbytes2 + instance_Show_Show_Missing_pervasives_byte_dict(Nat_big_num.of_int 0) debug_frame_section_body)) in + + (match parse_frame_info c cuh_default pc_frame with + | PR_fail( s, pc_info') -> failwith ("parse_frame_info: " ^ pp_parse_fail s pc_info') + | PR_success( fi, pc_loc') -> fi + )) in + + let li = (parse_line_number_infos c debug_line_section_body compilation_units1) in + + { + d_endianness = (c.endianness); + d_str = debug_str_section_body; + d_compilation_units = compilation_units1; + d_type_units = ([]); + d_loc = loc; + d_ranges = ranges; + d_frame_info = fi; + d_line_info = li; + }) + +(*val extract_dwarf : elf_file -> maybe dwarf*) +let extract_dwarf f:(dwarf)option= + + (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 + )) in + let (c: p_context) = ({ endianness = en }) in + let extract_section_body section_name (strict: bool)= + ((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_body = ((match section.Elf_interpreted_section.elf32_section_body with Sequence bs -> bs )) in + let _ = (my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ ("\n" + ^ (" body = " ^ (ppbytes2 + instance_Show_Show_Missing_pervasives_byte_dict(Nat_big_num.of_int 0) section_body ^ "\n"))))))) in + section_body + | [] -> + if strict then + failwith ("" ^ (section_name ^ " section not present")) + else + [] + | _ -> failwith ("multiple " ^ (section_name ^ " sections present")) + ) + + + | 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_body = ((match section.Elf_interpreted_section.elf64_section_body with Sequence bs -> bs )) in + section_body + | [] -> + if strict then + failwith ("" ^ (section_name ^ " section not present")) + else + [] + | _ -> failwith ("multiple " ^ (section_name ^ " sections present")) + ) + )) in + + let debug_info_section_body = (extract_section_body ".debug_info" true) in + let debug_abbrev_section_body = (extract_section_body ".debug_abbrev" false) in + let debug_str_section_body = (extract_section_body ".debug_str" false) in + let debug_loc_section_body = (extract_section_body ".debug_loc" false) in + let debug_ranges_section_body = (extract_section_body ".debug_ranges" false) in + let debug_frame_section_body = (extract_section_body ".debug_frame" false) in + let debug_line_section_body = (extract_section_body ".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 + + Some d) + + +(** ************************************************************ *) +(** ****** location evaluation ******************************** *) +(** ************************************************************ *) + + +(** pp of locations *) + +(*val pp_simple_location : simple_location -> string*) +let pp_simple_location sl:string= + ((match sl with + | SL_memory_address n -> pphex n + | SL_register n -> "reg" ^ Nat_big_num.to_string n + | SL_implicit bs -> "value: " ^ ppbytes + instance_Show_Show_Missing_pervasives_byte_dict bs + | SL_empty -> "<empty>" + )) + +(*val pp_composite_location_piece : composite_location_piece -> string*) +let pp_composite_location_piece clp:string= + ((match clp with + | CLP_piece( n, sl) -> "piece (" ^ (Nat_big_num.to_string n ^ (") " ^ pp_simple_location sl)) + | CLP_bit_piece( n1, n2, sl) -> "bit_piece (" ^ (Nat_big_num.to_string n1 ^ ("," ^ (Nat_big_num.to_string n2 ^ (") " ^ pp_simple_location sl)))) + )) + +(*val pp_single_location: single_location -> string*) +let pp_single_location sl:string= + ((match sl with + | SL_simple sl -> pp_simple_location sl + | SL_composite clps -> "composite: " ^ myconcat ", " (Lem_list.map pp_composite_location_piece clps) + )) + + +(** 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: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:arithmetic_context= + ( + if(Nat_big_num.equal cuh.cuh_address_size (Nat_big_num.of_int 8)) then + ({ ac_bitwidth =(Nat_big_num.of_int 64); + ac_half = (Nat_big_num.pow_int (Nat_big_num.of_int 2) ( 32)); + ac_all = (Nat_big_num.pow_int (Nat_big_num.of_int 2) ( 64)); + ac_max = (Nat_big_num.sub_nat + (Nat_big_num.pow_int (Nat_big_num.of_int 2) ( 64)) + (Nat_big_num.of_int 1)); }) else + ( + if(Nat_big_num.equal cuh.cuh_address_size (Nat_big_num.of_int 4)) then + ({ ac_bitwidth =(Nat_big_num.of_int 32); + ac_half = (Nat_big_num.pow_int (Nat_big_num.of_int 2) ( 16)); + ac_all = (Nat_big_num.pow_int (Nat_big_num.of_int 2) ( 32)); + ac_max = (Nat_big_num.sub_nat + (Nat_big_num.pow_int (Nat_big_num.of_int 2) ( 32)) + (Nat_big_num.of_int 1)); }) else + (failwith "arithmetic_context_of_cuh given non-4/8 size"))) + +let find_cfa_table_row_for_pc (evaluated_frame_info1: evaluated_frame_info) (pc: Nat_big_num.num) : cfa_table_row= + ((match + myfind + (fun (fde1,rows) -> Nat_big_num.greater_equal pc fde1.fde_initial_location_address && Nat_big_num.less pc (Nat_big_num.add fde1.fde_initial_location_address fde1.fde_address_range)) + evaluated_frame_info1 + with + | Some (fde1,rows) -> + (match myfind (fun row -> Nat_big_num.greater_equal pc row.ctr_loc) rows with + | Some row -> row + | None -> failwith "evaluate_cfa: no matchine row" + ) + | None -> failwith "evaluate_cfa: no fde encloding pc" + )) + + +let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evaluated_frame_info1: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: attribute_value option) (pc: Nat_big_num.num) (s: state) (ops: operation list) : single_location error= + + (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: Nat_big_num.num option) vs' (err:string) op= + ((match mv with + | Some v -> push_memory_address v vs' + | None -> Fail (err ^ pp_operation op) + )) in + + let bregxi r i= + ((match ev.read_register r with + | RRR_result v -> push_memory_address (partialNaturalFromInteger ( Nat_big_num.modulus(Nat_big_num.add( v)i) ( ac.ac_all))) s.s_stack + | RRR_not_currently_available -> Fail "RRR_not_currently_available" + | RRR_bad_register_number -> Fail ("RRR_bad_register_number " ^ Nat_big_num.to_string r) + )) 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" + ) + | _ -> Fail "OpSem unary not given an element on stack" + )) in + + (match ops with + | [] -> + if (listEqualBy (=) 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 ( ac.ac_all)) s.s_stack + | (OpSem_stack f, []) -> + (match f ac s.s_stack op.op_argument_values with + | Some stack' -> + let value' : simple_location = ((match stack' with [] -> SL_empty | v'::_ -> SL_memory_address v' )) in + Success { s with s_stack = stack'; s_value = value' } + | None -> Fail "OpSem_stack failed" + ) + | (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" + ) + | (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" + ) + | (OpSem_opcode_lit base, []) -> + if Nat_big_num.greater_equal op.op_code base && Nat_big_num.less op.op_code (Nat_big_num.add base(Nat_big_num.of_int 32)) then + push_memory_address ( Nat_big_num.sub_nat 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 = (Nat_big_num.sub_nat 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 = (Nat_big_num.sub_nat 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 + | Some fbloc -> + (*let _ = my_debug5 ("OpSem_fbreg (" ^ show i ^ ")\n") in*) + (match evaluate_location_description c dloc evaluated_frame_info1 cuh ac ev (*mfbloc*)None 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 = (Nat_big_num.modulus ( Nat_big_num.add( a) i) ( 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 + 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? *) + ) + | Fail e -> + Fail ("OpSem_fbreg failure: " ^ e) + ) + | None -> + Fail "OpSem_fbreg: no frame base location description given" + ) + + | (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 = (List.rev_append (List.rev 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 = (List.rev_append (List.rev s.s_location_pieces) [piece]) } + | (OpSem_implicit_value, [OAV_block( size2, 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" + ) + | (OpSem_call_frame_cfa, []) -> + let row = (find_cfa_table_row_for_pc evaluated_frame_info1 pc) in + (match row.ctr_cfa with + | CR_undefined -> + failwith "evaluate_cfa of CR_undefined" + | CR_register( r, i) -> + bregxi r i (* same behaviour as an OpSem_bregx *) + | CR_expression bs -> + 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 *) + ) + | (_, _) -> + Fail ("bad OpSem invocation: op=" ^ (pp_operation op ^ (" arguments=" ^ myconcat "" (Lem_list.map pp_operation_argument_value op.op_argument_values)))) + )) + in + (match es' with + | Success s' -> + evaluate_operation_list c dloc evaluated_frame_info1 cuh ac ev mfbloc pc s' ops' + | Fail e -> + Fail e + ) + )) + +and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info1: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: attribute_value option) (pc: Nat_big_num.num) (bs: char list) : single_location error= + (let parse_context1 = ({pc_bytes = bs; pc_offset =(Nat_big_num.of_int 0) }) in + (match parse_operations c cuh parse_context1 with + | PR_fail( s, pc') -> Fail ("evaluate_location_description_bytes: parse_operations fail: " ^ pp_parse_fail s pc') + | PR_success( ops, pc') -> + if not ((listEqualBy (=) pc'.pc_bytes [])) then + Fail "evaluate_location_description_bytes: extra non-parsed bytes" + else + evaluate_operation_list c dloc evaluated_frame_info1 cuh ac ev mfbloc pc initial_state ops + )) + +and evaluate_location_description (c:p_context) (dloc: location_list_list) (evaluated_frame_info1: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: attribute_value option) (pc: Nat_big_num.num) (loc:attribute_value) : single_location error= + ((match loc with + | AV_exprloc( n, bs) -> + evaluate_location_description_bytes c dloc evaluated_frame_info1 cuh ac ev mfbloc pc bs + | AV_block( n, bs) -> + evaluate_location_description_bytes c dloc evaluated_frame_info1 cuh ac ev mfbloc pc bs + | AV_sec_offset n -> + let location_list1 = (find_location_list dloc n) in + let (offset,(llis: location_list_item list)) = location_list1 in + let f (lli:location_list_item) : single_location_description option= + ((match lli with + | LLI_lle lle -> + if Nat_big_num.greater_equal pc lle.lle_beginning_address_offset && Nat_big_num.less pc lle.lle_ending_address_offset then Some lle.lle_single_location_description else None + | LLI_base _ -> + None (* TODO: either refactor to do offset during parsing or update base offsets here. Should refactor to use "interpreted". *) + )) in + (match myfindmaybe f llis with + | Some bs -> + evaluate_location_description_bytes c dloc evaluated_frame_info1 cuh ac ev mfbloc pc bs + | None -> + Fail "evaluate_location_description didn't find pc in location list ranges" + ) + | _ -> Fail "evaluate_location_description av_location not understood" + )) + + + + + +(** ************************************************************ *) +(** **** 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:(Nat_big_num.num*register_rule)list= ((r,rr)::rrp) + +(*val rrp_lookup : cfa_register -> register_rule_map -> register_rule*) +let rrp_lookup r rrp:register_rule= + ((match (lookupBy Nat_big_num.equal r rrp) with + | Some rr -> rr + | None -> RR_undefined + )) + +(*val rrp_empty : register_rule_map*) +let rrp_empty:(cfa_register*register_rule)list= ([]) + + + +(** 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*) + +let register_footprint_rrp (rrp: register_rule_map) : cfa_register Pset.set= + (Pset.from_list Nat_big_num.compare (Lem_list.map fst rrp)) + +let register_footprint (rows: cfa_table_row list) : cfa_register list= + (Pset.elements (bigunionListMap + instance_Basic_classes_SetType_Num_natural_dict (fun row -> register_footprint_rrp row.ctr_regs) rows)) + + +(*val max_lengths : list (list string) -> list natural*) +let rec max_lengths xss:(Nat_big_num.num)list= + ((match xss with + | [] -> failwith "max_lengths" + | xs::xss' -> + let lens = (Lem_list.map (fun x -> Nat_big_num.of_int (String.length x)) xs) in + if (listEqualBy (listEqualBy (=)) xss' []) then lens + else + let lens' = (max_lengths xss') in + let z = (Lem_list.list_combine lens lens') in + let lens'' = (Lem_list.map (fun (l1,l2)-> Nat_big_num.max l1 l2) z) in + lens'' + )) + +let rec pad_row xs lens:(string)list= + ((match (xs,lens) with + | ([],[]) -> [] + | (x::xs', len::lens') -> right_space_padded_to len x :: pad_row xs' lens' + )) + +let pad_rows (xss : ( string list) list) : string= + (let lens = (max_lengths xss) in + myconcat "" (Lem_list.map (fun xs -> myconcat " " (pad_row xs lens) ^ "\n") xss)) + +let pp_evaluated_fde (fde1, (rows: cfa_table_row list)) : string= + (let regs = (register_footprint rows) in + let header : string list = ("LOC" :: ("CFA" :: Lem_list.map + (pp_cfa_register instance_Show_Show_Num_natural_dict) regs)) in + let ppd_rows : ( string list) list = + (Lem_list.map (fun row -> pphex row.ctr_loc :: (pp_cfa_rule row.ctr_cfa :: Lem_list.map (fun r -> pp_register_rule (rrp_lookup r row.ctr_regs)) regs)) rows) in + pad_rows (header :: ppd_rows)) + + + +(** evaluation of cfa information from .debug_frame *) + +let evaluate_call_frame_instruction (fi: frame_info) (cie1: cie) (state1: cfa_state) (cfi: call_frame_instruction) : cfa_state= + + (let create_row (loc: Nat_big_num.num)= + (let row = ({ state1.cs_current_row with ctr_loc = loc }) in + { state1 with cs_current_row = row; cs_previous_rows = (state1.cs_current_row::state1.cs_previous_rows) }) in + + let update_cfa (cr:cfa_rule)= + (let row = ({ state1.cs_current_row with ctr_cfa = cr }) in + { state1 with cs_current_row = row }) in + + let update_reg r rr= + (let row = ({ state1.cs_current_row with ctr_regs = (rrp_update state1.cs_current_row.ctr_regs r rr) }) in + { state1 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 ( Nat_big_num.add state1.cs_current_row.ctr_loc (Nat_big_num.mul d cie1.cie_code_alignment_factor)) + | DW_CFA_advance_loc1 d -> + create_row ( Nat_big_num.add state1.cs_current_row.ctr_loc (Nat_big_num.mul d cie1.cie_code_alignment_factor)) + | DW_CFA_advance_loc2 d -> + create_row ( Nat_big_num.add state1.cs_current_row.ctr_loc (Nat_big_num.mul d cie1.cie_code_alignment_factor)) + | DW_CFA_advance_loc4 d -> + create_row ( Nat_big_num.add state1.cs_current_row.ctr_loc (Nat_big_num.mul d cie1.cie_code_alignment_factor)) + + (* CFA Definition Instructions *) + | DW_CFA_def_cfa( r, n) -> + update_cfa (CR_register( r, ( n))) + | DW_CFA_def_cfa_sf( r, i) -> + update_cfa (CR_register( r, ( Nat_big_num.mul i cie1.cie_data_alignment_factor))) + | DW_CFA_def_cfa_register r -> + (match state1.cs_current_row.ctr_cfa with + | CR_register( r', i) -> + update_cfa (CR_register( r, i)) + | _ -> failwith "DW_CFA_def_cfa_register: current rule is not CR_register" + ) + | DW_CFA_def_cfa_offset n -> + (match state1.cs_current_row.ctr_cfa with + | CR_register( r, i) -> + update_cfa (CR_register( r, ( n))) + | _ -> failwith "DW_CFA_def_cfa_offset: current rule is not CR_register" + ) + | DW_CFA_def_cfa_offset_sf i -> + (match state1.cs_current_row.ctr_cfa with + | CR_register( r, i') -> + update_cfa (CR_register( r, ( Nat_big_num.mul i' cie1.cie_data_alignment_factor))) + | _ -> failwith "DW_CFA_def_cfa_offset_sf: current rule is not CR_register" + ) + | 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 ( Nat_big_num.mul( n) cie1.cie_data_alignment_factor)) + | DW_CFA_offset_extended( r, n) -> + update_reg r (RR_offset ( Nat_big_num.mul( n) cie1.cie_data_alignment_factor)) + | DW_CFA_offset_extended_sf( r, i) -> + update_reg r (RR_offset ( Nat_big_num.mul i cie1.cie_data_alignment_factor)) + | DW_CFA_val_offset( r, n) -> + update_reg r (RR_val_offset ( Nat_big_num.mul( n) cie1.cie_data_alignment_factor)) + | DW_CFA_val_offset_sf( r, i) -> + update_reg r (RR_val_offset ( Nat_big_num.mul i cie1.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 state1.cs_initial_instructions_row.ctr_regs) +(* RR_undefined if the lookup fails? *) + | DW_CFA_restore_extended r -> + update_reg r (rrp_lookup r state1.cs_initial_instructions_row.ctr_regs) + +(* Row State Instructions *) +(* do these also push and restore the CFA rule? *) + | DW_CFA_remember_state -> + { state1 with cs_row_stack = (state1.cs_current_row :: state1.cs_row_stack) } + | DW_CFA_restore_state -> + (match state1.cs_row_stack with + | r::rs -> { state1 with cs_current_row = r; cs_row_stack = rs } + | [] -> failwith "DW_CFA_restore_state: empty row stack" + ) +(* Padding Instruction *) + | DW_CFA_nop -> + state1 + +(* Unknown *) + | DW_CFA_unknown b -> + failwith ("evaluate_call_frame_instruction: DW_CFA_unknown " ^ hex_string_of_byte b) + + )) + + + +let rec evaluate_call_frame_instructions (fi: frame_info) (cie1: cie) (state1: cfa_state) (cfis: call_frame_instruction list) : cfa_state= + ((match cfis with + | [] -> state1 + | cfi::cfis' -> + let state' = (evaluate_call_frame_instruction fi cie1 state1 cfi) in + evaluate_call_frame_instructions fi cie1 state' cfis' + )) + + +let evaluate_fde (fi: frame_info) (fde1:fde) : cfa_table_row list= + (let cie1 = (find_cie fi fde1.fde_cie_pointer) in + let final_location = (Nat_big_num.add fde1.fde_initial_location_address fde1.fde_address_range) in + let initial_cfa_state = + (let initial_row = + ({ + ctr_loc = (fde1.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 cie1 initial_cfa_state cie1.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 cie1 (*final_location*) state'' fde1.fde_instructions) in + List.rev (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= + (Lem_list.mapMaybe (fun fie -> (match fie with FIE_fde fde1 -> Some (fde1, (evaluate_fde d.d_frame_info fde1)) | FIE_cie _ -> None )) d.d_frame_info) + +let pp_evaluated_frame_info (efi: evaluated_frame_info):string= + (myconcat "\n" (Lem_list.map pp_evaluated_fde efi)) + + + +(** ************************************************************ *) +(** ** analysis of location and frame data for reverse mapping *) +(** ************************************************************ *) + +(** analysis *) + +(*val find_dies_in_die : (die->bool) -> compilation_unit -> list die -> die -> list (compilation_unit * (list die) * die)*) +let rec find_dies_in_die (p:die->bool) (cu:compilation_unit) (parents: die list) (d: die):(compilation_unit*(die)list*die)list= + (let ds = (List.concat (map (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) : (compilation_unit * ( die list) * die) list= + (List.concat (map (fun cu -> find_dies_in_die p cu [] cu.cu_die) d.d_compilation_units)) + + +(** simple-minded analysis of location *) + +let analyse_locations_raw c (d: dwarf):string= + + (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 = (Lem_list.map tag_encode ["DW_TAG_variable"; "DW_TAG_formal_parameter"]) in + let dies : (compilation_unit * ( die list) * die) list = + (find_dies + (fun die1 -> + Lem_list.elem + instance_Basic_classes_Eq_Num_natural_dict die1.die_abbreviation_declaration.ad_tag tags + && has_attribute "DW_AT_name" die1) + d) in + + myconcat "" + (Lem_list.map + (fun (cu,parents,die1) -> + + let ats = (Lem_list.list_combine + die1.die_abbreviation_declaration.ad_attribute_specifications + die1.die_attribute_values) in + + let find_ats (s:string)= (myfindNonPure (fun (((at: Nat_big_num.num), (af: Nat_big_num.num)), ((pos: Nat_big_num.num),(av:attribute_value))) -> Nat_big_num.equal (attribute_encode s) at) ats) in + + let ((_,_),(_,av_name)) = (find_ats "DW_AT_name") in + + let name1 = + ((match av_name with + | AV_string bs -> string_of_bytes bs + | AV_strp n -> pp_debug_str_entry d.d_str n + | _ -> "av_name AV not understood" + )) 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_list1 = (myfindNonPure (fun (n',_)->Nat_big_num.equal n' n) d.d_loc) in + pp_location_list c cuh_default location_list1 + | _ -> "av_location AV not understood" + )) in + + pp_tag_encoding die1.die_abbreviation_declaration.ad_tag ^ (" " ^ (name1 ^ (":\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 rec closest_enclosing_range c (dranges: range_list_list) (cu_base_address1: Nat_big_num.num) (parents: die list) : ( (Nat_big_num.num * Nat_big_num.num)list)option= + ((match parents with + | [] -> None + | die1::parents' -> + (match (find_attribute_value "DW_AT_low_pc" die1, find_attribute_value "DW_AT_high_pc" die1, find_attribute_value "DW_AT_ranges" die1) with + | (Some (AV_addr n), None, None ) -> Some [(n,Nat_big_num.add n(Nat_big_num.of_int 1))] (* unclear if this case is used? *) + | (Some (AV_addr n1), Some (AV_addr n2), None ) -> Some [(n1,n2)] + | (Some (AV_addr n1), Some (AV_constant_ULEB128 n2), None ) -> Some [(n1,Nat_big_num.add n1 n2)] (* should be mod all? *) + | (Some (AV_addr n1), Some (AV_constant_SLEB128 i2), None ) -> Some [(n1, Nat_big_num.abs ( Nat_big_num.add( n1) i2))] (* should + be mod all? *) + | (Some (AV_addr n1), Some (AV_constantN( _, _)), None ) -> failwith "AV_constantN in closest_enclosing_range" + + | (Some (AV_addr n1), Some (AV_block( n, bs)), None ) -> let n2 = (natural_of_bytes c.endianness bs) in Some [(n1,Nat_big_num.add n1 n2)] (* should be mod all? *) (* signed or unsigned interp? *) + + | (_, None, Some (AV_sec_offset n)) -> + let rlis = (snd (find_range_list dranges n)) in + let nns = (interpret_range_list cu_base_address1 rlis) in + Some nns + | (None, None, None ) -> closest_enclosing_range c dranges cu_base_address1 parents' + | (_, _, _ ) -> Some [] (*Assert_extra.failwith "unexpected attribute values in closest_enclosing_range"*) + ) + )) + +(* +If one of the DW_FORM_data<n> 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<n>. +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_address1: Nat_big_num.num) (parents: die list) : attribute_value option= + ((match parents with + | [] -> None + | die1::parents' -> + (match find_attribute_value "DW_AT_frame_base" die1 with + | Some av -> Some av + | None -> closest_enclosing_frame_base dloc base_address1 parents' + ) + )) + + + + +let interpreted_location_of_die c cuh (dloc: location_list_list) (dranges: range_list_list) (base_address1: Nat_big_num.num) (parents: die list) (die1: die) : ( (Nat_big_num.num * Nat_big_num.num * single_location_description)list)option= +( + + (* 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 dranges base_address1 (die1::parents) with + | Some nns -> + Some (Lem_list.map (fun (n1,n2) -> (n1,n2,bs)) nns) + | None -> + (* if there is no such range, we take the full 0 - 0xfff.fff range*) + Some [(Nat_big_num.of_int 0,(arithmetic_context_of_cuh cuh).ac_max,bs)] + )) in + + (match find_attribute_value "DW_AT_location" die1 with + | Some (AV_exprloc( n, bs)) -> location bs + | Some (AV_block( n, bs)) -> location bs + (* while for a location list, we take the associated pc range from + each element of the list *) + | Some (AV_sec_offset n) -> + let (_,llis) = (find_location_list dloc n) in + Some (interpret_location_list base_address1 llis) + | None -> None + )) + + +let cu_base_address cu:Nat_big_num.num= + ((match find_attribute_value "DW_AT_low_pc" cu.cu_die with + | Some (AV_addr n) -> n + | _ ->Nat_big_num.of_int 0 (*Nothing*) (*Assert_extra.failwith "no cu DW_AT_low_pc"*) + )) + + +(*val analyse_locations : dwarf -> analysed_location_data*) +let analyse_locations (d: dwarf) : analysed_location_data= + + (let c : p_context = ({ endianness = (d.d_endianness) }) 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_name and DW_AT_location attribute *) + let tags = (Lem_list.map tag_encode ["DW_TAG_variable"; "DW_TAG_formal_parameter"]) in + let dies : (compilation_unit * ( die list) * die) list = + (find_dies + (fun die1 -> + Lem_list.elem + instance_Basic_classes_Eq_Num_natural_dict die1.die_abbreviation_declaration.ad_tag tags + && (has_attribute "DW_AT_name" die1 + && has_attribute "DW_AT_location" die1)) + d) in + + Lem_list.map + (fun ((((cu:compilation_unit), (parents: die list), (die1: die)) as x)) -> + let base_address1 = (cu_base_address cu) in + let interpreted_locations : ( (Nat_big_num.num * Nat_big_num.num * single_location_description)list)option = + (interpreted_location_of_die c cuh_default d.d_loc d.d_ranges base_address1 parents die1) in + (x,interpreted_locations) + ) + dies) + + + +let pp_analysed_locations1 c cuh (nnls: (Nat_big_num.num * Nat_big_num.num * single_location_description) list) : string= + (myconcat "" + (Lem_list.map + (fun (n1,n2,bs) -> " " ^ (pphex n1 ^ (" " ^ (pphex n2 ^ (" " ^ (parse_and_pp_operations c cuh bs ^ "\n")))))) + nnls)) + +let pp_analysed_locations2 c cuh mnnls:string= + ((match mnnls with + | Some nnls -> pp_analysed_locations1 c cuh nnls + | None -> " <no locations>\n" + )) + +let pp_analysed_locations3 c cuh str (als: analysed_location_data) : string= + (myconcat "\n" + (Lem_list.map + (fun ((cu,parents,die1),mnnls) -> + pp_die_abbrev c cuh str(Nat_big_num.of_int 0) false parents die1 + ^ pp_analysed_locations2 c cuh mnnls + ) + als + )) + +let pp_analysed_location_data (d: dwarf) (als: analysed_location_data) : string= + (let c : p_context = ({ endianness = (d.d_endianness) }) in + let (cuh_default : compilation_unit_header) = (let cu = (myhead d.d_compilation_units) in cu.cu_header) in + pp_analysed_locations3 c (*HACK*) cuh_default d.d_str als) + + + +let pp_analysed_location_data_at_pc (d: dwarf) (alspc: analysed_location_data_at_pc) : string= + (myconcat "" (Lem_list.map + (fun ((cu,parents,die1),(n1,n2,sld,esl)) -> + " " ^ + (let name1 = + ((match find_name_of_die d.d_str die1 with + | Some s -> s + | None -> "<no name>\n" + )) in + (match esl with + | Success sl -> + name1 ^ (" @ " ^ (pp_single_location sl ^"\n")) + + | Fail e -> name1 ^ (" @ " ^ ("<fail: " ^ (e ^ ">\n"))) + )) + ) + alspc)) + + +(*val analysed_locations_at_pc : evaluation_context -> dwarf_static -> natural -> analysed_location_data_at_pc*) +let analysed_locations_at_pc + (ev) + (ds: dwarf_static) + (pc: Nat_big_num.num) + : analysed_location_data_at_pc= + +(let c : p_context = ({ endianness = (ds.ds_dwarf.d_endianness) }) in + + let xs = + (Lem_list.mapMaybe + (fun (cupd,mnns) -> + (match mnns with + | None -> None + | Some nns -> + let nns' = (List.filter (fun (n1,n2,sld) -> Nat_big_num.greater_equal pc n1 && Nat_big_num.less pc n2) nns) in + (match nns' with + | [] -> None + | _ -> Some (cupd,nns') + ) + )) + ds.ds_analysed_location_data) +in + +List.concat + (Lem_list.map + (fun ((cu,parents,die1),nns) -> + let ac = (arithmetic_context_of_cuh cu.cu_header) in + let base_address1 = (cu_base_address cu) in + let mfbloc : attribute_value option = + (closest_enclosing_frame_base ds.ds_dwarf.d_loc base_address1 parents) in + Lem_list.map + (fun (n1,n2,sld) -> + let el : single_location error = + (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,die1),(n1,n2,sld,el)) + ) + nns + ) + xs)) + +(*val names_of_address : dwarf -> analysed_location_data_at_pc -> natural -> list string*) +let names_of_address + (d: dwarf) + (alspc: analysed_location_data_at_pc) + (address: Nat_big_num.num) + : string list= + +(Lem_list.mapMaybe + (fun ((cu,parents,die1),(n1,n2,sld,esl)) -> + (match esl with + | Success (SL_simple (SL_memory_address a)) -> + if Nat_big_num.equal a address then + (match find_name_of_die d.d_str die1 with + | Some s -> Some s + | None -> None + ) + else + None + | Success _ -> None (* just suppress? *) + | Fail e -> None (* just suppress? *) + ) + ) + alspc) + + +(** ************************************************************ *) +(** ** evaluation of line-number info *) +(** ************************************************************ *) + +let initial_line_number_registers (lnh: line_number_header) : line_number_registers= + ({ + lnr_address =(Nat_big_num.of_int 0); + lnr_op_index =(Nat_big_num.of_int 0); + lnr_file =(Nat_big_num.of_int 1); + lnr_line =(Nat_big_num.of_int 1); + lnr_column =(Nat_big_num.of_int 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 =(Nat_big_num.of_int 0); + lnr_discriminator =(Nat_big_num.of_int 0); + }) + +let evaluate_line_number_operation + (lnh: line_number_header) + ((s: line_number_registers), (lnrs: line_number_registers list)) + (lno: line_number_operation) + : line_number_registers * line_number_registers list= + + (let new_address s operation_advance= (Nat_big_num.add s.lnr_address (Nat_big_num.mul + lnh.lnh_minimum_instruction_length + (Nat_big_num.div( Nat_big_num.add s.lnr_op_index operation_advance)lnh.lnh_maximum_operations_per_instruction))) in + let new_op_index s operation_advance= (Nat_big_num.modulus + ( Nat_big_num.add s.lnr_op_index operation_advance) lnh.lnh_maximum_operations_per_instruction) in + + (match lno with + | DW_LN_special adjusted_opcode -> + let operation_advance = (Nat_big_num.div adjusted_opcode lnh.lnh_line_range) in + let line_increment = (Nat_big_num.add lnh.lnh_line_base (( Nat_big_num.modulus adjusted_opcode lnh.lnh_line_range))) in + let s' = + ({ s with + lnr_line = (partialNaturalFromInteger ( Nat_big_num.add( 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 =(Nat_big_num.of_int 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 =(Nat_big_num.of_int 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 ( Nat_big_num.add( 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 =(Nat_big_num.of_int 255) in + let adjusted_opcode = (Nat_big_num.sub_nat opcode lnh.lnh_opcode_base) in + let operation_advance = (Nat_big_num.div 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 = (Nat_big_num.add s.lnr_address n); + lnr_op_index =(Nat_big_num.of_int 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 =(Nat_big_num.of_int 0); + }) in + (s', lnrs) + | DW_LNE_define_file( s, n1, n2, n3) -> + 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) + )) + +let rec evaluate_line_number_operations + (lnh: line_number_header) + ((s: line_number_registers), (lnrs: line_number_registers list)) + (lnos: line_number_operation list) + : line_number_registers * line_number_registers list= + ((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' + )) + +let evaluate_line_number_program + (lnp:line_number_program) + : line_number_registers list= + (List.rev (snd (evaluate_line_number_operations lnp.lnp_header ((initial_line_number_registers lnp.lnp_header),[]) lnp.lnp_operations))) + + +let pp_line_number_registers lnr:string= + ("" + ^ ("address = " ^ (pphex lnr.lnr_address ^ ("\n" + ^ ("op_index = " ^ (Nat_big_num.to_string lnr.lnr_op_index ^ ("\n" + ^ ("file = " ^ (Nat_big_num.to_string lnr.lnr_file ^ ("\n" + ^ ("line = " ^ (Nat_big_num.to_string lnr.lnr_line ^ ("\n" + ^ ("column = " ^ (Nat_big_num.to_string lnr.lnr_column ^ ("\n" + ^ ("is_stmt = " ^ (string_of_bool lnr.lnr_is_stmt ^ ("\n" + ^ ("basic_block = " ^ (string_of_bool lnr.lnr_basic_block ^ ("\n" + ^ ("end_sequence = " ^ (string_of_bool lnr.lnr_end_sequence ^ ("\n" + ^ ("prologue_end = " ^ (string_of_bool lnr.lnr_prologue_end ^ ("\n" + ^ ("epilogue_begin = " ^ (string_of_bool lnr.lnr_epilogue_begin ^ ("\n" + ^ ("isa = " ^ (Nat_big_num.to_string lnr.lnr_isa ^ ("\n" + ^ ("discriminator = " ^ (pphex lnr.lnr_discriminator ^ "\n")))))))))))))))))))))))))))))))))))) + +let pp_line_number_registers_tight lnr : string list= + ([ + pphex lnr.lnr_address ; + Nat_big_num.to_string lnr.lnr_op_index ; + Nat_big_num.to_string lnr.lnr_file ; + Nat_big_num.to_string lnr.lnr_line ; + Nat_big_num.to_string lnr.lnr_column ; + string_of_bool lnr.lnr_is_stmt ; + string_of_bool lnr.lnr_basic_block ; + string_of_bool lnr.lnr_end_sequence ; + string_of_bool lnr.lnr_prologue_end ; + string_of_bool lnr.lnr_epilogue_begin ; + Nat_big_num.to_string lnr.lnr_isa ; + pphex lnr.lnr_discriminator + ]) + +let pp_line_number_registerss lnrs:string= + (pad_rows + ( + ["address"; "op_index"; "file"; "line"; "column"; "is_stmt"; "basic_block"; "end_sequence"; "prologue_end"; "epilogue_begin"; "isa"; "discriminator"] + :: + (Lem_list.map pp_line_number_registers_tight lnrs) + )) + +let pp_evaluated_line_info (eli: evaluated_line_info) : string= + (myconcat "\n" (Lem_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: Nat_big_num.num) : (string * Nat_big_num.num * line_number_registers) list= + (List.concat + (Lem_list.map + (fun (lnh, lnrs) -> + myfiltermaybe + (fun lnr -> + if Nat_big_num.equal a lnr.lnr_address && not lnr.lnr_end_sequence then + (match mynth ( Nat_big_num.sub_nat lnr.lnr_file(Nat_big_num.of_int 1)) lnh.lnh_file_names with + | Some lnfe -> + Some (string_of_bytes lnfe.lnfe_path, lnr.lnr_line, lnr) + | None -> + Some ("<source_lines_of_address: file entry not found>",Nat_big_num.of_int 0, lnr) + ) + else + None) + 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:(dwarf_static)option= + ((match extract_dwarf f1 with + | None -> None + | Some dwarf1 -> + let _ = (my_debug5 (pp_dwarf dwarf1)) in + + let ald : analysed_location_data = + (analyse_locations dwarf1) in + let efi : evaluated_frame_info = + (evaluate_frame_info dwarf1) in + let eli : evaluated_line_info = + (Lem_list.map (fun lnp -> (lnp.lnp_header, evaluate_line_number_program lnp)) dwarf1.d_line_info) in + let ds = + ({ + ds_dwarf = dwarf1; + ds_analysed_location_data = ald; + ds_evaluated_frame_info = efi; + ds_evaluated_line_info = eli; + }) in + Some ds + )) + + + + +(** ************************************************************ *) +(** ** top level for main_elf ******************************** *) +(** ************************************************************ *) + +(*val harness_string_of_elf : elf_file -> byte_sequence -> string*) +let harness_string_of_elf f1 bs:string= + (let mds = (extract_dwarf_static f1) in + (match mds with + | None -> "<no dwarf information extracted>" + | Some ds -> + 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))))) + )) + + +(*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 harness_string_of_elf64_debug_info_section f1 bs0:string= + ( (*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 harness_string_of_elf32_debug_info_section f1 bs0:string= + ( (*os proc usr hdr sht stbl*)harness_string_of_elf (ELF_File_32 f1) bs0) + diff --git a/lib/ocaml_rts/linksem/elf64_file_of_elf_memory_image.ml b/lib/ocaml_rts/linksem/elf64_file_of_elf_memory_image.ml new file mode 100644 index 00000000..b9366d2c --- /dev/null +++ b/lib/ocaml_rts/linksem/elf64_file_of_elf_memory_image.ml @@ -0,0 +1,491 @@ +(*Generated by Lem from elf64_file_of_elf_memory_image.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_map +(*import Set*) +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show +open Endianness + +open Elf_header +open Elf_file +open Elf_interpreted_section +open Elf_interpreted_segment +open Elf_section_header_table +open Elf_program_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation +open String_table + +open Memory_image +open Memory_image_orderings + +open Elf_memory_image +open Elf_memory_image_of_elf64_file +open Abis + +(* Things the caller should do first: *) +(* - create segment annotations *) +(* - create .dynamic-equivalent metadata (but not the section) *) +(* - concretise symbolic elements? actually they pass a function to do this. *) + +type make_concrete_fn = Memory_image.element -> Memory_image.element + +(* Things we do, at the caller's direction:*) +(* - create SHT *) +(* - create symtabs, strtabs, symbol hash tables (the ABI helps us) *) +(* - create shstrtab (if we're creating a SHT) *) +(* - actually create the dynamic section (and its PHDR) *) +(* - create any other PHDRs (the ABI tells us, mostly) and PT_PHDR (the user tells us) *) + +(*val elf64_file_of_elf_memory_image : abi any_abi_feature -> make_concrete_fn -> string -> elf_memory_image -> elf64_file*) +let elf64_file_of_elf_memory_image a make_concrete fname1 img2:elf64_file= +( + (* Generate an ELF header, (optionally) SHT and (optionally) PHT, + * based on metadata in the image. + * + * How do we decide what kind of ELF file to generate? see whether we have segment annotations? + what architecture/osabi to give? the ABI tells us + + *)let (section_tags, section_ranges) = (elf_memory_image_section_ranges img2) + in + let section_tags_bare = (Lem_list.map (fun tag -> + (match tag with + | FileFeature(ElfSection(idx1, isec1)) -> (idx1, isec1) + | _ -> failwith "not section tag" + )) section_tags) + in + let section_tags_bare_noidx = (Lem_list.map (fun (idx1, isec1) -> isec1) section_tags_bare) + in + let basic_shstrtab = (List.fold_left (fun table -> (fun str -> + let (_, t) = (String_table.insert_string str table) in t + )) String_table.empty0 [".shstrtab"; ".symtab"; ".strtab"]) + in + let shstrtab = (List.fold_left (fun table -> fun (idx1, isec1) -> + let (_, t) = (String_table.insert_string isec1.elf64_section_name_as_string table) in + (* let _ = errln ("Adding section name `" ^ isec.elf64_section_name_as_string ^ "' to shstrtab; now has size " + ^ (show (String_table.size t))) + in *) t + ) basic_shstrtab section_tags_bare) + in + let phoff =(Nat_big_num.of_int 64) + in + let max_phnum1 = ( (* length phdrs *)a.max_phnum) + in + (* what do we generate? + * .eh_frame? no, *should* come from the script + * .got, .got.plt? HMM. These should have been created, + * as ABI features, by the time we get here. + * .comment -- maybe + * .shstrtab -- YES + * .symtab -- YES + * .strtab -- YES. + * + * Do we generate them as elements in the image, or just + * use them to write the ELF file? The latter. + *) + let (symbol_tags, symbol_ranges) = (elf_memory_image_symbol_def_ranges img2) + in + let all_sym_names = (Lem_list.map (fun tag -> + (match tag with + SymbolDef(sd) -> sd.def_symname + | _ -> "not symbol tag, in symbol tags" + ) + ) symbol_tags) + in + (*let _ = errln ("All symbol names: " ^ (show all_sym_names)) + in*) + let strtab = (List.fold_left (fun table -> fun str -> + let (_, t) = (String_table.insert_string str table) in t + ) String_table.empty0 all_sym_names) + in + (* If the same address starts >1 section, all but one of those sections + * must have size zero. These need to come *first* to avoid screwing up + * the offset calculation. So also sort by size, so that the zero-sizers + * come first. *) + let element_section_tag_pairs_sorted_by_address = ( (* List.stable_sort *)List.sort + (fun (isec1, (el1, range1)) -> (fun (isec2, (el2, range2)) -> ( + let (addr1, sz1) = ((match Pmap.lookup el1 img2.elements with + Some(e) -> + (*let _ = errln ("Size of element " ^ el1 ^ " is " ^ (show e.length)) + in*) + (e.startpos, e.length1) + | None -> failwith "internal error: element does not exist" + )) + in + let (addr2, sz2) = ((match Pmap.lookup el2 img2.elements with + Some(e) -> (e.startpos, e.length1) + | None -> failwith "internal error: element does not exist" + )) + in +(pairCompare (maybeCompare Nat_big_num.compare) (maybeCompare Nat_big_num.compare) (addr1, sz1) (addr2, sz2)) + ))) + (list_combine section_tags_bare_noidx section_ranges)) + in + let sorted_sections = (Lem_list.map (fun (isec1, (el, range1)) -> isec1) + element_section_tag_pairs_sorted_by_address) + in + let filesz = (fun el -> fun isec1 -> + (* How can we distinguish progbits from nobits? + * A section can be nobits if its representation + * is all zero or don't-care. But in practice we + * don't make a section nobits unless its name is .bss. *) + let sz = (if (* is_all_zeroes_or_dont_care *) true && +(isec1.elf64_section_name_as_string = ".bss") then Nat_big_num.of_int 0 + else (match el.length1 with + None -> failwith "error: concrete section element has no length" + | Some len -> len + )) + in + (*let _ = errln ("Filesz of " ^ isec.elf64_section_name_as_string ^ " is 0x" ^ (hex_string_of_natural sz)) + in*) + sz + ) + in + let (last_off, section_file_offsets) = (List.fold_left (fun (current_off, offs_so_far) -> (fun (isec1, (el_name, el_range)) -> + (* where can we place this in the file? + * it's the next offset that's congruent to the section addr, + * modulo the biggest page size. *) + let el = ((match Pmap.lookup el_name img2.elements with + Some e -> e + | None -> failwith "nonexistent element" + )) + in + let (start_off : Nat_big_num.num) = ((match el.startpos with + Some addr -> let this_remainder = (Nat_big_num.modulus current_off a.maxpagesize) + in + let target_remainder = (Nat_big_num.modulus addr a.maxpagesize) + in + let bump = ( + if Nat_big_num.greater_equal target_remainder this_remainder + then Nat_big_num.sub_nat target_remainder this_remainder + else ( Nat_big_num.sub_nat (Nat_big_num.add a.maxpagesize target_remainder) this_remainder) + ) + in Nat_big_num.add + (*let _ = errln ("For section " ^ isec.elf64_section_name_as_string ^ ", bumping offset by " ^ + (hex_string_of_natural bump) ^ "(remainder " ^ (hex_string_of_natural this_remainder) ^ + ", target remainder " ^ (hex_string_of_natural target_remainder) ^ ") to 0x" ^ + (hex_string_of_natural (current_off + bump))) + in*) + current_off bump + | None -> + (* It has no assigned address. That's okay if it's not allocatable. + * If it's not allocatable, it has no alignment. *) + if flag_is_set shf_alloc isec1.elf64_section_flags then (failwith "allocatable section with no address") + else current_off (* FIXME: is alignment important in file-offset-space? *) + )) + in + let end_off = (Nat_big_num.add start_off (filesz el isec1)) + in + (end_off, List.rev_append (List.rev offs_so_far) [start_off]) + )) (( Nat_big_num.add phoff ( Nat_big_num.mul max_phnum1(Nat_big_num.of_int 56))), []) element_section_tag_pairs_sorted_by_address) + in + let user_sections_sorted_with_offsets = (let x2 = + ([]) in List.fold_right + (fun(off, (isec1, (el_name, el_range))) x2 -> + if true then + (let el = ((match Pmap.lookup el_name img2.elements with + Some x -> x + | None -> failwith "internal error: section not found" + )) in + { elf64_section_name = (isec1.elf64_section_name) (* ignored *) + ; elf64_section_type = (isec1.elf64_section_type) + ; elf64_section_flags = (isec1.elf64_section_flags) + ; elf64_section_addr = ((match el.startpos with + Some addr -> addr + | None ->Nat_big_num.of_int 0 + )) ; elf64_section_offset = + (*let _ = errln ("Assigning offset 0x" ^ (hex_string_of_natural off) ^ " to section " ^ + isec.elf64_section_name_as_string) + in*) + off + ; elf64_section_size = ((match el.length1 with + Some len -> len + | None -> length el.contents + )) + ; elf64_section_link = (isec1.elf64_section_link) + ; elf64_section_info = (isec1.elf64_section_info) + ; elf64_section_align = (isec1.elf64_section_align) + ; elf64_section_entsize = (isec1.elf64_section_entsize) + ; elf64_section_body = + (let pad_fn1 = ( + if flag_is_set shf_execinstr isec1.elf64_section_flags then + a.pad_data else a.pad_code) in + Sequence + (concretise_byte_pattern [] (Nat_big_num.of_int 0) + (make_concrete el).contents pad_fn1)) + ; elf64_section_name_as_string = (isec1.elf64_section_name_as_string) + }) :: x2 else x2) + (list_combine section_file_offsets + element_section_tag_pairs_sorted_by_address) x2) + in + let symtab = +( + (* Get all the symbols *)elf64_null_symbol_table_entry :: (let x2 = + ([]) in List.fold_right + (fun(maybe_range, tag) x2 -> + if true then + (match tag with + SymbolDef (d) -> + let nameidx = ((match String_table.find_string d.def_symname strtab with + Some idx1 -> let v = (Uint32.of_string + (Nat_big_num.to_string idx1)) + in + (* let _ = errln ("strtab: found `" ^ d.def_symname ^ "' at index " ^ (show v)) + in *) + v + | None -> failwith + "impossible: symbol name not in strtab we just created" + )) in + let (shndx1, svalue, sz) = ( + if d.def_syment.elf64_st_shndx = + Uint32.of_string + (Nat_big_num.to_string shn_abs) then + (d.def_syment.elf64_st_shndx, d.def_syment.elf64_st_value, d.def_syment.elf64_st_size) + else + let (el_name, (start, len)) = ((match maybe_range with + Some(el_name, (start, len)) -> + (el_name, + (start, len)) + | None -> + failwith + "impossible: non-ABS symbol with no range" + )) in + (Uint32.of_string + (Nat_big_num.to_string + ( (* what's the section index of this element? *) + let maybe_found = (mapMaybei + (fun i -> fun isec1 -> + if isec1.elf64_section_name_as_string + = + el_name then + Some i + else + None) + sorted_sections) + in + (match maybe_found with + [i] -> Nat_big_num.add + (Nat_big_num.of_int 1) + i + | [] ->Nat_big_num.of_int + (* HMM *) (*let _ = errln ("Couldn't compute section index of symbol " ^ d.def_symname) + in*) 0 + | _ -> failwith + ("internal error: multiple sections named " + ^ el_name) + ) )), + Uint64.of_string + (Nat_big_num.to_string + ( Nat_big_num.add start + (match Pmap.lookup el_name + img2.elements with + Some x -> (match x.startpos with + Some addr -> + addr + | None -> + failwith + "internal error: symbol defined in section with no address" + ) + | None -> failwith + "internal error: section (of symbol) not found" + ))), + Uint64.of_string + (Nat_big_num.to_string len) )) in + (* CHECK: can we expect these to be these usable, the way we generated them? *) + { elf64_st_name = nameidx + ; elf64_st_info = (d.def_syment.elf64_st_info) (* type, binding, visibility *) + ; elf64_st_other = (d.def_syment.elf64_st_other) + ; elf64_st_shndx = shndx1 ; elf64_st_value = svalue + ; elf64_st_size = sz } + (* FIXME: do we ever get symbolrefs? *) + | _ -> failwith "not a symbol tag, in symbol_tags" + ) :: x2 else x2) (list_combine symbol_ranges symbol_tags) x2)) + in + (*let _ = errln ("Building an ELF file from" ^ (show (length element_section_tag_pairs_sorted_by_address)) ^ " sections") + in*) + (* PROBLEM: + * sections' offset assignments depend on phnum. + * BUT + * phnum depends on sections' offset assignments! + * How do we break this cycle? + * We can get an upper bound on the number of phdrs, then + * fill them in later. + *) + (* How does the GNU BFD output a statically linked executable? + * First the ELF header, + * then program headers, + * then sections in order of address: + * .interp, these are all allocatable sections! with addresses! + * then .note.ABI-tag, + * then .note.gnu.build-id, + * then .gnu.hash, + * then .dynsym, + * then .dynstr, + * then .gnu.version, + * then .gnu.version_r, + * then ... + * + * ... and so on ... + * + * then .gnu.debuglink (the only non-allocatable section) + * then .shstrtab, then SHT. + * + * So how can we calculate the offset of the SHT? We have to place + * all the other sections first. + *) + let shstrndx = (Nat_big_num.add(Nat_big_num.of_int 1) (length section_tags)) + in + let shstroff = last_off + in + let shstrsz = (String_table.size0 shstrtab) + in + let symoff = (align_up_to(Nat_big_num.of_int 8) ( Nat_big_num.add shstroff shstrsz)) + in + let symsz = (Nat_big_num.mul(Nat_big_num.of_int 24) (length symtab)) + in + let stroff = (Nat_big_num.add symoff symsz) + in + let strsz = (String_table.size0 strtab) + in + let shoff = (align_up_to(Nat_big_num.of_int 64) ( Nat_big_num.add stroff strsz)) + in + let shnum = (Nat_big_num.add(Nat_big_num.of_int 4) (length sorted_sections)) (* null, shstrtab, symtab, strtab *) + in + let (entry : Nat_big_num.num) = ((match Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (EntryPoint) img2.by_tag with + [(_, maybe_el_range)] -> + (match maybe_el_range with + Some (el_name, (start, len)) -> + address_of_range (el_name, (start, len)) img2 + | None -> failwith "entry point defined without a range" + ) + | [] -> failwith "no entry point defined" + | _ -> failwith "multiple entry points defined" + )) + in + let hdr = (a.make_elf_header elf_ft_exec entry shoff phoff max_phnum1 shnum shstrndx) + in + let endian = (if (Lem.option_equal (=) (Ml_bindings.list_index_big_int elf_ii_data hdr.elf64_ident) (Some(Uint32.of_string (Nat_big_num.to_string elf_data_2lsb)))) then Little else Big) + in + let all_sections_sorted_with_offsets = (List.rev_append (List.rev user_sections_sorted_with_offsets) [ + { elf64_section_name = ((match String_table.find_string ".shstrtab" shstrtab with + Some n -> n + | None -> failwith "internal error: `.shstrtab' not in shstrtab" + )) + ; elf64_section_type = sht_strtab + ; elf64_section_flags =(Nat_big_num.of_int 0) + ; elf64_section_addr =(Nat_big_num.of_int 0) + ; elf64_section_offset = shstroff + ; elf64_section_size = shstrsz + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 0) + ; elf64_section_entsize =(Nat_big_num.of_int 0) + ; elf64_section_body = (Sequence(Lem_list.map (fun x-> x) (Xstring.explode (String_table.get_base_string shstrtab)))) + ; elf64_section_name_as_string = ".shstrtab" + }; + { elf64_section_name = ((match String_table.find_string ".symtab" shstrtab with + Some n -> n + | None -> failwith "internal error: `.symtab' not in shstrtab" + )) + ; elf64_section_type = sht_symtab + ; elf64_section_flags =(Nat_big_num.of_int 0) + ; elf64_section_addr =(Nat_big_num.of_int 0) + ; elf64_section_offset = symoff + ; elf64_section_size = symsz + ; elf64_section_link = (Nat_big_num.add (Nat_big_num.add(Nat_big_num.of_int 1) (length user_sections_sorted_with_offsets))(Nat_big_num.of_int 2)) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 8) + ; elf64_section_entsize =(Nat_big_num.of_int 24) + ; elf64_section_body = (Byte_sequence.concat0 (Lem_list.map (bytes_of_elf64_symbol_table_entry endian) symtab)) + ; elf64_section_name_as_string = ".symtab" + }; + (* strtab *) + { elf64_section_name = ((match String_table.find_string ".strtab" shstrtab with + Some n -> n + | None -> failwith "internal error: `.strtab' not in shstrtab" + )) + ; elf64_section_type = sht_strtab + ; elf64_section_flags =(Nat_big_num.of_int 0) + ; elf64_section_addr =(Nat_big_num.of_int 0) + ; elf64_section_offset = stroff + ; elf64_section_size = strsz + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 1) + ; elf64_section_entsize =(Nat_big_num.of_int 0) + ; elf64_section_body = (Sequence(Lem_list.map (fun x-> x) (Xstring.explode (String_table.get_base_string strtab)))) + ; elf64_section_name_as_string = ".strtab" + } + ]) + in + let phdrs = (a.make_phdrs a.maxpagesize a.commonpagesize elf_ft_exec img2 all_sections_sorted_with_offsets) + in + { elf64_file_header = ({ (* fix up hdr with the precise phnum *) + elf64_ident = (hdr.elf64_ident) + ; elf64_type = (hdr.elf64_type) + ; elf64_machine = (hdr.elf64_machine) + ; elf64_version = (hdr.elf64_version) + ; elf64_entry = (hdr.elf64_entry) + ; elf64_phoff = (hdr.elf64_phoff) + ; elf64_shoff = (hdr.elf64_shoff) + ; elf64_flags = (hdr.elf64_flags) + ; elf64_ehsize = (hdr.elf64_ehsize) + ; elf64_phentsize = (hdr.elf64_phentsize) + ; elf64_phnum = (Uint32.of_string (Nat_big_num.to_string (length phdrs))) + ; elf64_shentsize = (hdr.elf64_shentsize) + ; elf64_shnum = (hdr.elf64_shnum) + ; elf64_shstrndx = (hdr.elf64_shstrndx) + }) + ; elf64_file_program_header_table = phdrs + ; elf64_file_section_header_table = (elf64_null_section_header :: ((Lem_list.mapi (fun i -> fun isec1 -> + { elf64_sh_name = (let s = (isec1.elf64_section_name_as_string) in + (match String_table.find_string s shstrtab with + Some n -> Uint32.of_string (Nat_big_num.to_string n) + | None -> failwith ("internal error: section name `" ^ (s ^ "' not in shstrtab")) + )) + ; elf64_sh_type = (Uint32.of_string (Nat_big_num.to_string isec1.elf64_section_type)) + ; elf64_sh_flags = (Uint64.of_string (Nat_big_num.to_string isec1.elf64_section_flags)) + ; elf64_sh_addr = (Uint64.of_string (Nat_big_num.to_string isec1.elf64_section_addr)) + ; elf64_sh_offset = (Uint64.of_string (Nat_big_num.to_string isec1.elf64_section_offset)) + ; elf64_sh_size = (Uint64.of_string (Nat_big_num.to_string isec1.elf64_section_size)) + ; elf64_sh_link = (Uint32.of_string (Nat_big_num.to_string isec1.elf64_section_link)) + ; elf64_sh_info = (Uint32.of_string (Nat_big_num.to_string isec1.elf64_section_info)) + ; elf64_sh_addralign = (Uint64.of_string (Nat_big_num.to_string isec1.elf64_section_align)) + ; elf64_sh_entsize = (Uint64.of_string (Nat_big_num.to_string isec1.elf64_section_entsize)) + } + )) (* (zip section_tags_bare section_file_offsets) *) all_sections_sorted_with_offsets)) + ; elf64_file_interpreted_segments = ([ + (* do we need to build this? I have HACKed elf_file so that we don't; + we assume that all the relevant payload is in the section bodies, + as it should be. *) + ]) + ; elf64_file_interpreted_sections = (null_elf64_interpreted_section :: all_sections_sorted_with_offsets) + ; elf64_file_bits_and_bobs = ([]) + }) diff --git a/lib/ocaml_rts/linksem/elf_dynamic.ml b/lib/ocaml_rts/linksem/elf_dynamic.ml new file mode 100644 index 00000000..0355337e --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_dynamic.ml @@ -0,0 +1,1202 @@ +(*Generated by Lem from elf_dynamic.lem.*) +(** [elf_dynamic] module exports types and definitions relating to the dynamic + * section and dynamic linking functionality of an ELF file. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_string + +open Byte_sequence +open Endianness +open Error +open Show +open String_table + +open Elf_file +open Elf_header +open Elf_relocation +open Elf_section_header_table +open Elf_program_header_table +open Elf_types_native_uint + +(** Validity checks *) + +(** [is_elf32_valid_program_header_table_for_dynamic_linking pht] checks whether + * a program header table [pht] is a valid program header table for an ELF file + * that will be potentially dynamically linked. Returns true if there is exactly + * one segment header of type [elf_pt_interp], i.e. contains a string pointing + * to the requested dynamic interpreter. + *) +(*val is_elf32_valid_program_header_table_for_dynamic_linking : elf32_program_header_table -> + bool*) +let is_elf32_valid_program_header_table_for_dynamic_linking pht:bool= + (List.length (List.filter (fun x -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string x.elf32_p_type)) elf_pt_interp) pht) = 1) + +(** [is_elf64_valid_program_header_table_for_dynamic_linking pht] checks whether + * a program header table [pht] is a valid program header table for an ELF file + * that will be potentially dynamically linked. Returns true if there is exactly + * one segment header of type [elf_pt_interp], i.e. contains a string pointing + * to the requested dynamic interpreter. + *) +(*val is_elf64_valid_program_header_table_for_dynamic_linking : elf64_program_header_table -> + bool*) +let is_elf64_valid_program_header_table_for_dynamic_linking pht:bool= + (List.length (List.filter (fun x -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string x.elf64_p_type)) elf_pt_interp) pht) = 1) + +(** Dynamic section entry *) + +(** [dyn_union] represents the C-union type used in the definition of [elf32_dyn] + * and [elf64_dyn] types below. Some section tags correspond to entries where + * the fields are either unspecified or ignored, hence the presence of the + * [D_Ignored] constructor. + *) +type( 'a, 'b) dyn_union + = D_Val of 'a + | D_Ptr of 'b + | D_Ignored of byte_sequence + +(** [elf32_dyn] captures the notion of an ELF32 dynamic section entry. + * Specialises the [dyn_union] type above to using [elf32_word] values and + * [elf32_addr] pointers. + *) +type elf32_dyn = + { elf32_dyn_tag : Int32.t (** The type of the entry. *) + ; elf32_dyn_d_un : (Uint32.uint32, Uint32.uint32) dyn_union (** The value of the entry, stored as a union. *) + } + +(** [elf64_dyn] captures the notion of an ELF32 dynamic section entry. + * Specialises the [dyn_union] type above to using [elf64_xword] values and + * [elf64_addr] pointers. + *) +type elf64_dyn = + { elf64_dyn_tag : Int64.t (** The type of the entry. *) + ; elf64_dyn_d_un : (Uint64.uint64, Uint64.uint64) dyn_union (** The value of the entry, stored as a union. *) + } + +(** Dynamic section tags *) + +(** [dt_null] marks the end of the dynamic array *) +let dt_null : Nat_big_num.num= (Nat_big_num.of_int 0) +(** [dt_needed] holds the string table offset of a string containing the name of + * a needed library. + *) +let dt_needed : Nat_big_num.num= (Nat_big_num.of_int 1) +(** [dt_pltrelsz] holds the size in bytes of relocation entries associated with + * the PLT. + *) +let dt_pltrelsz : Nat_big_num.num= (Nat_big_num.of_int 2) +(** [dt_pltgot] holds an address associated with the PLT or GOT. *) +let dt_pltgot : Nat_big_num.num= (Nat_big_num.of_int 3) +(** [dt_hash] holds the address of a symbol-table hash. *) +let dt_hash : Nat_big_num.num= (Nat_big_num.of_int 4) +(** [dt_strtab] holds the address of the string table. *) +let dt_strtab : Nat_big_num.num= (Nat_big_num.of_int 5) +(** [dt_symtab] holds the address of a symbol table. *) +let dt_symtab : Nat_big_num.num= (Nat_big_num.of_int 6) +(** [dt_rela] holds the address of a relocation table. *) +let dt_rela : Nat_big_num.num= (Nat_big_num.of_int 7) +(** [dt_relasz] holds the size in bytes of the relocation table. *) +let dt_relasz : Nat_big_num.num= (Nat_big_num.of_int 8) +(** [dt_relaent] holds the size in bytes of a relocation table entry. *) +let dt_relaent : Nat_big_num.num= (Nat_big_num.of_int 9) +(** [dt_strsz] holds the size in bytes of the string table. *) +let dt_strsz : Nat_big_num.num= (Nat_big_num.of_int 10) +(** [dt_syment] holds the size in bytes of a symbol table entry. *) +let dt_syment : Nat_big_num.num= (Nat_big_num.of_int 11) +(** [dt_init] holds the address of the initialisation function. *) +let dt_init : Nat_big_num.num= (Nat_big_num.of_int 12) +(** [dt_fini] holds the address of the finalisation function. *) +let dt_fini : Nat_big_num.num= (Nat_big_num.of_int 13) +(** [dt_soname] holds the string table offset of a string containing the shared- + * object name. + *) +let dt_soname : Nat_big_num.num= (Nat_big_num.of_int 14) +(** [dt_rpath] holds the string table offset of a string containing the library + * search path. + *) +let dt_rpath : Nat_big_num.num= (Nat_big_num.of_int 15) +(** [dt_symbolic] alters the linker's symbol resolution algorithm so that names + * are resolved first from the shared object file itself, rather than the + * executable file. + *) +let dt_symbolic : Nat_big_num.num= (Nat_big_num.of_int 16) +(** [dt_rel] is similar to [dt_rela] except its table has implicit addends. *) +let dt_rel : Nat_big_num.num= (Nat_big_num.of_int 17) +(** [dt_relsz] holds the size in bytes of the [dt_rel] relocation table. *) +let dt_relsz : Nat_big_num.num= (Nat_big_num.of_int 18) +(** [dt_relent] holds the size in bytes of a [dt_rel] relocation entry. *) +let dt_relent : Nat_big_num.num= (Nat_big_num.of_int 19) +(** [dt_pltrel] specifies the type of relocation entry to which the PLT refers. *) +let dt_pltrel : Nat_big_num.num= (Nat_big_num.of_int 20) +(** [dt_debug] is used for debugging and its purpose is not specified in the ABI. + * Programs using this entry are not ABI-conformant. + *) +let dt_debug : Nat_big_num.num= (Nat_big_num.of_int 21) +(** [dt_textrel] absence of this entry indicates that no relocation entry should + * cause a modification to a non-writable segment. Otherwise, if present, one + * or more relocation entries may request modifications to a non-writable + * segment. + *) +let dt_textrel : Nat_big_num.num= (Nat_big_num.of_int 22) +(** [dt_jmprel]'s member holds the address of relocation entries associated with + * the PLT. + *) +let dt_jmprel : Nat_big_num.num= (Nat_big_num.of_int 23) +(** [dt_bindnow] instructs the linker to process all relocations for the object + * containing the entry before transferring control to the program. + *) +let dt_bindnow : Nat_big_num.num= (Nat_big_num.of_int 24) +(** [dt_init_array] holds the address to the array of pointers to initialisation + * functions. + *) +let dt_init_array : Nat_big_num.num= (Nat_big_num.of_int 25) +(** [dt_fini_array] holds the address to the array of pointers to finalisation + * functions. + *) +let dt_fini_array : Nat_big_num.num= (Nat_big_num.of_int 26) +(** [dt_init_arraysz] holds the size in bytes of the array of pointers to + * initialisation functions. + *) +let dt_init_arraysz : Nat_big_num.num= (Nat_big_num.of_int 27) +(** [dt_fini_arraysz] holds the size in bytes of the array of pointers to + * finalisation functions. + *) +let dt_fini_arraysz : Nat_big_num.num= (Nat_big_num.of_int 28) +(** [dt_runpath] holds an offset into the string table holding a string containing + * the library search path. + *) +let dt_runpath : Nat_big_num.num= (Nat_big_num.of_int 29) +(** [dt_flags] holds flag values specific to the object being loaded. *) +let dt_flags : Nat_big_num.num= (Nat_big_num.of_int 30) +let dt_encoding : Nat_big_num.num= (Nat_big_num.of_int 32) +(** [dt_preinit_array] holds the address to the array of pointers of pre- + * initialisation functions. + *) +let dt_preinit_array : Nat_big_num.num= (Nat_big_num.of_int 32) +(** [dt_preinit_arraysz] holds the size in bytes of the array of pointers of + * pre-initialisation functions. + *) +let dt_preinit_arraysz : Nat_big_num.num= (Nat_big_num.of_int 33) +(** [dt_loos] and [dt_hios]: this inclusive range is reserved for OS-specific + * semantics. + *) +let dt_loos : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 805306374))(Nat_big_num.of_int 1)) (* 0x6000000D *) +let dt_hios : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939522048)) (* 0x6ffff000 *) +(** [dt_loproc] and [dt_hiproc]: this inclusive range is reserved for processor + * specific semantics. + *) +let dt_loproc : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524096)) (* 0x70000000 *) +let dt_hiproc : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 1073741823))(Nat_big_num.of_int 1)) (* 0x7fffffff *) + +(** [string_of_dynamic_tag so t os proc] produces a string-based representation of + * dynamic section tag [t]. For tag values between LO_OS and HI_OS [os] is + * used to produce the resulting value. For tag values between LO_PROC and + * HI_PROC [proc] is used to produce the resulting value. Boolean flag [so] + * indicates whether the flag in question is derived from a shared object file, + * which alters the printing of ENCODING and PRE_INITARRAY flags. + *) +(*val string_of_dynamic_tag : bool -> natural -> (natural -> bool) -> (natural -> string) -> (natural -> string) + -> string*) +let string_of_dynamic_tag shared_object tag os_additional_ranges os proc:string= + (if Nat_big_num.equal tag dt_null then + "NULL" + else if Nat_big_num.equal tag dt_needed then + "NEEDED" + else if Nat_big_num.equal tag dt_pltrelsz then + "PLTRELSZ" + else if Nat_big_num.equal tag dt_pltgot then + "PLTGOT" + else if Nat_big_num.equal tag dt_hash then + "HASH" + else if Nat_big_num.equal tag dt_strtab then + "STRTAB" + else if Nat_big_num.equal tag dt_symtab then + "SYMTAB" + else if Nat_big_num.equal tag dt_rela then + "RELA" + else if Nat_big_num.equal tag dt_relasz then + "RELASZ" + else if Nat_big_num.equal tag dt_relaent then + "RELAENT" + else if Nat_big_num.equal tag dt_strsz then + "STRSZ" + else if Nat_big_num.equal tag dt_syment then + "SYMENT" + else if Nat_big_num.equal tag dt_init then + "INIT" + else if Nat_big_num.equal tag dt_fini then + "FINI" + else if Nat_big_num.equal tag dt_soname then + "SONAME" + else if Nat_big_num.equal tag dt_rpath then + "RPATH" + else if Nat_big_num.equal tag dt_symbolic then + "SYMBOLIC" + else if Nat_big_num.equal tag dt_rel then + "REL" + else if Nat_big_num.equal tag dt_relsz then + "RELSZ" + else if Nat_big_num.equal tag dt_relent then + "RELENT" + else if Nat_big_num.equal tag dt_pltrel then + "PLTREL" + else if Nat_big_num.equal tag dt_debug then + "DEBUG" + else if Nat_big_num.equal tag dt_textrel then + "TEXTREL" + else if Nat_big_num.equal tag dt_jmprel then + "JMPREL" + else if Nat_big_num.equal tag dt_bindnow then + "BIND_NOW" + else if Nat_big_num.equal tag dt_init_array then + "INIT_ARRAY" + else if Nat_big_num.equal tag dt_fini_array then + "FINI_ARRAY" + else if Nat_big_num.equal tag dt_init_arraysz then + "INIT_ARRAYSZ" + else if Nat_big_num.equal tag dt_fini_arraysz then + "FINI_ARRAYSZ" + else if Nat_big_num.equal tag dt_runpath then + "RUNPATH" + else if Nat_big_num.equal tag dt_flags then + "FLAGS" + else if Nat_big_num.equal tag dt_encoding then + if not shared_object then + "ENCODING" + else + "PREINIT_ARRAY" + else if Nat_big_num.equal tag dt_preinit_arraysz then + "PREINIT_ARRAYSZ" + else if Nat_big_num.greater_equal tag dt_loproc && Nat_big_num.less_equal tag dt_hiproc then + proc tag + else if Nat_big_num.greater_equal tag dt_loos && Nat_big_num.less_equal tag dt_hios then + os tag + else if os_additional_ranges tag then + os tag + else + "Invalid dynamic section tag") + +(** [tag_correspondence] is a type used to emulate the functionality of a C-union + * in Lem. The type records whether the union should be interpreted as a value, + * a pointer, or a "do not care" value. An accompanying function will map a + * dynamic section tag to a [tag_correspondence], so that transcription functions + * know how to properly use the [dyn_union] value in a dynamic section entry. + *) +type tag_correspondence + = C_Val (** [dyn_union] should be interpreted as a value. *) + | C_Ptr (** [dyn_union] should be interpreted as a pointer. *) + | C_Ignored (** [dyn_union] is irrelevant, so we do not care. *) + +(** [tag_correspondence_of_tag tag os_additional_ranges os proc] produces a + * [tag_correspondence] value for a given dynamic tag, [tag]. Some tag values + * are reserved for interpretation by the OS or processor supplement (i.e. the + * ABI). We therefore also take in a predicate, [os_additional_ranges], that + * recognises when a tag is "special" for a given ABI, and a means of interpreting + * that tag, using [os] and [proc] functions. + *) +(*val tag_correspondence_of_tag : bool -> natural -> (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> error tag_correspondence*) +let tag_correspondence_of_tag shared_object tag os_additional_ranges os proc:(tag_correspondence)error= + (if Nat_big_num.equal tag dt_null then + return C_Ignored + else if Nat_big_num.equal tag dt_needed then + return C_Val + else if Nat_big_num.equal tag dt_pltrelsz then + return C_Val + else if Nat_big_num.equal tag dt_pltgot then + return C_Ptr + else if Nat_big_num.equal tag dt_hash then + return C_Ptr + else if Nat_big_num.equal tag dt_strtab then + return C_Ptr + else if Nat_big_num.equal tag dt_symtab then + return C_Ptr + else if Nat_big_num.equal tag dt_rela then + return C_Ptr + else if Nat_big_num.equal tag dt_relasz then + return C_Val + else if Nat_big_num.equal tag dt_relaent then + return C_Val + else if Nat_big_num.equal tag dt_strsz then + return C_Val + else if Nat_big_num.equal tag dt_syment then + return C_Val + else if Nat_big_num.equal tag dt_init then + return C_Ptr + else if Nat_big_num.equal tag dt_fini then + return C_Ptr + else if Nat_big_num.equal tag dt_soname then + return C_Val + else if Nat_big_num.equal tag dt_rpath then + return C_Val + else if Nat_big_num.equal tag dt_symbolic then + return C_Ignored + else if Nat_big_num.equal tag dt_rel then + return C_Ptr + else if Nat_big_num.equal tag dt_relsz then + return C_Val + else if Nat_big_num.equal tag dt_relent then + return C_Val + else if Nat_big_num.equal tag dt_pltrel then + return C_Val + else if Nat_big_num.equal tag dt_debug then + return C_Ptr + else if Nat_big_num.equal tag dt_textrel then + return C_Ignored + else if Nat_big_num.equal tag dt_jmprel then + return C_Ptr + else if Nat_big_num.equal tag dt_bindnow then + return C_Ignored + else if Nat_big_num.equal tag dt_init_array then + return C_Ptr + else if Nat_big_num.equal tag dt_fini_array then + return C_Ptr + else if Nat_big_num.equal tag dt_init_arraysz then + return C_Val + else if Nat_big_num.equal tag dt_fini_arraysz then + return C_Val + else if Nat_big_num.equal tag dt_runpath then + return C_Val + else if Nat_big_num.equal tag dt_flags then + return C_Val + else if Nat_big_num.equal tag dt_encoding then + if not shared_object then + return C_Ignored + else + return C_Ptr + else if Nat_big_num.equal tag dt_preinit_arraysz then + return C_Val + else if Nat_big_num.greater_equal tag dt_loproc && Nat_big_num.less_equal tag dt_hiproc then + proc tag + else if Nat_big_num.greater_equal tag dt_loos && Nat_big_num.less_equal tag dt_hios then + os tag + else if os_additional_ranges tag then + os tag + else + fail ("tag_correspondence_of_tag: invalid dynamic section tag")) + +(** [read_elf32_dyn endian bs0 so os_additional_ranges os proc] reads an [elf32_dyn] + * record from byte sequence [bs0], assuming endianness [endian]. As mentioned + * above some ABIs reserve additional tag values for their own purposes. These + * are recognised by the predicate [os_additional_ranges] and interpreted by + * the functions [os] and [proc]. Fails if the transcription of the record from + * [bs0] fails, or if [os] or [proc] fail. + *) +(*val read_elf32_dyn : endianness -> byte_sequence -> bool -> (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> error (elf32_dyn * byte_sequence)*) +let read_elf32_dyn endian bs0 shared_object os_additional_ranges os proc:(elf32_dyn*byte_sequence)error= + (read_elf32_sword endian bs0 >>= (fun (tag0, bs1) -> + let tag = (Nat_big_num.abs (Nat_big_num.of_int32 tag0)) in + tag_correspondence_of_tag shared_object tag os_additional_ranges os proc >>= (fun corr -> + (match corr with + | C_Ptr -> + read_elf32_addr endian bs1 >>= (fun (ptr, bs2) -> + return ({ elf32_dyn_tag = tag0 ; elf32_dyn_d_un = (D_Ptr ptr) }, bs2)) + | C_Val -> + read_elf32_word endian bs1 >>= (fun (vl, bs2) -> + return ({ elf32_dyn_tag = tag0 ; elf32_dyn_d_un = (D_Val vl) }, bs2)) + | C_Ignored -> + (match endian with + | Big -> + read_4_bytes_be bs1 >>= (fun ((b1, b2, b3, b4), bs2) -> + let cut = (Byte_sequence.from_byte_lists [[b1; b2; b3; b4]]) in + return ({ elf32_dyn_tag = tag0 ; elf32_dyn_d_un = (D_Ignored cut) }, bs2)) + | Little -> + read_4_bytes_le bs1 >>= (fun ((b1, b2, b3, b4), bs2) -> + let cut = (Byte_sequence.from_byte_lists [[b1; b2; b3; b4]]) in + return ({ elf32_dyn_tag = tag0 ; elf32_dyn_d_un = (D_Ignored cut) }, bs2)) + ) + )))) + +(** [read_elf64_dyn endian bs0 os_additional_ranges os proc] reads an [elf64_dyn] + * record from byte sequence [bs0], assuming endianness [endian]. As mentioned + * above some ABIs reserve additional tag values for their own purposes. These + * are recognised by the predicate [os_additional_ranges] and interpreted by + * the functions [os] and [proc]. Fails if the transcription of the record from + * [bs0] fails, or if [os] or [proc] fail. + *) +(*val read_elf64_dyn : endianness -> byte_sequence -> bool -> (natural -> bool) -> + (natural -> error tag_correspondence) -> (natural -> error tag_correspondence) -> + error (elf64_dyn * byte_sequence)*) +let read_elf64_dyn endian bs0 shared_object os_additional_ranges os proc:(elf64_dyn*byte_sequence)error= + (read_elf64_sxword endian bs0 >>= (fun (tag0, bs1) -> + let tag = (Nat_big_num.abs (Nat_big_num.of_int64 tag0)) in + tag_correspondence_of_tag shared_object tag os_additional_ranges os proc >>= (fun corr -> + (match corr with + | C_Ptr -> + read_elf64_addr endian bs1 >>= (fun (ptr, bs2) -> + return ({ elf64_dyn_tag = tag0 ; elf64_dyn_d_un = (D_Ptr ptr) }, bs2)) + | C_Val -> + read_elf64_xword endian bs1 >>= (fun (vl, bs2) -> + return ({ elf64_dyn_tag = tag0 ; elf64_dyn_d_un = (D_Val vl) }, bs2)) + | C_Ignored -> + (match endian with + | Big -> + read_8_bytes_be bs1 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs2) -> + let cut = (Byte_sequence.from_byte_lists [[b1; b2; b3; b4; b5; b6; b7; b8]]) in + return ({ elf64_dyn_tag = tag0 ; elf64_dyn_d_un = (D_Ignored cut) }, bs2)) + | Little -> + read_8_bytes_le bs1 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs2) -> + let cut = (Byte_sequence.from_byte_lists [[b1; b2; b3; b4; b5; b6; b7; b8]]) in + return ({ elf64_dyn_tag = tag0 ; elf64_dyn_d_un = (D_Ignored cut) }, bs2)) + ) + )))) + +(** [obtain_elf32_dynamic_section_contents' endian bs0 os_additional_ranges os + * proc] exhaustively reads in [elf32_dyn] values from byte sequence [bs0], + * interpreting ABI-specific dynamic tags with [os_additional_ranges], [os], and + * [proc] as mentioned above. Fails if [bs0]'s length modulo the size of an + * [elf32_dyn] entry is not 0. + *) +(*val obtain_elf32_dynamic_section_contents' : endianness -> byte_sequence -> + bool -> (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> error (list elf32_dyn)*) +let rec obtain_elf32_dynamic_section_contents' endian bs0 shared_object os_additional_ranges os proc:((elf32_dyn)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf32_dyn endian bs0 shared_object os_additional_ranges os proc >>= (fun (head, bs0) -> + if Nat_big_num.equal (Nat_big_num.of_int32 head.elf32_dyn_tag) ( dt_null) then (* DT_NULL marks end of array *) + return [head] + else + obtain_elf32_dynamic_section_contents' endian bs0 shared_object os_additional_ranges os proc >>= (fun tail -> + return (head::tail)))) + +(** [obtain_elf64_dynamic_section_contents' endian bs0 os_additional_ranges os + * proc] exhaustively reads in [elf64_dyn] values from byte sequence [bs0], + * interpreting ABI-specific dynamic tags with [os_additional_ranges], [os], and + * [proc] as mentioned above. Fails if [bs0]'s length modulo the size of an + * [elf64_dyn] entry is not 0. + *) +(*val obtain_elf64_dynamic_section_contents' : endianness -> byte_sequence -> + bool -> (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> error (list elf64_dyn)*) +let rec obtain_elf64_dynamic_section_contents' endian bs0 shared_object os_additional_ranges os proc:((elf64_dyn)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf64_dyn endian bs0 shared_object os_additional_ranges os proc >>= (fun (head, bs0) -> + if Nat_big_num.equal (Nat_big_num.of_int64 head.elf64_dyn_tag) ( dt_null) then (* DT_NULL marks end of array *) + return [head] + else + obtain_elf64_dynamic_section_contents' endian bs0 shared_object os_additional_ranges os proc >>= (fun tail -> + return (head::tail)))) + +(** [obtain_elf32_dynamic_section_contents' f1 os_additional_ranges os + * proc bs0] exhaustively reads in [elf32_dyn] values from byte sequence [bs0], + * obtaining endianness and the section header table from [elf32_file] f1, + * interpreting ABI-specific dynamic tags with [os_additional_ranges], [os], and + * [proc] as mentioned above. Fails if [bs0]'s length modulo the size of an + * [elf32_dyn] entry is not 0. + *) +(*val obtain_elf32_dynamic_section_contents : elf32_file -> + (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> byte_sequence -> error (list elf32_dyn)*) +let obtain_elf32_dynamic_section_contents f1 os_additional_ranges os proc bs0:((elf32_dyn)list)error= + (let endian = (get_elf32_header_endianness f1.elf32_file_header) in + let sht = (f1.elf32_file_section_header_table) in + let shared_object = (is_elf32_shared_object_file f1.elf32_file_header) in + (match List.filter (fun ent -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_type)) sht_dynamic) sht with + | [] -> fail "obtain_elf32_dynamic_section_contents: no SHT_DYNAMIC section header entries" + | [dyn] -> + let off = (Nat_big_num.of_string (Uint32.to_string dyn.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string dyn.elf32_sh_size)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + obtain_elf32_dynamic_section_contents' endian rel shared_object os_additional_ranges os proc) + | _ -> fail "obtain_elf32_dynamic_section_contents: multiple SHT_DYNAMIC section header entries" + )) + +(** [obtain_elf64_dynamic_section_contents' f1 os_additional_ranges os + * proc bs0] exhaustively reads in [elf64_dyn] values from byte sequence [bs0], + * obtaining endianness and the section header table from [elf64_file] f1, + * interpreting ABI-specific dynamic tags with [os_additional_ranges], [os], and + * [proc] as mentioned above. Fails if [bs0]'s length modulo the size of an + * [elf64_dyn] entry is not 0. + *) +(*val obtain_elf64_dynamic_section_contents : elf64_file -> + (natural -> bool) -> (natural -> error tag_correspondence) -> + (natural -> error tag_correspondence) -> byte_sequence -> error (list elf64_dyn)*) +let obtain_elf64_dynamic_section_contents f1 os_additional_ranges os proc bs0:((elf64_dyn)list)error= + (let endian = (get_elf64_header_endianness f1.elf64_file_header) in + let sht = (f1.elf64_file_section_header_table) in + let shared_object = (is_elf64_shared_object_file f1.elf64_file_header) in + (match List.filter (fun ent -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_type)) sht_dynamic) sht with + | [] -> fail "obtain_elf64_dynamic_section_contents: no SHT_DYNAMIC section header entries" + | [dyn] -> + let off = (Nat_big_num.of_string (Uint64.to_string dyn.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 dyn.elf64_sh_size) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + obtain_elf64_dynamic_section_contents' endian rel shared_object os_additional_ranges os proc) + | _ -> fail "obtain_elf64_dynamic_section_contents: multiple SHT_DYNAMIC section header entries" + )) + +(** DT Flags values *) + +(** [df_origin] specific that the object being loaded may make reference to the + * $(ORIGIN) substitution string. + *) +let df_origin : Nat_big_num.num= (Nat_big_num.of_int 1) (* 0x1 *) +(** [df_symbolic] changes the linker's symbol resolution algorithm, resolving + * symbols first from the shared object file rather than the executable file. + *) +let df_symbolic : Nat_big_num.num= (Nat_big_num.of_int 2) (* 0x2 *) +(** [df_textrel] if this flag is not set then no relocation entry should cause + * modification to a non-writable segment. + *) +let df_textrel : Nat_big_num.num= (Nat_big_num.of_int 4) (* 0x4 *) +(** [df_bindnow] if set this instructs the linker to process all relocation entries + * of the containing object before transferring control to the program. + *) +let df_bindnow : Nat_big_num.num= (Nat_big_num.of_int 8) (* 0x8 *) +(** [df_static_tls] if set instructs the linker to reject all attempts to load + * the containing file dynamically. + *) +let df_static_tls : Nat_big_num.num= (Nat_big_num.of_int 16) (* 0x10 *) + +(** [check_flag] is a utility function for testing whether a flag is set. + * TODO: so simple it is probably unneccessary now. + *) +(*val check_flag : natural -> natural -> bool*) +let check_flag m pos:bool= ( Nat_big_num.equal m pos) + +(** [string_of_dt_flag f] produces a string-based representation of dynamic + * section flag [f]. + *) +(*val string_of_dt_flag : natural -> string*) +let string_of_dt_flag flag:string= + (if check_flag flag(Nat_big_num.of_int 0) then + "None" + else if check_flag flag df_origin then + "ORIGIN" + else if check_flag flag df_bindnow then + "BIND_NOW" + else if check_flag flag df_symbolic then + "SYMBOLIC" + else if check_flag flag df_textrel then + "TEXTREL" + else if check_flag flag df_static_tls then + "STATIC_TLS" + else if check_flag flag ( Nat_big_num.add df_bindnow df_static_tls) then + "BIND_NOW STATIC_TLS" + else if check_flag flag ( Nat_big_num.add df_static_tls df_symbolic) then + "SYMBOLIC STATIC_TLS" + else (* XXX: add more as needed *) + "Invalid dynamic section flag") + +(** [rel_type] represents the two types of relocation records potentially present + * in an ELF file: relocation, and relocation with addends. + *) +type rel_type + = Rel (** Plain relocation type. *) + | RelA (** Relocation with addends type. *) + +(** [string_of_rel_type r] produces a string-based representation of [rel_type], + * [r]. + *) +(*val string_of_rel_type : rel_type -> string*) +let string_of_rel_type r:string= + ((match r with + | Rel -> "REL" + | RelA -> "RELA" + )) + +(** Type [dyn_value] represents the value of an ELF dynamic section entry. Values + * can represent various different types of objects (e.g. paths to libraries, or + * flags, or sizes of other entries in a file), and this type collates them all. + * Parameterised over two type variables so the type can be shared between ELF32 + * and ELF64. + *) +type( 'addr, 'size) dyn_value + = Address of 'addr (** An address. *) + | Size of 'size (** A size (in bytes). *) + | FName of string (** A filename. *) + | SOName of string (** A shared object name. *) + | Path of string (** A path to some directory. *) + | RPath of string (** A "run path". *) + | RunPath of string (** A "run path". *) + | Library of string (** A library path. *) + | Flags1 of Nat_big_num.num (** Flags. *) + | Flags of Nat_big_num.num (** Flags. *) + | Numeric of Nat_big_num.num (** An uninterpreted numeric value. *) + | Checksum of Nat_big_num.num (** A checksum value *) + | RelType of rel_type (** A relocation entry type. *) + | Timestamp of Nat_big_num.num (** A timestamp value. *) + | Null (** A null (0) value. *) + | Ignored (** An ignored value. *) + +(** [elf32_dyn_value] and [elf64_dyn_value] are specialisations of [dyn_value] + * fixing the correct types for the ['addr] and ['size] type variables. + *) +type elf32_dyn_value = (Uint32.uint32, Uint32.uint32) dyn_value +type elf64_dyn_value = (Uint64.uint64, Uint64.uint64) dyn_value + +(** [get_string_table_of_elf32_dyn_section endian dyns sht bs0] searches through + * dynamic section entries [dyns] looking for one pointing to a string table, looks + * up the corresponding section header [sht] pointed to by that dynamic + * section entry, finds the section in [bs0] and decodes a string table from that + * section assuming endianness [endian]. May fail. + *) +(*val get_string_table_of_elf32_dyn_section : endianness -> list elf32_dyn -> + elf32_section_header_table -> byte_sequence -> error string_table*) +let get_string_table_of_elf32_dyn_section endian dyns sht bs0:(string_table)error= + (let strtabs = +(List.filter (fun x -> Nat_big_num.equal +(Nat_big_num.of_int32 x.elf32_dyn_tag) ( dt_strtab) + ) dyns) + in + (match strtabs with + | [strtab] -> + (match strtab.elf32_dyn_d_un with + | D_Val v -> fail "get_string_table_of_elf32_dyn_section: STRTAB must be a PTR" + | D_Ptr p -> + let sect = +(List.filter (fun s -> +(s.elf32_sh_addr = p) && +(s.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string sht_strtab)) + ) sht) + in + (match sect with + | [] -> fail "get_string_table_of_elf32_dyn_section: no section entry with same address as STRTAB" + | [s] -> + let off = (Nat_big_num.of_string (Uint32.to_string s.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string s.elf32_sh_size)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + let strings = (Byte_sequence.string_of_byte_sequence rel) in + return (String_table.mk_string_table strings (Missing_pervasives.null_char))) + | _ -> fail "get_string_table_of_elf32_dyn_section: multiple section entries with same address as STRTAB" + ) + | D_Ignored i -> fail "get_string_table_of_elf32_dyn_section: STRTAB must be a PTR" + ) + | [] -> fail "get_string_table_of_elf32_dyn_section: no string table entry" + | _ -> fail "get_string_table_of_elf32_dyn_section: multiple string table entries" + )) + +(** [get_string_table_of_elf64_dyn_section endian dyns sht bs0] searches through + * dynamic section entries [dyns] looking for one pointing to a string table, looks + * up the corresponding section header [sht] pointed to by that dynamic + * section entry, finds the section in [bs0] and decodes a string table from that + * section assuming endianness [endian]. May fail. + *) +(*val get_string_table_of_elf64_dyn_section : endianness -> list elf64_dyn -> + elf64_section_header_table -> byte_sequence -> error string_table*) +let get_string_table_of_elf64_dyn_section endian dyns sht bs0:(string_table)error= + (let strtabs = +(List.filter (fun x -> Nat_big_num.equal +(Nat_big_num.of_int64 x.elf64_dyn_tag) ( dt_strtab) + ) dyns) + in + (match strtabs with + | [strtab] -> + (match strtab.elf64_dyn_d_un with + | D_Val v -> fail "get_string_table_of_elf64_dyn_section: STRTAB must be a PTR" + | D_Ptr p -> + let sect = +(List.filter (fun s -> +(s.elf64_sh_addr = p) && +(s.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string sht_strtab)) + ) sht) + in + (match sect with + | [] -> fail "get_string_table_of_elf64_dyn_section: no section entry with same address as STRTAB" + | [s] -> + let off = (Nat_big_num.of_string (Uint64.to_string s.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 s.elf64_sh_size) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + let strings = (Byte_sequence.string_of_byte_sequence rel) in + return (String_table.mk_string_table strings Missing_pervasives.null_char)) + | _ -> fail "get_string_table_of_elf64_dyn_section: multiple section entries with same address as STRTAB" + ) + | D_Ignored i -> fail "get_string_table_of_elf64_dyn_section: STRTAB must be a PTR" + ) + | [] -> fail "get_string_table_of_elf64_dyn_section: no string table entry" + | _ -> fail "get_string_table_of_elf64_dyn_section: multiple string table entries" + )) + +(** [get_value_of_elf32_dyn so dyn os_additional_ranges os proc stab] returns the value + * stored in a dynamic section entry [dyn], using [os_additional_ranges] and + * [os] to decode ABI-reserved tags. String table [stab] is used to correctly + * decode library and run paths, etc. + * May fail. + *) +(*val get_value_of_elf32_dyn : bool -> elf32_dyn -> (natural -> bool) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> + (elf32_dyn -> string_table -> error elf32_dyn_value) -> + string_table -> error elf32_dyn_value*) +let get_value_of_elf32_dyn shared_object dyn os_additional_ranges os proc stab:(((Uint32.uint32),(Uint32.uint32))dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int32 dyn.elf32_dyn_tag)) in + if Nat_big_num.equal tag dt_null then + return Null + else if Nat_big_num.equal tag dt_needed then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: NEEDED must be a Val" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: NEEDED must be a Val" + ) >>= (fun off -> + let off = (Nat_big_num.of_string (Uint32.to_string off)) in + String_table.get_string_at off stab >>= (fun str -> + return (Library str))) + else if Nat_big_num.equal tag dt_pltrelsz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: PLTRELSZ must be a Val" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: PLTRELSZ must be a Val" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_pltgot then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: PLTGOT must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: PLTGOT must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_hash then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: HASH must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: HASH must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_strtab then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: STRTAB must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: STRTAB must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_symtab then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: SYMTAB must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: SYMTAB must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_rela then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: RELA must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RELA must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_relasz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: RELASZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RELASZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_relaent then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: RELAENT must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RELAENT must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_strsz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: STRSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: STRSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_syment then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: SYMENT must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: SYMENT must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_init then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: INIT must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: INIT must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_fini then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: FINI must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: FINI must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_soname then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: SONAME must be a Val" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: SONAME must be a Val" + ) >>= (fun off -> + let off = (Nat_big_num.of_string (Uint32.to_string off)) in + String_table.get_string_at off stab >>= (fun str -> + return (SOName str))) + else if Nat_big_num.equal tag dt_rpath then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: RPATH must be a Val" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RPATH must be a Val" + ) >>= (fun off -> + let off = (Nat_big_num.of_string (Uint32.to_string off)) in + String_table.get_string_at off stab >>= (fun str -> + return (RPath str))) + else if Nat_big_num.equal tag dt_symbolic then + return Null + else if Nat_big_num.equal tag dt_rel then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: REL must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: REL must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_relsz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: RELSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RELSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_relent then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: RELENT must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RELENT must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_pltrel then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: PLTREL must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: PLTREL must be a VAL" + ) >>= (fun r -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string r)) dt_rel then + return (RelType Rel) + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string r)) dt_rela then + return (RelType RelA) + else + fail "get_value_of_elf32_dyn_entry: PLTREL neither REL nor RELA") + else if Nat_big_num.equal tag dt_debug then + return Null + else if Nat_big_num.equal tag dt_textrel then + return Null + else if Nat_big_num.equal tag dt_jmprel then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: JMPREL must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: JMPREL must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_bindnow then + return Ignored + else if Nat_big_num.equal tag dt_init_array then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: INIT_ARRAY must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: INIT_ARRAY must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_fini_array then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: FINI_ARRAY must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: FINI_ARRAY must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_init_arraysz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: INIT_ARRAYSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: INIT_ARRAYSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_fini_arraysz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: FINI_ARRAYSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: FINI_ARRAYSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_runpath then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: RUNPATH must be a Val" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: RUNPATH must be a Val" + ) >>= (fun off -> + let off = (Nat_big_num.of_string (Uint32.to_string off)) in + String_table.get_string_at off stab >>= (fun str -> + return (RunPath str))) + else if Nat_big_num.equal tag dt_flags then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: FLAGS must be a Val" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: FLAGS must be a Val" + ) >>= (fun flags -> + return (Flags (Nat_big_num.of_string (Uint32.to_string flags)))) + else if Nat_big_num.equal tag dt_encoding then + if not shared_object then + return Ignored + else + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "get_value_of_elf32_dyn_entry: PREINIT_ARRAY must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: PREINIT_ARRAY must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_preinit_arraysz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf32_dyn_entry: PREINIT_ARRAYSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf32_dyn_entry: PREINIT_ARRAYSZ must be a VAL" + ) >>= (fun sz -> + return (Checksum (Nat_big_num.of_string (Uint32.to_string sz)))) (** XXX: bug in readelf does not print this as a size! *) + else if Nat_big_num.greater_equal tag dt_loproc && Nat_big_num.less_equal tag dt_hiproc then + proc dyn stab + else if Nat_big_num.greater_equal tag dt_loos && Nat_big_num.less_equal tag dt_hios then + os dyn stab + else if os_additional_ranges tag then + os dyn stab + else + fail "get_value_of_elf32_dyn: unrecognised tag type") + +(** [get_value_of_elf64_dyn dyn os_additional_ranges os proc stab] returns the value + * stored in a dynamic section entry [dyn], using [os_additional_ranges] and + * [os] to decode ABI-reserved tags. String table [stab] is used to correctly + * decode library and run paths, etc. + * May fail. + *) +(*val get_value_of_elf64_dyn : bool -> elf64_dyn -> (natural -> bool) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> + (elf64_dyn -> string_table -> error elf64_dyn_value) -> + string_table -> error elf64_dyn_value*) +let get_value_of_elf64_dyn shared_object dyn os_additional_ranges os_dyn proc_dyn stab:(((Uint64.uint64),(Uint64.uint64))dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int64 dyn.elf64_dyn_tag)) in + if Nat_big_num.equal tag dt_null then + return Null + else if Nat_big_num.equal tag dt_needed then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: NEEDED must be a Val" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: NEEDED must be a Val" + ) >>= (fun off -> + let off = (Ml_bindings.nat_big_num_of_uint64 off) in + String_table.get_string_at off stab >>= (fun str -> + return (Library str))) + else if Nat_big_num.equal tag dt_pltrelsz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: PLTRELSZ must be a Val" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: PLTRELSZ must be a Val" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_pltgot then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: PLTGOT must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: PLTGOT must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_hash then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: HASH must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: HASH must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_strtab then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: STRTAB must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: STRTAB must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_symtab then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: SYMTAB must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: SYMTAB must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_rela then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: RELA must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RELA must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_relasz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: RELASZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RELASZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_relaent then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: RELAENT must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RELAENT must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_strsz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: STRSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: STRSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_syment then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: SYMENT must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: SYMENT must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_init then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: INIT must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: INIT must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_fini then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: FINI must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: FINI must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_soname then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: SONAME must be a Val" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: SONAME must be a Val" + ) >>= (fun off -> + let off = (Ml_bindings.nat_big_num_of_uint64 off) in + String_table.get_string_at off stab >>= (fun str -> + return (SOName str))) + else if Nat_big_num.equal tag dt_rpath then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: RPATH must be a Val" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RPATH must be a Val" + ) >>= (fun off -> + let off = (Ml_bindings.nat_big_num_of_uint64 off) in + String_table.get_string_at off stab >>= (fun str -> + return (RPath str))) + else if Nat_big_num.equal tag dt_symbolic then + return Null + else if Nat_big_num.equal tag dt_rel then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: REL must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: REL must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_relsz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: RELSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RELSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_relent then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: RELENT must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RELENT must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_pltrel then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: PLTREL must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: PLTREL must be a VAL" + ) >>= (fun r -> + if Nat_big_num.equal (Ml_bindings.nat_big_num_of_uint64 r) dt_rel then + return (RelType Rel) + else if Nat_big_num.equal (Ml_bindings.nat_big_num_of_uint64 r) dt_rela then + return (RelType RelA) + else + fail "get_value_of_elf64_dyn_entry: PLTREL neither REL nor RELA") + else if Nat_big_num.equal tag dt_debug then + return Null + else if Nat_big_num.equal tag dt_textrel then + return Null + else if Nat_big_num.equal tag dt_jmprel then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: JMPREL must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: JMPREL must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_bindnow then + return Ignored + else if Nat_big_num.equal tag dt_init_array then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: INIT_ARRAY must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: INIT_ARRAY must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_fini_array then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: FINI_ARRAY must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: FINI_ARRAY must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_init_arraysz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: INIT_ARRAYSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: INIT_ARRAYSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_fini_arraysz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: FINI_ARRAYSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: FINI_ARRAYSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag dt_runpath then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: RUNPATH must be a Val" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: RUNPATH must be a Val" + ) >>= (fun off -> + let off = (Ml_bindings.nat_big_num_of_uint64 off) in + String_table.get_string_at off stab >>= (fun str -> + return (RunPath str))) + else if Nat_big_num.equal tag dt_flags then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: FLAGS must be a Val" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: FLAGS must be a Val" + ) >>= (fun flags -> + return (Flags (Ml_bindings.nat_big_num_of_uint64 flags))) + else if Nat_big_num.equal tag dt_encoding then + if not shared_object then + return Ignored + else + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "get_value_of_elf64_dyn_entry: PREINIT_ARRAY must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: PREINIT_ARRAY must be a PTR" + ) >>= (fun ptr -> + return (Address ptr)) + else if Nat_big_num.equal tag dt_preinit_arraysz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "get_value_of_elf64_dyn_entry: PREINIT_ARRAYSZ must be a VAL" + | D_Ignored i -> fail "get_value_of_elf64_dyn_entry: PREINIT_ARRAYSZ must be a VAL" + ) >>= (fun sz -> + return (Checksum (Ml_bindings.nat_big_num_of_uint64 sz))) (** XXX: bug in readelf does not print this as a size! *) + else if Nat_big_num.greater_equal tag dt_loproc && Nat_big_num.less_equal tag dt_hiproc then + proc_dyn dyn stab + else if Nat_big_num.greater_equal tag dt_loos && Nat_big_num.less_equal tag dt_hios then + os_dyn dyn stab + else if os_additional_ranges tag then + os_dyn dyn stab + else + fail "get_value_of_elf64_dyn: unrecognised tag type") diff --git a/lib/ocaml_rts/linksem/elf_file.ml b/lib/ocaml_rts/linksem/elf_file.ml new file mode 100644 index 00000000..fda353f8 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_file.ml @@ -0,0 +1,1198 @@ +(*Generated by Lem from elf_file.lem.*) +(** Module [elf_file] packages all components of an ELF file up into a single + * record, provides I/O routines for this record, as well as other utility + * functions that operate on an entire ELF file. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_num +open Lem_maybe +open Lem_string + +open Elf_header +open Elf_interpreted_section +open Elf_interpreted_segment +open Elf_types_native_uint +open Elf_section_header_table +open Elf_symbol_table +open Elf_program_header_table + +open String_table + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +(** [elf32_file] record captures the internal structure of an ELF32 file. + * Invariant: length of the program header and section header tables should match + * the length of their interpreted counterparts, and the nth element of the + * (program/section) header table must correspond to the nth element of the + * interpreted (segments/sections), respectively. + *) +type elf32_file = + { elf32_file_header : elf32_header (** The file header. *) + ; elf32_file_program_header_table : elf32_program_header_table (** The program header table. *) + ; elf32_file_section_header_table : elf32_section_header_table (** The section header table. *) + ; elf32_file_interpreted_segments : elf32_interpreted_segments (** A more usable interpretation of the file's segments. *) + ; elf32_file_interpreted_sections : elf32_interpreted_sections (** A more usable interpretation of the file's sections. *) + ; elf32_file_bits_and_bobs : (Nat_big_num.num * byte_sequence) list (** The uninterpreted "rubbish" that may appear in gaps in the binary file. *) + } + +(** [bytes_of_elf32_file f1] blits ELF file [f1] to a byte sequence, ready for + * writing to a binary file. Fails if the invariant on [elf32_file] mentioned + * above is not respected. + *) +(*val bytes_of_elf32_file : elf32_file -> error byte_sequence*) +let bytes_of_elf32_file ef:(byte_sequence)error= + (let endian = (get_elf32_header_endianness ef.elf32_file_header) in + let hdr_bytes = (bytes_of_elf32_header ef.elf32_file_header) in + let hdr_layout = (Nat_big_num.of_int 0, hdr_bytes) in + let pht_bytes = (bytes_of_elf32_program_header_table endian ef.elf32_file_program_header_table) in + let sht_bytes = (bytes_of_elf32_section_header_table endian ef.elf32_file_section_header_table) in + let pht_off = (Nat_big_num.of_string (Uint32.to_string ef.elf32_file_header.elf32_phoff)) in + let sht_off = (Nat_big_num.of_string (Uint32.to_string ef.elf32_file_header.elf32_shoff)) in + let pht_layout = (pht_off, pht_bytes) in + let sht_layout = (sht_off, sht_bytes) in + let bab_layout = (ef.elf32_file_bits_and_bobs) in + if List.length ef.elf32_file_program_header_table = + List.length ef.elf32_file_interpreted_segments then + if List.length ef.elf32_file_section_header_table = + List.length ef.elf32_file_interpreted_sections then + let segs_zip = (Lem_list.list_combine ef.elf32_file_program_header_table ef.elf32_file_interpreted_segments) in + let sects_zip = (Lem_list.list_combine ef.elf32_file_section_header_table ef.elf32_file_interpreted_sections) in + let segs_layout = +(Lem_list.map (fun (seg, interp_seg) -> + (Nat_big_num.of_string (Uint32.to_string seg.elf32_p_offset), interp_seg.elf32_segment_body) + ) (List.filter (fun (x, _) -> not (x.elf32_p_filesz = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) segs_zip)) + in + let sects_layout = +(Lem_list.map (fun (sect, interp_sect) -> + (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_offset), interp_sect.elf32_section_body) + ) (List.filter (fun (x, _) -> not (x.elf32_sh_type = (Uint32.of_string (Nat_big_num.to_string sht_nobits)))) sects_zip)) + in + let pre_layout = (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev [hdr_layout; pht_layout; sht_layout]) sects_layout)) segs_layout)) bab_layout) in + let final_layout = +(List.sort (fun (off_x, _) (off_y, _) -> Nat_big_num.compare off_x off_y) + pre_layout) + in + let concats = +(foldM (fun x y -> + let (current_offset, so_far) = x in + let (point_to_add, body) = y in + if Nat_big_num.less point_to_add current_offset then + let diff = (Nat_big_num.sub_nat current_offset point_to_add) in + (* Completely contained inside other segment *) + if Nat_big_num.less (Byte_sequence.length0 body) diff then + return (current_offset, so_far) + else + Byte_sequence.partition0 diff body >>= (fun (_, cut) -> + let concat3 = (Byte_sequence.concat0 [so_far; cut]) in + let delta = (Nat_big_num.add current_offset (Byte_sequence.length0 cut)) in + return (delta, concat3)) + else + let diff = (Nat_big_num.sub_nat point_to_add current_offset) in + let reps = (Byte_sequence.create diff '\000') in + let concat3 = (Byte_sequence.concat0 [so_far; reps; body]) in + let delta = (Nat_big_num.add point_to_add (Byte_sequence.length0 body)) in + return (delta, concat3) + ) (Nat_big_num.of_int 0, Byte_sequence.empty) final_layout) + in + concats >>= (fun (offset, body) -> + return body) + else + fail "bytes_of_elf32_file: interpreted sections and section header table must have same length" + else + fail "bytes_of_elf32_file: interpreted segments and program header table must have same length") + +(** [elf64_file] record captures the internal structure of an ELF32 file. + * Invariant: length of the program header and section header tables should match + * the length of their interpreted counterparts, and the nth element of the + * (program/section) header table must correspond to the nth element of the + * interpreted (segments/sections), respectively. + *) +type elf64_file = + { elf64_file_header : elf64_header (** The file header. *) + ; elf64_file_program_header_table : elf64_program_header_table (** The program header table. *) + ; elf64_file_section_header_table : elf64_section_header_table (** The section header table. *) + ; elf64_file_interpreted_segments : elf64_interpreted_segments (** A more usable interpretation of the file's segments. *) + ; elf64_file_interpreted_sections : elf64_interpreted_sections (** A more usable interpretation of the file's sections. *) + ; elf64_file_bits_and_bobs : (Nat_big_num.num * byte_sequence) list (** The uninterpreted "rubbish" that may appear in gaps in the binary file. *) + } + + +type elf_file = + | ELF_File_32 of elf32_file + | ELF_File_64 of elf64_file + + + + +(** [bytes_of_elf64_file f1] blits ELF file [f1] to a byte sequence, ready for + * writing to a binary file. Fails if the invariant on [elf64_file] mentioned + * above is not respected. + *) +(*val bytes_of_elf64_file : elf64_file -> error byte_sequence*) +let bytes_of_elf64_file ef:(byte_sequence)error= + (let endian = (get_elf64_header_endianness ef.elf64_file_header) in + let hdr_bytes = (bytes_of_elf64_header ef.elf64_file_header) in + let hdr_layout = (Nat_big_num.of_int 0, hdr_bytes) in + let pht_bytes = (bytes_of_elf64_program_header_table endian ef.elf64_file_program_header_table) in + let sht_bytes = (bytes_of_elf64_section_header_table endian ef.elf64_file_section_header_table) in + let pht_off = (Nat_big_num.of_string (Uint64.to_string ef.elf64_file_header.elf64_phoff)) in + let sht_off = (Nat_big_num.of_string (Uint64.to_string ef.elf64_file_header.elf64_shoff)) in + let pht_layout = (pht_off, pht_bytes) in + let sht_layout = (sht_off, sht_bytes) in + let bab_layout = (ef.elf64_file_bits_and_bobs) in + if (* List.length ef.elf64_file_program_header_table = + List.length ef.elf64_file_interpreted_segments *) true then + if List.length ef.elf64_file_section_header_table = + List.length ef.elf64_file_interpreted_sections then + let segs_zip = (Lem_list.list_combine ef.elf64_file_program_header_table ef.elf64_file_interpreted_segments) in + let sects_zip = (Lem_list.list_combine ef.elf64_file_section_header_table ef.elf64_file_interpreted_sections) in + let segs_layout = ([]) (* + List.map (fun (seg, interp_seg) -> + (natural_of_elf64_off seg.elf64_p_offset, interp_seg.elf64_segment_body) + ) (List.filter (fun (x, _) -> x.elf64_p_filesz <> elf64_xword_of_natural 0) segs_zip) *) + in + let sects_layout = +(Lem_list.map (fun (sect, interp_sect) -> + (Nat_big_num.of_string (Uint64.to_string sect.elf64_sh_offset), interp_sect.elf64_section_body) + ) (List.filter (fun (x, _) -> not (x.elf64_sh_type = (Uint32.of_string (Nat_big_num.to_string sht_nobits)))) sects_zip)) + in + let pre_layout = (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev [hdr_layout; pht_layout; sht_layout]) sects_layout)) segs_layout)) bab_layout) in + let final_layout = +(List.sort (fun (off_x, _) (off_y, _) -> Nat_big_num.compare off_x off_y) + pre_layout) + in + let concats = +(foldM (fun x y -> + let (current_offset, so_far) = x in + let (point_to_add, body) = y in + if Nat_big_num.less point_to_add current_offset then + let diff = (Nat_big_num.sub_nat current_offset point_to_add) in + (* Completely contained inside other segment *) + if Nat_big_num.less (Byte_sequence.length0 body) diff then + return (current_offset, so_far) + else + Byte_sequence.partition0 diff body >>= (fun (_, cut) -> + let concat3 = (Byte_sequence.concat0 [so_far; cut]) in + let delta = (Nat_big_num.add current_offset (Byte_sequence.length0 cut)) in + return (delta, concat3)) + else + let diff = (Nat_big_num.sub_nat point_to_add current_offset) in + let reps = (Byte_sequence.create diff '\000') in + let concat3 = (Byte_sequence.concat0 [so_far; reps; body]) in + let delta = (Nat_big_num.add point_to_add (Byte_sequence.length0 body)) in + return (delta, concat3) + ) (Nat_big_num.of_int 0, Byte_sequence.empty) final_layout) + in + concats >>= (fun (offset, body) -> + return body) + else + fail "bytes_of_elf64_file: interpreted sections and section header table must have same length" + else + fail "bytes_of_elf64_file: interpreted segments and program header table must have same length") + +(** [obtain_elf32_program_header_table hdr bs0] reads a file's program header table + * from byte sequence [bs0] using information gleaned from the file header [hdr]. + * Fails if transcription fails. + *) +(*val obtain_elf32_program_header_table : elf32_header -> byte_sequence + -> error elf32_program_header_table*) +let obtain_elf32_program_header_table hdr bs0:((elf32_program_header_table_entry)list)error= + (let endian = (get_elf32_header_endianness hdr) in + let pentries = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_phnum)) in + let pentry_size = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_phentsize)) in + let psize = (Nat_big_num.mul pentries pentry_size) in + if Nat_big_num.equal psize(Nat_big_num.of_int 0) then + return [] + else + let poffset = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_phoff)) in + Byte_sequence.offset_and_cut poffset psize bs0 >>= (fun pexact -> + (* Byte sequence irrelevant below as exact size used... *) + read_elf32_program_header_table psize endian pexact >>= (fun (pht, _) -> + return pht))) + +(** [obtain_elf64_program_header_table hdr bs0] reads a file's program header table + * from byte sequence [bs0] using information gleaned from the file header [hdr]. + * Fails if transcription fails. + *) +(*val obtain_elf64_program_header_table : elf64_header -> byte_sequence + -> error elf64_program_header_table*) +let obtain_elf64_program_header_table hdr bs0:((elf64_program_header_table_entry)list)error= + (let endian = (get_elf64_header_endianness hdr) in + let pentries = (Nat_big_num.of_string (Uint32.to_string hdr.elf64_phnum)) in + let pentry_size = (Nat_big_num.of_string (Uint32.to_string hdr.elf64_phentsize)) in + let psize = (Nat_big_num.mul pentries pentry_size) in + if Nat_big_num.equal psize(Nat_big_num.of_int 0) then + return [] + else + let poffset = (Nat_big_num.of_string (Uint64.to_string hdr.elf64_phoff)) in + Byte_sequence.offset_and_cut poffset psize bs0 >>= (fun pexact -> + (* Byte sequence irrelevant below as exact size used... *) + read_elf64_program_header_table psize endian pexact >>= (fun (pht, _) -> + return pht))) + +(** [obtain_elf32_section_header_table hdr bs0] reads a file's section header table + * from byte sequence [bs0] using information gleaned from the file header [hdr]. + * Fails if transcription fails. + *) +(*val obtain_elf32_section_header_table : elf32_header -> byte_sequence + -> error elf32_section_header_table*) +let obtain_elf32_section_header_table hdr bs0:((elf32_section_header_table_entry)list)error= + (let endian = (get_elf32_header_endianness hdr) in + let sentries = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shnum)) in + let sentry_size = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shentsize)) in + let ssize = (Nat_big_num.mul sentries sentry_size) in + if Nat_big_num.equal ssize(Nat_big_num.of_int 0) then + return [] + else + let soffset = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shoff)) in + Byte_sequence.offset_and_cut soffset ssize bs0 >>= (fun sexact -> + (* Byte sequence irrelevant below as exact size used... *) + read_elf32_section_header_table ssize endian sexact >>= (fun (sht, _) -> + return sht))) + +(** [obtain_elf64_section_header_table hdr bs0] reads a file's section header table + * from byte sequence [bs0] using information gleaned from the file header [hdr]. + * Fails if transcription fails. + *) +(*val obtain_elf64_section_header_table : elf64_header -> byte_sequence -> error elf64_section_header_table*) +let obtain_elf64_section_header_table hdr bs0:((elf64_section_header_table_entry)list)error= + (let endian = (get_elf64_header_endianness hdr) in + let sentries = (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shnum)) in + let sentry_size = (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shentsize)) in + let ssize = (Nat_big_num.mul sentries sentry_size) in + if Nat_big_num.equal ssize(Nat_big_num.of_int 0) then + return [] + else + let soffset = (Nat_big_num.of_string (Uint64.to_string hdr.elf64_shoff)) in + Byte_sequence.offset_and_cut soffset ssize bs0 >>= (fun sexact -> + (* Byte sequence irrelevant below as exact size used... *) + read_elf64_section_header_table ssize endian sexact >>= (fun (sht, _) -> + return sht))) + +(** [obtain_elf32_section_header_string_table hdr sht bs0] reads a file's section + * header string table from byte sequence [bs0] using information gleaned from + * the file header [hdr] and section header table [sht]. + * Fails if transcription fails. + *) +(*val obtain_elf32_section_header_string_table : elf32_header -> + elf32_section_header_table -> byte_sequence -> error (maybe string_table)*) +let obtain_elf32_section_header_string_table hdr sht bs0:((string_table)option)error= + (if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shstrndx)) shn_undef then + return None + else + (match Ml_bindings.list_index_big_int (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shstrndx)) sht with + None -> fail "no section header string table" + | Some x -> return x + ) >>= (fun sh -> + Byte_sequence.offset_and_cut (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_offset)) (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_size)) bs0 >>= (fun sexact -> + return (Some (string_table_of_byte_sequence sexact))))) + +(** [obtain_elf64_section_header_string_table hdr sht bs0] reads a file's section + * header string table from byte sequence [bs0] using information gleaned from + * the file header [hdr] and section header table [sht]. + * Fails if transcription fails. + *) +(*val obtain_elf64_section_header_string_table : elf64_header -> + elf64_section_header_table -> byte_sequence -> error (maybe string_table)*) +let obtain_elf64_section_header_string_table hdr sht bs0:((string_table)option)error= + (if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shstrndx)) shn_undef then + return None + else + (match Ml_bindings.list_index_big_int (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shstrndx)) sht with + None -> fail "no section header string table" + | Some x -> return x + ) >>= (fun sh -> + Byte_sequence.offset_and_cut (Nat_big_num.of_string (Uint64.to_string sh.elf64_sh_offset)) (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_size) bs0 >>= (fun sexact -> + return (Some (string_table_of_byte_sequence sexact))))) + +(** [obtain_elf32_interpreted_segments pht bs0] generates the interpreted segments + * of an ELF file from the uninterpreted program header table entries in [pht], + * read from byte sequence [bs0]. Makes working with segments easier. + * May fail if transcription of any segment fails. + *) +(*val obtain_elf32_interpreted_segments : elf32_program_header_table -> byte_sequence + -> error elf32_interpreted_segments*) +let obtain_elf32_interpreted_segments pht bdy:((elf32_interpreted_segment)list)error= + (mapM (fun ph -> + let offset = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_filesz)) in + (if Nat_big_num.equal size2(Nat_big_num.of_int 0) then + return Byte_sequence.empty + else + Byte_sequence.offset_and_cut offset size2 bdy) >>= (fun relevant -> + let vaddr = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_vaddr)) in + let paddr = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_paddr)) in + let memsz = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_memsz)) in + let typ = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_type)) in + let align = (Nat_big_num.of_string (Uint32.to_string ph.elf32_p_align)) in + let flags = (elf32_interpret_program_header_flags ph.elf32_p_flags) in + if Nat_big_num.less memsz size2 then + fail "obtain_elf32_interpreted_segments: memory size of segment cannot be less than file size" + else + return { elf32_segment_body = relevant; elf32_segment_type = typ; + elf32_segment_size = size2; elf32_segment_memsz = memsz; + elf32_segment_base = vaddr; elf32_segment_flags = flags; + elf32_segment_paddr = paddr; elf32_segment_align = align; + elf32_segment_offset = offset }) + ) pht) + +(** [obtain_elf64_interpreted_segments pht bs0] generates the interpreted segments + * of an ELF file from the uninterpreted program header table entries in [pht], + * read from byte sequence [bs0]. Makes working with segments easier. + * May fail if transcription of any segment fails. + *) +(*val obtain_elf64_interpreted_segments : elf64_program_header_table -> byte_sequence + -> error elf64_interpreted_segments*) +let obtain_elf64_interpreted_segments pht bdy:((elf64_interpreted_segment)list)error= + (mapM (fun ph -> + let offset = (Nat_big_num.of_string (Uint64.to_string ph.elf64_p_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 ph.elf64_p_filesz) in + (if Nat_big_num.equal size2(Nat_big_num.of_int 0) then + return Byte_sequence.empty + else + Byte_sequence.offset_and_cut offset size2 bdy) >>= (fun relevant -> + let vaddr = (Ml_bindings.nat_big_num_of_uint64 ph.elf64_p_vaddr) in + let paddr = (Ml_bindings.nat_big_num_of_uint64 ph.elf64_p_paddr) in + let memsz = (Ml_bindings.nat_big_num_of_uint64 ph.elf64_p_memsz) in + let typ = (Nat_big_num.of_string (Uint32.to_string ph.elf64_p_type)) in + let align = (Ml_bindings.nat_big_num_of_uint64 ph.elf64_p_align) in + let flags = (elf64_interpret_program_header_flags ph.elf64_p_flags) in + if Nat_big_num.less memsz size2 then + fail "obtain_elf64_interpreted_segments: memory size of segment cannot be less than file size" + else + return { elf64_segment_body = relevant; elf64_segment_type = typ; + elf64_segment_size = size2; elf64_segment_memsz = memsz; + elf64_segment_base = vaddr; elf64_segment_flags = flags; + elf64_segment_align = align; elf64_segment_paddr = paddr; + elf64_segment_offset = offset }) + ) pht) + +(** [obtain_elf32_interpreted_section sht bs0] generates the interpreted sections + * of an ELF file from the uninterpreted section header table entries in [sht], + * read from byte sequence [bs0]. Makes working with sections easier. + * May fail if transcription of any section fails. + *) +(*val obtain_elf32_interpreted_sections : maybe string_table -> elf32_section_header_table + -> byte_sequence -> error elf32_interpreted_sections*) +let obtain_elf32_interpreted_sections shstrtab sht bs0:((elf32_interpreted_section)list)error= + (mapM (fun sh -> + let offset = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_size)) in + let name1 = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_name)) in + let typ = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_type)) in + let filesz = (if Nat_big_num.equal typ sht_nobits then Nat_big_num.of_int 0 else size2) in + let flags = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_flags)) in + let base = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_addr)) in + let link1 = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_link)) in + let info = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_info)) in + let align = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_addralign)) in + let entry_size = (Nat_big_num.of_string (Uint32.to_string sh.elf32_sh_entsize)) in + let name_string = +((match shstrtab with + None -> "" + | Some shstrtab -> + (match (get_string_at name1 shstrtab) with + | Success n -> n + | Fail _ -> "" + ) + )) + in + (if Nat_big_num.equal filesz(Nat_big_num.of_int 0) then + return Byte_sequence.empty + else + Byte_sequence.offset_and_cut offset filesz bs0) >>= (fun relevant -> + return { elf32_section_name = name1; elf32_section_type = typ; + elf32_section_size = size2; elf32_section_offset = offset; + elf32_section_flags = flags; elf32_section_addr = base; + elf32_section_link = link1; elf32_section_info = info; + elf32_section_align = align; elf32_section_body = relevant; + elf32_section_entsize = entry_size; + elf32_section_name_as_string = name_string }) + ) sht) + +(** [obtain_elf64_interpreted_section sht bs0] generates the interpreted sections + * of an ELF file from the uninterpreted section header table entries in [sht], + * read from byte sequence [bs0]. Makes working with sections easier. + * May fail if transcription of any section fails. + *) +(*val obtain_elf64_interpreted_sections : maybe string_table -> elf64_section_header_table + -> byte_sequence -> error elf64_interpreted_sections*) +let obtain_elf64_interpreted_sections shstrtab sht bs0:((elf64_interpreted_section)list)error= + (mapM (fun sh -> + let offset = (Nat_big_num.of_string (Uint64.to_string sh.elf64_sh_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_size) in + let name1 = (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_name)) in + let typ = (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_type)) in + let filesz = (if Nat_big_num.equal typ sht_nobits then Nat_big_num.of_int 0 else size2) in + let flags = (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_flags) in + let base = (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_addr) in + let link1 = (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_link)) in + let info = (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_info)) in + let align = (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_addralign) in + let entry_size = (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_entsize) in + let name_string = +((match shstrtab with + None -> "" + | Some shstrtab -> + (match (get_string_at name1 shstrtab) with + | Success n -> n + | Fail _ -> "" + ) + )) + in + (if Nat_big_num.equal filesz(Nat_big_num.of_int 0) then + return Byte_sequence.empty + else + Byte_sequence.offset_and_cut offset filesz bs0) >>= (fun relevant -> + return { elf64_section_name = name1; elf64_section_type = typ; + elf64_section_size = size2; elf64_section_offset = offset; + elf64_section_flags = flags; elf64_section_addr = base; + elf64_section_link = link1; elf64_section_info = info; + elf64_section_align = align; elf64_section_body = relevant; + elf64_section_entsize = entry_size; + elf64_section_name_as_string = name_string }) + ) sht) + +(** [find_first_not_in_range e rngs] for every pair (start, end) in [rngs], finds + * the first element, beginning counting from [e], that does not lie between + * a start and end value. + *) +(*val find_first_not_in_range : natural -> list (natural * natural) -> natural*) +let rec find_first_not_in_range start ranges:Nat_big_num.num= + ((match List.filter (fun (x, y) -> Nat_big_num.greater_equal start x && Nat_big_num.less_equal start y) ranges with + | [] -> start + | _ -> find_first_not_in_range ( Nat_big_num.add start(Nat_big_num.of_int 1)) ranges + )) + +(** [find_first_in_range e rngs] for every pair (start, end) in [rngs], finds + * the first element, beginning counting from [e], that lies between + * a start and end value. + *) +(*val find_first_in_range : natural -> list (natural * natural) -> natural*) +let rec find_first_in_range start ranges:Nat_big_num.num= + ((match List.filter (fun (x, y) -> Nat_big_num.greater_equal start x && Nat_big_num.less_equal start y) ranges with + | [] -> find_first_in_range ( Nat_big_num.add start(Nat_big_num.of_int 1)) ranges + | _ -> start + )) + +(** [compute_differences start max ranges] is a utility function used for calculating + * "dead" spots in an ELF file not covered by any of the interpreted structure + * that nevertheless need recording in the bits_and_bobs field of each ELF record + * in order to maintain in-out roundtripping up to exact binary equivalence. + *) +(*val compute_differences : natural -> natural -> list (natural * natural) -> error (list (natural * natural))*) +let rec compute_differences start max ranges:((Nat_big_num.num*Nat_big_num.num)list)error= + (if Nat_big_num.equal start max then + return [] + else if Nat_big_num.greater start max then + fail "compute_differences: passed maximum" + else + let first = (find_first_not_in_range start ranges) in + if Nat_big_num.greater_equal first max then + return [] + else + let last1 = (find_first_in_range first ranges) in + if Nat_big_num.greater last1 max then + return [(first, max)] + else + compute_differences last1 max ranges >>= (fun tail -> + return ((first, last1)::tail))) + +(** [obtain_elf32_bits_and_bobs hdr pht segs sht sects bs0] identifies and records + * the "dead" spots of an ELF file not covered by any meaningful structure of the + * ELF file format. + *) +(*val obtain_elf32_bits_and_bobs : elf32_header -> elf32_program_header_table -> elf32_interpreted_segments + -> elf32_section_header_table -> elf32_interpreted_sections -> byte_sequence -> error (list (natural * byte_sequence))*) +let obtain_elf32_bits_and_bobs hdr segs interp_segs sects interp_sects bs0:((Nat_big_num.num*byte_sequence)list)error= + (let hdr_off_len = (Nat_big_num.of_int 0, Nat_big_num.of_string (Uint32.to_string hdr.elf32_ehsize)) in + let pht_off = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_phoff)) in + let pht_len = (Nat_big_num.mul (Nat_big_num.of_string (Uint32.to_string hdr.elf32_phentsize)) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_phnum))) in + let pht_off_len = (pht_off, Nat_big_num.add pht_off pht_len) in + let sht_off = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shoff)) in + let sht_len = (Nat_big_num.mul (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shentsize)) (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shnum))) in + let sht_off_len = (sht_off, Nat_big_num.add sht_off sht_len) in + if List.length interp_segs = List.length segs then + let seg_zip = (Lem_list.list_combine segs interp_segs) in + if List.length interp_sects = List.length sects then + let sect_zip = (Lem_list.list_combine sects interp_sects) in + let seg_off_len = +(Lem_list.map (fun (seg, interp_seg) -> + let start = (Nat_big_num.of_string (Uint32.to_string seg.elf32_p_offset)) in + let len = (interp_seg.elf32_segment_size) in + (start, Nat_big_num.add start len)) seg_zip) + in + let sect_off_len = +(Lem_list.map (fun (sect, interp_sect) -> + let start = (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_offset)) in + let len = (interp_sect.elf32_section_size) in + (start, Nat_big_num.add start len)) sect_zip) + in + let pre_layout = (hdr_off_len :: (pht_off_len :: (sht_off_len :: List.rev_append (List.rev seg_off_len) sect_off_len))) in + let layout = +(List.sort (fun (off_x, _) (off_y, _) -> + Nat_big_num.compare off_x off_y + ) pre_layout) + in + compute_differences(Nat_big_num.of_int 0) (Byte_sequence.length0 bs0) layout >>= (fun diffs -> + mapM (fun (start, len) -> + Byte_sequence.offset_and_cut start ( Nat_big_num.sub_nat len start) bs0 >>= (fun rel -> + return (start, rel)) + ) diffs) + else + fail "obtain_elf32_bits_and_bobs: section header table and interpreted section differ in length" + else + fail "obtain_elf32_bits_and_bobs: program header table and interpreted segments differ in length") + +(** [obtain_elf64_bits_and_bobs hdr pht segs sht sects bs0] identifies and records + * the "dead" spots of an ELF file not covered by any meaningful structure of the + * ELF file format. + *) +(*val obtain_elf64_bits_and_bobs : elf64_header -> elf64_program_header_table -> elf64_interpreted_segments + -> elf64_section_header_table -> elf64_interpreted_sections -> byte_sequence -> error (list (natural * byte_sequence))*) +let obtain_elf64_bits_and_bobs hdr segs interp_segs sects interp_sects bs0:((Nat_big_num.num*byte_sequence)list)error= + (let hdr_off_len = (Nat_big_num.of_int 0, Nat_big_num.of_string (Uint32.to_string hdr.elf64_ehsize)) in + + let pht_off = (Nat_big_num.of_string (Uint64.to_string hdr.elf64_phoff)) in + let pht_len = (Nat_big_num.mul (Nat_big_num.of_string (Uint32.to_string hdr.elf64_phentsize)) (Nat_big_num.of_string (Uint32.to_string hdr.elf64_phnum))) in + let pht_off_len = (pht_off, Nat_big_num.add pht_off pht_len) in + let sht_off = (Nat_big_num.of_string (Uint64.to_string hdr.elf64_shoff)) in + let sht_len = (Nat_big_num.mul (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shentsize)) (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shnum))) in + let sht_off_len = (sht_off, Nat_big_num.add sht_off sht_len) in + if List.length interp_segs = List.length segs then + let seg_zip = (Lem_list.list_combine segs interp_segs) in + if List.length interp_sects = List.length sects then + let sect_zip = (Lem_list.list_combine sects interp_sects) in + let seg_off_len = +(Lem_list.map (fun (seg, interp_seg) -> + let start = (Nat_big_num.of_string (Uint64.to_string seg.elf64_p_offset)) in + let len = (interp_seg.elf64_segment_size) in + (start, Nat_big_num.add start len)) seg_zip) + in + let sect_off_len = +(Lem_list.map (fun (sect, interp_sect) -> + let start = (Nat_big_num.of_string (Uint64.to_string sect.elf64_sh_offset)) in + let len = (interp_sect.elf64_section_size) in + (start, Nat_big_num.add start len)) sect_zip) + in + let pre_layout = (hdr_off_len :: (pht_off_len :: (sht_off_len :: List.rev_append (List.rev seg_off_len) sect_off_len))) in + let layout = +(List.sort (fun (off_x, _) (off_y, _) -> + Nat_big_num.compare off_x off_y + ) pre_layout) + in + compute_differences(Nat_big_num.of_int 0) (Byte_sequence.length0 bs0) layout >>= (fun diffs -> + mapM (fun (start, finish) -> + Byte_sequence.offset_and_cut start ( Nat_big_num.sub_nat finish start) bs0 >>= (fun rel -> + return (start, rel)) + ) diffs) + else + fail "obtain_elf64_bits_and_bobs: section header table and interpreted section differ in length" + else + fail "obtain_elf64_bits_and_bobs: program header table and interpreted segments differ in length") + +(** [read_elf32_file bs0] reads an ELF32 file from byte sequence [bs0]. Fails if + * transcription fails. + *) +(*val read_elf32_file : byte_sequence -> error elf32_file*) +let read_elf32_file bs0:(elf32_file)error= + (read_elf32_header bs0 >>= (fun (hdr, bs1) -> + obtain_elf32_program_header_table hdr bs0 >>= (fun pht -> + obtain_elf32_section_header_table hdr bs0 >>= (fun sht -> + obtain_elf32_section_header_string_table hdr sht bs0 >>= (fun shstrtab -> + obtain_elf32_interpreted_segments pht bs0 >>= (fun segs -> + obtain_elf32_interpreted_sections shstrtab sht bs0 >>= (fun sects -> + obtain_elf32_bits_and_bobs hdr pht segs sht sects bs0 >>= (fun bits_and_bobs -> + return { elf32_file_header = hdr; + elf32_file_program_header_table = pht; + elf32_file_section_header_table = sht; + elf32_file_interpreted_segments = segs; + elf32_file_interpreted_sections = sects; + elf32_file_bits_and_bobs = bits_and_bobs })))))))) + +(** [read_elf64_file bs0] reads an ELF64 file from byte sequence [bs0]. Fails if + * transcription fails. + *) +(*val read_elf64_file : byte_sequence -> error elf64_file*) +let read_elf64_file bs0:(elf64_file)error= + (read_elf64_header bs0 >>= (fun (hdr, bs1) -> + obtain_elf64_program_header_table hdr bs0 >>= (fun pht -> + obtain_elf64_section_header_table hdr bs0 >>= (fun sht -> + obtain_elf64_section_header_string_table hdr sht bs0 >>= (fun shstrtab -> + obtain_elf64_interpreted_segments pht bs0 >>= (fun segs -> + obtain_elf64_interpreted_sections shstrtab sht bs0 >>= (fun sects -> + obtain_elf64_bits_and_bobs hdr pht segs sht sects bs0 >>= (fun bits_and_bobs -> + return { elf64_file_header = hdr; + elf64_file_program_header_table = pht; + elf64_file_section_header_table = sht; + elf64_file_interpreted_segments = segs; + elf64_file_interpreted_sections = sects; + elf64_file_bits_and_bobs = bits_and_bobs })))))))) + +(** [get_elf32_file_secton_header_string_table f1] returns the ELF file, [f1], + * section header string table. + * TODO: why is this not using obtain_elf32_section_header_string_table above? + *) +(*val get_elf32_file_section_header_string_table : elf32_file -> error string_table*) +let get_elf32_file_section_header_string_table f3:(string_table)error= + (let hdr = (f3.elf32_file_header) in + let sht = (f3.elf32_file_section_header_table) in + let segs = (f3.elf32_file_interpreted_segments) in + let idx1 = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shstrndx)) in + bytes_of_elf32_file f3 >>= (fun bs0 -> + (match Ml_bindings.list_index_big_int idx1 sht with + | None -> fail "obtain_elf32_string_table: invalid offset into section header table" + | Some sect -> + let offset = (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_size)) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun rel -> + let strings = (Byte_sequence.string_of_byte_sequence rel) in + return (String_table.mk_string_table strings Missing_pervasives.null_char)) + ))) + +(** [get_elf64_file_secton_header_string_table f1] returns the ELF file, [f1], + * section header string table. + * TODO: why is this not using obtain_elf64_section_header_string_table above? + *) +(*val get_elf64_file_section_header_string_table : elf64_file -> error string_table*) +let get_elf64_file_section_header_string_table f3:(string_table)error= + (let hdr = (f3.elf64_file_header) in + let sht = (f3.elf64_file_section_header_table) in + let segs = (f3.elf64_file_interpreted_segments) in + let idx1 = (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shstrndx)) in + bytes_of_elf64_file f3 >>= (fun bs0 -> + (match Ml_bindings.list_index_big_int idx1 sht with + | None -> fail "obtain_elf64_string_table: invalid offset into section header table" + | Some sect -> + let offset = (Nat_big_num.of_string (Uint64.to_string sect.elf64_sh_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 sect.elf64_sh_size) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun rel -> + let strings = (Byte_sequence.string_of_byte_sequence rel) in + return (String_table.mk_string_table strings Missing_pervasives.null_char)) + ))) + +(*val find_elf32_symbols_by_symtab_idx : natural -> elf32_file -> error (elf32_symbol_table * string_table * natural)*) +let find_elf32_symbols_by_symtab_idx sec_idx f:((elf32_symbol_table_entry)list*string_table*Nat_big_num.num)error= + ((match Lem_list.list_index f.elf32_file_interpreted_sections (Nat_big_num.to_int sec_idx) with + None -> fail "impossible: interpreted section found but not indexable" + | Some sec -> return sec + ) >>= (fun sec -> + (match Lem_list.list_index f.elf32_file_interpreted_sections (Nat_big_num.to_int sec.elf32_section_link) with + None -> fail "no associated strtab" + | Some strs -> return strs + ) >>= (fun strs -> + let strings = (Byte_sequence.string_of_byte_sequence strs.elf32_section_body) in + let strtab = (String_table.mk_string_table strings null_char) in + let endian = (get_elf32_header_endianness f.elf32_file_header) in + read_elf32_symbol_table endian sec.elf32_section_body >>= (fun symtab -> + return (symtab, strtab, sec_idx))))) + +(*val find_elf32_symtab_by_type : natural -> elf32_file -> error (elf32_symbol_table * string_table * natural)*) +let find_elf32_symtab_by_type t f:(elf32_symbol_table*string_table*Nat_big_num.num)error= + (let found_symtab_index = (find_index0 (fun sh -> Nat_big_num.equal sh.elf32_section_type t) f.elf32_file_interpreted_sections) in + (match found_symtab_index with + None -> fail "no such symtab" + | Some sec_idx -> return sec_idx + ) >>= (fun sec_idx -> find_elf32_symbols_by_symtab_idx sec_idx f)) + +(*val find_elf64_symbols_by_symtab_idx : natural -> elf64_file -> error (elf64_symbol_table * string_table * natural)*) +let find_elf64_symbols_by_symtab_idx sec_idx f:((elf64_symbol_table_entry)list*string_table*Nat_big_num.num)error= + ((match Lem_list.list_index f.elf64_file_interpreted_sections (Nat_big_num.to_int sec_idx) with + None -> fail "impossible: interpreted section found but not indexable" + | Some sec -> return sec + ) >>= (fun sec -> + (match Lem_list.list_index f.elf64_file_interpreted_sections (Nat_big_num.to_int sec.elf64_section_link) with + None -> fail "no associated strtab" + | Some strs -> return strs + ) >>= (fun strs -> + let strings = (Byte_sequence.string_of_byte_sequence strs.elf64_section_body) in + let strtab = (String_table.mk_string_table strings null_char) in + let endian = (get_elf64_header_endianness f.elf64_file_header) in + read_elf64_symbol_table endian sec.elf64_section_body >>= (fun symtab -> + return (symtab, strtab, sec_idx))))) + +(*val find_elf64_symtab_by_type : natural -> elf64_file -> error (elf64_symbol_table * string_table * natural)*) +let find_elf64_symtab_by_type t f:(elf64_symbol_table*string_table*Nat_big_num.num)error= + (let found_symtab_index = (find_index0 (fun sh -> Nat_big_num.equal sh.elf64_section_type t) f.elf64_file_interpreted_sections) in + (match found_symtab_index with + None -> fail "no such symtab" + | Some sec_idx -> return sec_idx + ) >>= (fun sec_idx -> find_elf64_symbols_by_symtab_idx sec_idx f)) + +(** [get_elf32_file_symbol_string_table f1] returns the ELF file [f1] symbol + * string table. May fail. + *) +(*val get_elf32_file_symbol_string_table : elf32_file -> error string_table*) +let get_elf32_file_symbol_string_table f3:(string_table)error= + (let hdr = (f3.elf32_file_header) in + let sht = (f3.elf32_file_section_header_table) in + let segs = (f3.elf32_file_interpreted_segments) in + let strtabs = (Missing_pervasives.mapMaybei (fun index sect -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_type)) sht_strtab then + if Nat_big_num.equal index (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shstrndx)) then + None + else + Some sect + else + None) sht) + in + bytes_of_elf32_file f3 >>= (fun bs0 -> + mapM (fun sect -> + let offset = (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_size)) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun bs1 -> + let strings = (Byte_sequence.string_of_byte_sequence bs1) in + return (String_table.mk_string_table strings Missing_pervasives.null_char))) strtabs + >>= (fun strings -> + String_table.concat1 strings))) + +(** [get_elf64_file_symbol_string_table f1] returns the ELF file [f1] symbol + * string table. May fail. + *) +(*val get_elf64_file_symbol_string_table : elf64_file -> error string_table*) +let get_elf64_file_symbol_string_table f3:(string_table)error= + (let hdr = (f3.elf64_file_header) in + let sht = (f3.elf64_file_section_header_table) in + let segs = (f3.elf64_file_interpreted_segments) in + let strtabs = (Missing_pervasives.mapMaybei (fun index sect -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string sect.elf64_sh_type)) sht_strtab then + if Nat_big_num.equal index (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shstrndx)) then + None + else + Some sect + else + None) sht) + in + bytes_of_elf64_file f3 >>= (fun bs0 -> + mapM (fun sect -> + let offset = (Nat_big_num.of_string (Uint64.to_string sect.elf64_sh_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 sect.elf64_sh_size) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun bs1 -> + let strings = (Byte_sequence.string_of_byte_sequence bs1) in + return (String_table.mk_string_table strings Missing_pervasives.null_char))) strtabs + >>= (fun strings -> + String_table.concat1 strings))) + +(** [get_elf32_file_symbol_table f1] returns the ELF file [f1] symbol + * table. May fail. + *) +(*val get_elf32_file_symbol_table : elf32_file -> error elf32_symbol_table*) +let get_elf32_file_symbol_table f3:((elf32_symbol_table_entry)list)error= + (let hdr = (f3.elf32_file_header) in + let sht = (f3.elf32_file_section_header_table) in + let segs = (f3.elf32_file_interpreted_segments) in + let endian = (get_elf32_header_endianness hdr) in + let symtabs = (List.filter (fun sect -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_type)) sht_symtab + ) sht) + in + (match symtabs with + | [] -> return [] + | [symtab] -> + let offset = (Nat_big_num.of_string (Uint32.to_string symtab.elf32_sh_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string symtab.elf32_sh_size)) in + bytes_of_elf32_file f3 >>= (fun bs0 -> + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun relevant -> + read_elf32_symbol_table endian relevant)) + | _ -> + fail "obtain_elf32_symbol_table: an ELF file may only have one symbol table of type SHT_SYMTAB" + )) + +(** [get_elf64_file_symbol_table f1] returns the ELF file [f1] symbol + * table. May fail. + *) +(*val get_elf64_file_symbol_table : elf64_file -> error elf64_symbol_table*) +let get_elf64_file_symbol_table f3:((elf64_symbol_table_entry)list)error= + (let hdr = (f3.elf64_file_header) in + let sht = (f3.elf64_file_section_header_table) in + let segs = (f3.elf64_file_interpreted_segments) in + let endian = (get_elf64_header_endianness hdr) in + let symtabs = (List.filter (fun sect -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string sect.elf64_sh_type)) sht_symtab + ) sht) + in + (match symtabs with + | [] -> return [] + | [symtab] -> + let offset = (Nat_big_num.of_string (Uint64.to_string symtab.elf64_sh_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 symtab.elf64_sh_size) in + bytes_of_elf64_file f3 >>= (fun bs0 -> + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun relevant -> + read_elf64_symbol_table endian relevant)) + | _ -> + fail "obtain_elf64_symbol_table: an ELF file may only have one symbol table of type SHT_SYMTAB" + )) + +(** [get_elf32_file_dynamic_symbol_table f1] returns the ELF file [f1] dynamic + * symbol table. May fail. + *) +(*val get_elf32_file_dynamic_symbol_table : elf32_file -> error elf32_symbol_table*) +let get_elf32_file_dynamic_symbol_table ef:((elf32_symbol_table_entry)list)error= + (let hdr = (ef.elf32_file_header) in + let sht = (ef.elf32_file_section_header_table) in + let segs = (ef.elf32_file_interpreted_segments) in + let endian = (get_elf32_header_endianness hdr) in + let symtabs = (List.filter (fun sect -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string sect.elf32_sh_type)) sht_dynsym + ) sht) + in + (match symtabs with + | [] -> return [] + | [symtab] -> + let offset = (Nat_big_num.of_string (Uint32.to_string symtab.elf32_sh_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string symtab.elf32_sh_size)) in + bytes_of_elf32_file ef >>= (fun bs0 -> + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun relevant -> + read_elf32_symbol_table endian relevant)) + | _ -> + fail "obtain_elf32_dynamic_symbol_table: an ELF file may only have one symbol table of type SHT_DYNSYM" + )) + +(** [get_elf64_file_dynamic_symbol_table f1] returns the ELF file [f1] dynamic + * symbol table. May fail. + *) +(*val get_elf64_file_dynamic_symbol_table : elf64_file -> error elf64_symbol_table*) +let get_elf64_file_dynamic_symbol_table ef:((elf64_symbol_table_entry)list)error= + (let hdr = (ef.elf64_file_header) in + let sht = (ef.elf64_file_section_header_table) in + let segs = (ef.elf64_file_interpreted_segments) in + let endian = (get_elf64_header_endianness hdr) in + let symtabs = (List.filter (fun sect -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string sect.elf64_sh_type)) sht_dynsym + ) sht) + in + (match symtabs with + | [] -> return [] + | [symtab] -> + let offset = (Nat_big_num.of_string (Uint64.to_string symtab.elf64_sh_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 symtab.elf64_sh_size) in + bytes_of_elf64_file ef >>= (fun bs0 -> + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun relevant -> + read_elf64_symbol_table endian relevant)) + | _ -> + fail "obtain_elf64_dynamic_symbol_table: an ELF file may only have one symbol table of type SHT_DYNSYM" + )) + +(** [get_elf32_file_symbol_table_by_index f1 index] returns the ELF file [f1] + * symbol table that is pointed to by the section header table entry at index + * [index]. May fail if index is out of range, or otherwise. + *) +(*val get_elf32_symbol_table_by_index : elf32_file -> natural -> error elf32_symbol_table*) +let get_elf32_symbol_table_by_index ef link1:(elf32_symbol_table)error= + (let hdr = (ef.elf32_file_header) in + let sht = (ef.elf32_file_section_header_table) in + let sects = (ef.elf32_file_interpreted_sections) in + let endian = (get_elf32_header_endianness hdr) in + (match Lem_list.list_index sects (Nat_big_num.to_int link1) with + | None -> fail "get_elf32_symbol_table_by_index: invalid index" + | Some sym -> + read_elf32_symbol_table endian sym.elf32_section_body + )) + +(** [get_elf32_file_string_table_by_index f1 index] returns the ELF file [f1] + * string table that is pointed to by the section header table entry at index + * [index]. May fail if index is out of range, or otherwise. + *) +(*val get_elf32_string_table_by_index : elf32_file -> natural -> error string_table*) +let get_elf32_string_table_by_index ef link1:(string_table)error= + (let hdr = (ef.elf32_file_header) in + let sht = (ef.elf32_file_section_header_table) in + let sects = (ef.elf32_file_interpreted_sections) in + (match Lem_list.list_index sects (Nat_big_num.to_int link1) with + | None -> fail "get_elf32_string_table_by_index: invalid index" + | Some sym -> return (mk_string_table (Byte_sequence.string_of_byte_sequence sym.elf32_section_body) Missing_pervasives.null_char) + )) + +(** [get_elf64_file_symbol_table_by_index f1 index] returns the ELF file [f1] + * symbol table that is pointed to by the section header table entry at index + * [index]. May fail if index is out of range, or otherwise. + *) +(*val get_elf64_symbol_table_by_index : elf64_file -> natural -> error elf64_symbol_table*) +let get_elf64_symbol_table_by_index ef link1:(elf64_symbol_table)error= + (let hdr = (ef.elf64_file_header) in + let sht = (ef.elf64_file_section_header_table) in + let sects = (ef.elf64_file_interpreted_sections) in + let endian = (get_elf64_header_endianness hdr) in + (match Lem_list.list_index sects (Nat_big_num.to_int link1) with + | None -> fail "get_elf64_symbol_table_by_index: invalid index" + | Some sym -> + read_elf64_symbol_table endian sym.elf64_section_body + )) + +(** [get_elf64_file_string_table_by_index f1 index] returns the ELF file [f1] + * string table that is pointed to by the section header table entry at index + * [index]. May fail if index is out of range, or otherwise. + *) +(*val get_elf64_string_table_by_index : elf64_file -> natural -> error string_table*) +let get_elf64_string_table_by_index ef link1:(string_table)error= + (let hdr = (ef.elf64_file_header) in + let sht = (ef.elf64_file_section_header_table) in + let sects = (ef.elf64_file_interpreted_sections) in + (match Lem_list.list_index sects (Nat_big_num.to_int link1) with + | None -> fail "get_elf64_string_table_by_index: invalid index" + | Some sym -> return (mk_string_table (Byte_sequence.string_of_byte_sequence sym.elf64_section_body) Missing_pervasives.null_char) + )) + +(** [segment_provenance] records whether a segment that appears in an executable + * process image has been derived directly from an ELF file, or was automatically + * created when the image calculation process noticed a segment with a memory + * size greater than its file size. + * Really a PPCMemism and not strictly needed for the ELF model itself. + *) +type segment_provenance + = FromELF (** Segment derived directly from the source ELF file. *) + | AutoGenerated (** Automatically generated during process extraction as memory size is greater than file size. *) + +(** [elf32_executable_process_image] is a process image for ELF32 files. Contains + * all that is necessary to load the executable components of an ELF32 file + * and begin execution. + * XXX: (segments, provenance), entry point, machine type + *) +type elf32_executable_process_image = + ( (elf32_interpreted_segment * segment_provenance)list * Nat_big_num.num * Nat_big_num.num) + +(** [elf64_executable_process_image] is a process image for ELF64 files. Contains + * all that is necessary to load the executable components of an ELF64 file + * and begin execution. + * XXX: (segments, provenance), entry point, machine type + *) +type elf64_executable_process_image = + ( (elf64_interpreted_segment * segment_provenance)list * Nat_big_num.num * Nat_big_num.num) + +(** [get_elf32_executable_image f1] extracts an executable process image from an + * executable ELF file. May fail if extraction is impossible. + *) +(*val get_elf32_executable_image : elf32_file -> error elf32_executable_process_image*) +let get_elf32_executable_image f3:((elf32_interpreted_segment*segment_provenance)list*Nat_big_num.num*Nat_big_num.num)error= + (if is_elf32_executable_file f3.elf32_file_header then + let entr = (f3.elf32_file_header.elf32_entry) in + let segs = (f3.elf32_file_interpreted_segments) in + let mach = (f3.elf32_file_header.elf32_machine) in + (match List.filter (fun sg -> Nat_big_num.equal sg.elf32_segment_type elf_pt_load) segs with + | [] -> fail "get_elf32_executable_image: an executable ELF file must have at least one loadable segment" + | load -> + mapM (fun sg -> + if Nat_big_num.equal sg.elf32_segment_memsz(Nat_big_num.of_int 0) then + return [] + else if Nat_big_num.equal sg.elf32_segment_memsz sg.elf32_segment_size then + return [(sg, FromELF)] + else if Nat_big_num.less sg.elf32_segment_size sg.elf32_segment_memsz then + (* Cannot be negative due to check in constructing [segs]. *) + let diff = (Nat_big_num.sub_nat sg.elf32_segment_memsz sg.elf32_segment_size) in + let zeros1 = (Byte_sequence.zeros diff) in + let addr = (Nat_big_num.add sg.elf32_segment_base sg.elf32_segment_size) in + let align = (sg.elf32_segment_align) in + let paddr = (sg.elf32_segment_paddr) in + let seg = +({ elf32_segment_body = zeros1; elf32_segment_type = (sg.elf32_segment_type); + elf32_segment_size = diff; elf32_segment_memsz = diff; + elf32_segment_base = addr; elf32_segment_flags = (sg.elf32_segment_flags); + elf32_segment_align = align; elf32_segment_paddr = paddr; + elf32_segment_offset = (sg.elf32_segment_offset) }) + in + return [(sg, FromELF); (seg, AutoGenerated)] + else + fail "get_elf32_executable_image: invariant invalidated") load >>= (fun bs_base -> + return (List.concat bs_base, Nat_big_num.of_string (Uint32.to_string entr), Nat_big_num.of_string (Uint32.to_string mach))) + ) + else + fail "get_elf32_executable_image: not an ELF executable file") + +(** [get_elf64_executable_image f1] extracts an executable process image from an + * executable ELF file. May fail if extraction is impossible. + *) +(*val get_elf64_executable_image : elf64_file -> error elf64_executable_process_image*) +let get_elf64_executable_image f3:((elf64_interpreted_segment*segment_provenance)list*Nat_big_num.num*Nat_big_num.num)error= + (if is_elf64_executable_file f3.elf64_file_header then + let entr = (f3.elf64_file_header.elf64_entry) in + let segs = (f3.elf64_file_interpreted_segments) in + let mach = (f3.elf64_file_header.elf64_machine) in + (match List.filter (fun sg -> Nat_big_num.equal sg.elf64_segment_type elf_pt_load) segs with + | [] -> fail "get_elf64_executable_image: an executable ELF file must have at least one loadable segment" + | load -> + mapM (fun sg -> + if Nat_big_num.equal sg.elf64_segment_memsz(Nat_big_num.of_int 0) then + return [] + else if Nat_big_num.equal sg.elf64_segment_memsz sg.elf64_segment_size then + return [(sg, FromELF)] + else if Nat_big_num.less sg.elf64_segment_size sg.elf64_segment_memsz then + (* Cannot be negative due to check in constructing [segs]. *) + let diff = (Nat_big_num.sub_nat sg.elf64_segment_memsz sg.elf64_segment_size) in + let zeros1 = (Byte_sequence.zeros diff) in + let addr = (Nat_big_num.add sg.elf64_segment_base sg.elf64_segment_size) in + let align = (sg.elf64_segment_align) in + let paddr = (sg.elf64_segment_paddr) in + let seg = +({ elf64_segment_body = zeros1; elf64_segment_type = (sg.elf64_segment_type); + elf64_segment_size = diff; elf64_segment_memsz = diff; + elf64_segment_base = addr; elf64_segment_flags = (sg.elf64_segment_flags); + elf64_segment_align = align; elf64_segment_paddr = paddr; + elf64_segment_offset = (sg.elf64_segment_offset) }) + in + return [(sg, FromELF); (seg, AutoGenerated)] + else + fail "get_elf64_executable_image: invariant invalidated") load >>= (fun bs_base -> + return (List.concat bs_base, Ml_bindings.nat_big_num_of_uint64 entr, Nat_big_num.of_string (Uint32.to_string mach))) + ) + else + fail "elf64_get_executable_image: not an executable ELF file") + +(** [global_symbol_init_info] records the name, type, size, address, chunk + * of initialisation data (if relevant for that symbol), and binding, of every + * global symbol in an ELF file. + * Another PPCMemism. + *) +type global_symbol_init_info + = (string * (Nat_big_num.num * Nat_big_num.num * Nat_big_num.num * byte_sequence option * Nat_big_num.num)) list + +(** [get_elf32_file_global_symbol_init f1] extracts the global symbol init info + * for ELF file [f1]. May fail. + *) +(*val get_elf32_file_global_symbol_init : elf32_file -> error global_symbol_init_info*) +let get_elf32_file_global_symbol_init f3:((string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*(byte_sequence)option*Nat_big_num.num))list)error= + (if is_elf32_executable_file f3.elf32_file_header then + let segs = (f3.elf32_file_interpreted_segments) in + bytes_of_elf32_file f3 >>= (fun bs0 -> + get_elf32_file_symbol_table f3 >>= (fun symtab -> + get_elf32_file_symbol_string_table f3 >>= (fun strtab -> + Elf_symbol_table.get_elf32_symbol_image_address symtab strtab >>= (fun strs -> + let mapped = (mapM (fun (symbol, (typ, size2, addr, bind)) -> + if Nat_big_num.equal typ Elf_symbol_table.stt_object then + get_elf32_executable_image f3 >>= (fun (img2, entry, mach) -> + let chunks1 = +(List.filter (fun (chunk, _) -> Nat_big_num.greater_equal + addr chunk.elf32_segment_base && + (if Nat_big_num.greater size2(Nat_big_num.of_int 0) + then Nat_big_num.less_equal (Nat_big_num.add addr size2) (Nat_big_num.add chunk.elf32_segment_base chunk.elf32_segment_size) + (* We don't consider a zero-size symbol one byte after a section + (i.e. addr = segment_base + segment_size) to be inside that section. *) + else Nat_big_num.less (Nat_big_num.add addr size2) (Nat_big_num.add chunk.elf32_segment_base chunk.elf32_segment_size)) + ) img2) + in + (match chunks1 with + | [] -> fail "get_elf32_global_symbol_init: global variable not present in executable image" + | [(x, _)] -> + let rebase = (Nat_big_num.sub_nat addr x.elf32_segment_base) in + Byte_sequence.offset_and_cut rebase size2 x.elf32_segment_body >>= (fun relevant -> + return (symbol, (typ, size2, addr, Some relevant, bind))) + | x::xs -> fail "get_elf32_global_symbol_init: invariant failed, global variable appears in multiple segments" + )) + else + return (symbol, (typ, size2, addr, None, bind))) strs) + in + mapped)))) + else + fail "get_elf32_file_global_symbol_init: not an executable ELF file") + +(** [get_elf64_file_global_symbol_init f1] extracts the global symbol init info + * for ELF file [f1]. May fail. + *) +(*val get_elf64_file_global_symbol_init : elf64_file -> error global_symbol_init_info*) +let get_elf64_file_global_symbol_init f3:((string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*(byte_sequence)option*Nat_big_num.num))list)error= + (if is_elf64_executable_file f3.elf64_file_header then + let segs = (f3.elf64_file_interpreted_segments) in + bytes_of_elf64_file f3 >>= (fun bs0 -> + get_elf64_file_symbol_table f3 >>= (fun symtab -> + get_elf64_file_symbol_string_table f3 >>= (fun strtab -> + Elf_symbol_table.get_elf64_symbol_image_address symtab strtab >>= (fun strs -> + let mapped = (mapM (fun (symbol, (typ, size2, addr, bind)) -> + if Nat_big_num.equal typ Elf_symbol_table.stt_object then + get_elf64_executable_image f3 >>= (fun (img2, entry, mach) -> + let chunks1 = +(List.filter (fun (chunk, _) -> Nat_big_num.greater_equal + addr chunk.elf64_segment_base && + (if Nat_big_num.greater size2(Nat_big_num.of_int 0) + then Nat_big_num.less_equal (Nat_big_num.add addr size2) (Nat_big_num.add chunk.elf64_segment_base chunk.elf64_segment_size) + (* We don't consider a zero-size symbol one byte after a section + (i.e. addr = segment_base + segment_size) to be inside that section. *) + else Nat_big_num.less (Nat_big_num.add addr size2) (Nat_big_num.add chunk.elf64_segment_base chunk.elf64_segment_size)) + ) img2) + in + (match chunks1 with + | [] -> fail "get_elf64_global_symbol_init: global variable not present in executable image" + | [(x, _)] -> + let rebase = (Nat_big_num.sub_nat addr x.elf64_segment_base) in + Byte_sequence.offset_and_cut rebase size2 x.elf64_segment_body >>= (fun relevant -> + return (symbol, (typ, size2, addr, Some relevant, bind))) + | x::xs -> fail "get_elf64_global_symbol_init: invariant failed, global variable appears in multiple segments" + )) + else + return (symbol, (typ, size2, addr, None, bind))) strs) + in + mapped)))) + else + fail "get_elf64_global_symbol_init: not an executable ELF file") + +(** [string_of_elf32_file hdr_bdl pht_bdl sht_bdl f1] produces a string-based + * representation of ELF file [f1] using ABI-specific print bundles [hdr_bdl], + * [pht_bdl] and [sht_bdl]. + *) +(*val string_of_elf32_file : hdr_print_bundle -> pht_print_bundle -> sht_print_bundle -> elf32_file -> string*) +let string_of_elf32_file hdr_bdl pht_bdl sht_bdl f3:string= + ((match get_elf32_file_section_header_string_table f3 with + | Fail err -> + unlines [ + "\nError obtaining ELF section header string table:" + ; err + ] + | Success strtab -> + unlines [ + "\n*Type elf32_file:" + ; "**Header:" + ; string_of_elf32_header hdr_bdl f3.elf32_file_header + ; "**Program header table:" + ; string_of_elf32_program_header_table pht_bdl f3.elf32_file_program_header_table + ; "**Section header table:" + ; string_of_elf32_section_header_table' sht_bdl strtab f3.elf32_file_section_header_table + ; "**Bits and bobs (unused junk space):" + ; string_of_list + (instance_Show_Show_tup2_dict instance_Show_Show_Num_natural_dict + instance_Show_Show_Byte_sequence_byte_sequence_dict) f3.elf32_file_bits_and_bobs + ] + )) + +(** [string_of_elf64_file hdr_bdl pht_bdl sht_bdl f1] produces a string-based + * representation of ELF file [f1] using ABI-specific print bundles [hdr_bdl], + * [pht_bdl] and [sht_bdl]. + *) +(*val string_of_elf64_file : hdr_print_bundle -> pht_print_bundle -> sht_print_bundle -> elf64_file -> string*) +let string_of_elf64_file hdr_bdl pht_bdl sht_bdl f3:string= + ((match get_elf64_file_section_header_string_table f3 with + | Fail err -> + unlines [ + "\nError obtaining ELF section header string table:" + ; err + ] + | Success strtab -> + unlines [ + "\n*Type elf64_file:" + ; "**Header:" + ; string_of_elf64_header hdr_bdl f3.elf64_file_header + ; "**Program header table:" + ; string_of_elf64_program_header_table pht_bdl f3.elf64_file_program_header_table + ; "**Section header table:" + ; string_of_elf64_section_header_table' sht_bdl strtab f3.elf64_file_section_header_table + ; "**Bits and bobs (unused junk space):" + ; string_of_list + (instance_Show_Show_tup2_dict instance_Show_Show_Num_natural_dict + instance_Show_Show_Byte_sequence_byte_sequence_dict) f3.elf64_file_bits_and_bobs + ] + )) + +(** [flag_is_set flag v] checks whether flag [flag] is set in [v]. + * TODO: move elsewhere. Check whether this is still being used. + *) +(*val flag_is_set : natural -> natural -> bool*) +let flag_is_set flag v:bool= +( + (* HACK: convert to elf64_xword first. Flags never live + * in objects bigger than 64 bits. *)Uint64.logand + (Uint64.of_string (Nat_big_num.to_string v)) + (Uint64.of_string (Nat_big_num.to_string flag)) + = (Uint64.of_string (Nat_big_num.to_string flag))) diff --git a/lib/ocaml_rts/linksem/elf_header.ml b/lib/ocaml_rts/linksem/elf_header.ml new file mode 100644 index 00000000..d8730e9c --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_header.ml @@ -0,0 +1,1508 @@ +(*Generated by Lem from elf_header.lem.*) +(** [elf_header] includes types, functions and other definitions for working with + * ELF headers. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_function +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +(*import Set*) + +open Lem_assert_extra + +open Default_printing +open Endianness + +open Elf_types_native_uint + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +(** Special section header table indices *) + +(** [shn_undef]: marks an undefined, missing or irrelevant section reference. + * Present here instead of in elf_section_header_table.lem because a calculation + * below requires this constant (i.e. forward reference in the ELF spec). + *) +let shn_undef : Nat_big_num.num= (Nat_big_num.of_int 0) + +(** [shn_xindex]: an escape value. It indicates the actual section header index + * is too large to fit in the containing field and is located in another + * location (specific to the structure where it appears). Present here instead + * of in elf_section_header_table.lem because a calculation below requires this + * constant (i.e. forward reference in the ELF spec). + *) +let shn_xindex : Nat_big_num.num= (Nat_big_num.of_int 65535) (* 0xffff *) + +(** ELF object file types. Enumerates the ELF object file types specified in the + * System V ABI. Values between [elf_ft_lo_os] and [elf_ft_hi_os] inclusive are + * reserved for operating system specific values typically defined in an + * addendum to the System V ABI for that operating system. Values between + * [elf_ft_lo_proc] and [elf_ft_hi_proc] inclusive are processor specific and + * are typically defined in an addendum to the System V ABI for that processor + * series. + *) + +(** No file type *) +let elf_ft_none : Nat_big_num.num= (Nat_big_num.of_int 0) +(** Relocatable file *) +let elf_ft_rel : Nat_big_num.num= (Nat_big_num.of_int 1) +(** Executable file *) +let elf_ft_exec : Nat_big_num.num= (Nat_big_num.of_int 2) +(** Shared object file *) +let elf_ft_dyn : Nat_big_num.num= (Nat_big_num.of_int 3) +(** Core file *) +let elf_ft_core : Nat_big_num.num= (Nat_big_num.of_int 4) +(** Operating-system specific *) +let elf_ft_lo_os : Nat_big_num.num= (Nat_big_num.of_int 65024) (* 0xfe00 *) +(** Operating-system specific *) +let elf_ft_hi_os : Nat_big_num.num= (Nat_big_num.of_int 65279) (* 0xfeff *) +(** Processor specific *) +let elf_ft_lo_proc : Nat_big_num.num= (Nat_big_num.of_int 65280) (* 0xff00 *) +(** Processor specific *) +let elf_ft_hi_proc : Nat_big_num.num= (Nat_big_num.of_int 65535) (* 0xffff *) + +(** [string_of_elf_file_type os proc m] produces a string representation of the + * numeric encoding [m] of the ELF file type. For values reserved for OS or + * processor specific values, the higher-order functions [os] and [proc] are + * used for printing, respectively. + *) +(*val string_of_elf_file_type : (natural -> string) -> (natural -> string) -> natural -> string*) +let string_of_elf_file_type os_specific proc_specific m:string= + (if Nat_big_num.equal m elf_ft_none then + "No file type" + else if Nat_big_num.equal m elf_ft_rel then + "REL (Relocatable file)" + else if Nat_big_num.equal m elf_ft_exec then + "EXEC (Executable file)" + else if Nat_big_num.equal m elf_ft_dyn then + "DYN (Shared object file)" + else if Nat_big_num.equal m elf_ft_core then + "CORE (Core file)" + else if Nat_big_num.greater_equal m elf_ft_lo_os && Nat_big_num.less_equal m elf_ft_hi_os then + os_specific m + else if Nat_big_num.greater_equal m elf_ft_lo_proc && Nat_big_num.less_equal m elf_ft_hi_proc then + proc_specific m + else + "Invalid file type") + +(** [is_operating_specific_file_type_value] checks whether a numeric value is + * reserved by the ABI for operating system-specific purposes. + *) +(*val is_operating_system_specific_object_file_type_value : natural -> bool*) +let is_operating_system_specific_object_file_type_value v:bool= (Nat_big_num.greater_equal + v(Nat_big_num.of_int 65024) && Nat_big_num.less_equal v(Nat_big_num.of_int 65279)) + +(** [is_processor_specific_file_type_value] checks whether a numeric value is + * reserved by the ABI for processor-specific purposes. + *) +(*val is_processor_specific_object_file_type_value : natural -> bool*) +let is_processor_specific_object_file_type_value v:bool= (Nat_big_num.greater_equal + v(Nat_big_num.of_int 65280) && Nat_big_num.less_equal v(Nat_big_num.of_int 65535)) + +(** ELF machine architectures *) + +(** RISC-V *) +let elf_ma_riscv : Nat_big_num.num= (Nat_big_num.of_int 243) +(** AMD GPU architecture *) +let elf_ma_amdgpu : Nat_big_num.num= (Nat_big_num.of_int 224) +(** Moxie processor family *) +let elf_ma_moxie : Nat_big_num.num= (Nat_big_num.of_int 223) +(** FTDI Chip FT32 high performance 32-bit RISC architecture *) +let elf_ma_ft32 : Nat_big_num.num= (Nat_big_num.of_int 222) +(** Controls and Data Services VISIUMcore processor *) +let elf_ma_visium : Nat_big_num.num= (Nat_big_num.of_int 221) +(** Zilog Z80 *) +let elf_ma_z80 : Nat_big_num.num= (Nat_big_num.of_int 220) +(** CSR Kalimba architecture family *) +let elf_ma_kalimba : Nat_big_num.num= (Nat_big_num.of_int 219) +(** Nanoradio optimised RISC *) +let elf_ma_norc : Nat_big_num.num= (Nat_big_num.of_int 218) +(** iCelero CoolEngine *) +let elf_ma_cool : Nat_big_num.num= (Nat_big_num.of_int 217) +(** Cognitive Smart Memory Processor *) +let elf_ma_coge : Nat_big_num.num= (Nat_big_num.of_int 216) +(** Paneve CDP architecture family *) +let elf_ma_cdp : Nat_big_num.num= (Nat_big_num.of_int 215) +(** KM211 KVARC processor *) +let elf_ma_kvarc : Nat_big_num.num= (Nat_big_num.of_int 214) +(** KM211 KMX8 8-bit processor *) +let elf_ma_kmx8 : Nat_big_num.num= (Nat_big_num.of_int 213) +(** KM211 KMX16 16-bit processor *) +let elf_ma_kmx16 : Nat_big_num.num= (Nat_big_num.of_int 212) +(** KM211 KMX32 32-bit processor *) +let elf_ma_kmx32 : Nat_big_num.num= (Nat_big_num.of_int 211) +(** KM211 KM32 32-bit processor *) +let elf_ma_km32 : Nat_big_num.num= (Nat_big_num.of_int 210) +(** Microchip 8-bit PIC(r) family *) +let elf_ma_mchp_pic : Nat_big_num.num= (Nat_big_num.of_int 204) +(** XMOS xCORE processor family *) +let elf_ma_xcore : Nat_big_num.num= (Nat_big_num.of_int 203) +(** Beyond BA2 CPU architecture *) +let elf_ma_ba2 : Nat_big_num.num= (Nat_big_num.of_int 202) +(** Beyond BA1 CPU architecture *) +let elf_ma_ba1 : Nat_big_num.num= (Nat_big_num.of_int 201) +(** Freescale 56800EX Digital Signal Controller (DSC) *) +let elf_ma_5600ex : Nat_big_num.num= (Nat_big_num.of_int 200) +(** 199 Renesas 78KOR family *) +let elf_ma_78kor : Nat_big_num.num= (Nat_big_num.of_int 199) +(** Broadcom VideoCore V processor *) +let elf_ma_videocore5 : Nat_big_num.num= (Nat_big_num.of_int 198) +(** Renesas RL78 family *) +let elf_ma_rl78 : Nat_big_num.num= (Nat_big_num.of_int 197) +(** Open8 8-bit RISC soft processing core *) +let elf_ma_open8 : Nat_big_num.num= (Nat_big_num.of_int 196) +(** Synopsys ARCompact V2 *) +let elf_ma_arc_compact2 : Nat_big_num.num= (Nat_big_num.of_int 195) +(** KIPO_KAIST Core-A 2nd generation processor family *) +let elf_ma_corea_2nd : Nat_big_num.num= (Nat_big_num.of_int 194) +(** KIPO_KAIST Core-A 1st generation processor family *) +let elf_ma_corea_1st : Nat_big_num.num= (Nat_big_num.of_int 193) +(** CloudShield architecture family *) +let elf_ma_cloudshield : Nat_big_num.num= (Nat_big_num.of_int 192) +(** Infineon Technologies SLE9X core *) +let elf_ma_sle9x : Nat_big_num.num= (Nat_big_num.of_int 179) +(** Intel L10M *) +let elf_ma_l10m : Nat_big_num.num= (Nat_big_num.of_int 180) +(** Intel K10M *) +let elf_ma_k10m : Nat_big_num.num= (Nat_big_num.of_int 181) +(** ARM 64-bit architecture (AARCH64) *) +let elf_ma_aarch64 : Nat_big_num.num= (Nat_big_num.of_int 183) +(** Atmel Corporation 32-bit microprocessor family *) +let elf_ma_avr32 : Nat_big_num.num= (Nat_big_num.of_int 185) +(** STMicroelectronics STM8 8-bit microcontroller *) +let elf_ma_stm8 : Nat_big_num.num= (Nat_big_num.of_int 186) +(** Tilera TILE64 multicore architecture family *) +let elf_ma_tile64 : Nat_big_num.num= (Nat_big_num.of_int 187) +(** Tilera TILEPro multicore architecture family *) +let elf_ma_tilepro : Nat_big_num.num= (Nat_big_num.of_int 188) +(** Xilinix MicroBlaze 32-bit RISC soft processor core *) +let elf_ma_microblaze : Nat_big_num.num= (Nat_big_num.of_int 189) +(** NVIDIA CUDA architecture *) +let elf_ma_cuda : Nat_big_num.num= (Nat_big_num.of_int 190) +(** Tilera TILE-Gx multicore architecture family *) +let elf_ma_tilegx : Nat_big_num.num= (Nat_big_num.of_int 191) +(** Cypress M8C microprocessor *) +let elf_ma_cypress : Nat_big_num.num= (Nat_big_num.of_int 161) +(** Renesas R32C series microprocessors *) +let elf_ma_r32c : Nat_big_num.num= (Nat_big_num.of_int 162) +(** NXP Semiconductors TriMedia architecture family *) +let elf_ma_trimedia : Nat_big_num.num= (Nat_big_num.of_int 163) +(** QUALCOMM DSP6 processor *) +let elf_ma_qdsp6 : Nat_big_num.num= (Nat_big_num.of_int 164) +(** Intel 8051 and variants *) +let elf_ma_8051 : Nat_big_num.num= (Nat_big_num.of_int 165) +(** STMicroelectronics STxP7x family of configurable and extensible RISC processors *) +let elf_ma_stxp7x : Nat_big_num.num= (Nat_big_num.of_int 166) +(** Andes Technology compact code size embedded RISC processor family *) +let elf_ma_nds32 : Nat_big_num.num= (Nat_big_num.of_int 167) +(** Cyan Technology eCOG1X family *) +let elf_ma_ecog1x : Nat_big_num.num= (Nat_big_num.of_int 168) +(** Dallas Semiconductor MAXQ30 Core Micro-controllers *) +let elf_ma_maxq30 : Nat_big_num.num= (Nat_big_num.of_int 169) +(** New Japan Radio (NJR) 16-bit DSP Processor *) +let elf_ma_ximo16 : Nat_big_num.num= (Nat_big_num.of_int 170) +(** M2000 Reconfigurable RISC Microprocessor *) +let elf_ma_manik : Nat_big_num.num= (Nat_big_num.of_int 171) +(** Cray Inc. NV2 vector architecture *) +let elf_ma_craynv2 : Nat_big_num.num= (Nat_big_num.of_int 172) +(** Renesas RX family *) +let elf_ma_rx : Nat_big_num.num= (Nat_big_num.of_int 173) +(** Imagination Technologies META processor architecture *) +let elf_ma_metag : Nat_big_num.num= (Nat_big_num.of_int 174) +(** MCST Elbrus general purpose hardware architecture *) +let elf_ma_mcst_elbrus : Nat_big_num.num= (Nat_big_num.of_int 175) +(** Cyan Technology eCOG16 family *) +let elf_ma_ecog16 : Nat_big_num.num= (Nat_big_num.of_int 176) +(** National Semiconductor CompactRISC CR16 16-bit microprocessor *) +let elf_ma_cr16 : Nat_big_num.num= (Nat_big_num.of_int 177) +(** Freescale Extended Time Processing Unit *) +let elf_ma_etpu : Nat_big_num.num= (Nat_big_num.of_int 178) +(** Altium TSK3000 core *) +let elf_ma_tsk3000 : Nat_big_num.num= (Nat_big_num.of_int 131) +(** Freescale RS08 embedded processor *) +let elf_ma_rs08 : Nat_big_num.num= (Nat_big_num.of_int 132) +(** Analog Devices SHARC family of 32-bit DSP processors *) +let elf_ma_sharc : Nat_big_num.num= (Nat_big_num.of_int 133) +(** Cyan Technology eCOG2 microprocessor *) +let elf_ma_ecog2 : Nat_big_num.num= (Nat_big_num.of_int 134) +(** Sunplus S+core7 RISC processor *) +let elf_ma_ccore7 : Nat_big_num.num= (Nat_big_num.of_int 135) +(** New Japan Radio (NJR) 24-bit DSP Processor *) +let elf_ma_dsp24 : Nat_big_num.num= (Nat_big_num.of_int 136) +(** Broadcom VideoCore III processor *) +let elf_ma_videocore3 : Nat_big_num.num= (Nat_big_num.of_int 137) +(** RISC processor for Lattice FPGA architecture *) +let elf_ma_latticemico32 : Nat_big_num.num= (Nat_big_num.of_int 138) +(** Seiko Epson C17 family *) +let elf_ma_c17 : Nat_big_num.num= (Nat_big_num.of_int 139) +(** The Texas Instruments TMS320C6000 DSP family *) +let elf_ma_c6000 : Nat_big_num.num= (Nat_big_num.of_int 140) +(** The Texas Instruments TMS320C2000 DSP family *) +let elf_ma_c2000 : Nat_big_num.num= (Nat_big_num.of_int 141) +(** The Texas Instruments TMS320C55x DSP family *) +let elf_ma_c5500 : Nat_big_num.num= (Nat_big_num.of_int 142) +(** STMicroelectronics 64bit VLIW Data Signal Processor *) +let elf_ma_mmdsp_plus : Nat_big_num.num= (Nat_big_num.of_int 160) +(** LSI Logic 16-bit DSP Processor *) +let elf_ma_zsp : Nat_big_num.num= (Nat_big_num.of_int 79) +(** Donald Knuth's educational 64-bit processor *) +let elf_ma_mmix : Nat_big_num.num= (Nat_big_num.of_int 80) +(** Harvard University machine-independent object files *) +let elf_ma_huany : Nat_big_num.num= (Nat_big_num.of_int 81) +(** SiTera Prism *) +let elf_ma_prism : Nat_big_num.num= (Nat_big_num.of_int 82) +(** Atmel AVR 8-bit microcontroller *) +let elf_ma_avr : Nat_big_num.num= (Nat_big_num.of_int 83) +(** Fujitsu FR30 *) +let elf_ma_fr30 : Nat_big_num.num= (Nat_big_num.of_int 84) +(** Mitsubishi D10V *) +let elf_ma_d10v : Nat_big_num.num= (Nat_big_num.of_int 85) +(** Mitsubishi D30V *) +let elf_ma_d30v : Nat_big_num.num= (Nat_big_num.of_int 86) +(** NEC v850 *) +let elf_ma_v850 : Nat_big_num.num= (Nat_big_num.of_int 87) +(** Mitsubishi M32R *) +let elf_ma_m32r : Nat_big_num.num= (Nat_big_num.of_int 88) +(** Matsushita MN10300 *) +let elf_ma_mn10300 : Nat_big_num.num= (Nat_big_num.of_int 89) +(** Matsushita MN10200 *) +let elf_ma_mn10200 : Nat_big_num.num= (Nat_big_num.of_int 90) +(** picoJava *) +let elf_ma_pj : Nat_big_num.num= (Nat_big_num.of_int 91) +(** OpenRISC 32-bit embedded processor *) +let elf_ma_openrisc : Nat_big_num.num= (Nat_big_num.of_int 92) +(** ARC International ARCompact processor (old spelling/synonym: ELF_MA_ARC_A5) *) +let elf_ma_arc_compact : Nat_big_num.num= (Nat_big_num.of_int 93) +(** Tensilica Xtensa Architecture *) +let elf_ma_xtensa : Nat_big_num.num= (Nat_big_num.of_int 94) +(** Alphamosaic VideoCore processor *) +let elf_ma_videocore : Nat_big_num.num= (Nat_big_num.of_int 95) +(** Thompson Multimedia General Purpose Processor *) +let elf_ma_tmm_gpp : Nat_big_num.num= (Nat_big_num.of_int 96) +(** National Semiconductor 32000 series *) +let elf_ma_ns32k : Nat_big_num.num= (Nat_big_num.of_int 97) +(** Tenor Network TPC processor *) +let elf_ma_tpc : Nat_big_num.num= (Nat_big_num.of_int 98) +(** Trebia SNP 1000 processor *) +let elf_ma_snp1k : Nat_big_num.num= (Nat_big_num.of_int 99) +(** STMicroelectronics ST200 microcontroller *) +let elf_ma_st200 : Nat_big_num.num= (Nat_big_num.of_int 100) +(** Ubicom IP2xxx microcontroller family *) +let elf_ma_ip2k : Nat_big_num.num= (Nat_big_num.of_int 101) +(** MAX Processor *) +let elf_ma_max : Nat_big_num.num= (Nat_big_num.of_int 102) +(** National Semiconductor CompactRISC microprocessor *) +let elf_ma_cr : Nat_big_num.num= (Nat_big_num.of_int 103) +(** Fujitsu F2MC16 *) +let elf_ma_f2mc16 : Nat_big_num.num= (Nat_big_num.of_int 104) +(** Texas Instruments embedded microcontroller msp430 *) +let elf_ma_msp430 : Nat_big_num.num= (Nat_big_num.of_int 105) +(** Analog Devices Blackfin (DSP) processor *) +let elf_ma_blackfin : Nat_big_num.num= (Nat_big_num.of_int 106) +(** S1C33 Family of Seiko Epson processors *) +let elf_ma_se_c33 : Nat_big_num.num= (Nat_big_num.of_int 107) +(** Sharp embedded microprocessor *) +let elf_ma_sep : Nat_big_num.num= (Nat_big_num.of_int 108) +(** Arca RISC Microprocessor *) +let elf_ma_arca : Nat_big_num.num= (Nat_big_num.of_int 109) +(** Microprocessor series from PKU-Unity Ltd. and MPRC of Peking University *) +let elf_ma_unicore : Nat_big_num.num= (Nat_big_num.of_int 110) +(** eXcess: 16/32/64-bit configurable embedded CPU *) +let elf_ma_excess : Nat_big_num.num= (Nat_big_num.of_int 111) +(** Icera Semiconductor Inc. Deep Execution Processor *) +let elf_ma_dxp : Nat_big_num.num= (Nat_big_num.of_int 112) +(** Altera Nios II soft-core processor *) +let elf_ma_altera_nios2 : Nat_big_num.num= (Nat_big_num.of_int 113) +(** National Semiconductor CompactRISC CRX microprocessor *) +let elf_ma_crx : Nat_big_num.num= (Nat_big_num.of_int 114) +(** Motorola XGATE embedded processor *) +let elf_ma_xgate : Nat_big_num.num= (Nat_big_num.of_int 115) +(** Infineon C16x/XC16x processor *) +let elf_ma_c166 : Nat_big_num.num= (Nat_big_num.of_int 116) +(** Renesas M16C series microprocessors *) +let elf_ma_m16c : Nat_big_num.num= (Nat_big_num.of_int 117) +(** Microchip Technology dsPIC30F Digital Signal Controller *) +let elf_ma_dspic30f : Nat_big_num.num= (Nat_big_num.of_int 118) +(** Freescale Communication Engine RISC core *) +let elf_ma_ce : Nat_big_num.num= (Nat_big_num.of_int 119) +(** Renesas M32C series microprocessors *) +let elf_ma_m32c : Nat_big_num.num= (Nat_big_num.of_int 120) +(** No machine *) +let elf_ma_none : Nat_big_num.num= (Nat_big_num.of_int 0) +(** AT&T WE 32100 *) +let elf_ma_m32 : Nat_big_num.num= (Nat_big_num.of_int 1) +(** SPARC *) +let elf_ma_sparc : Nat_big_num.num= (Nat_big_num.of_int 2) +(** Intel 80386 *) +let elf_ma_386 : Nat_big_num.num= (Nat_big_num.of_int 3) +(** Motorola 68000 *) +let elf_ma_68k : Nat_big_num.num= (Nat_big_num.of_int 4) +(** Motorola 88000 *) +let elf_ma_88k : Nat_big_num.num= (Nat_big_num.of_int 5) +(** Intel 80860 *) +let elf_ma_860 : Nat_big_num.num= (Nat_big_num.of_int 7) +(** MIPS I Architecture *) +let elf_ma_mips : Nat_big_num.num= (Nat_big_num.of_int 8) +(** IBM System/370 Processor *) +let elf_ma_s370 : Nat_big_num.num= (Nat_big_num.of_int 9) +(** MIPS RS3000 Little-endian *) +let elf_ma_mips_rs3_le : Nat_big_num.num= (Nat_big_num.of_int 10) +(** Hewlett-Packard PA-RISC *) +let elf_ma_parisc : Nat_big_num.num= (Nat_big_num.of_int 15) +(** Fujitsu VPP500 *) +let elf_ma_vpp500 : Nat_big_num.num= (Nat_big_num.of_int 17) +(** Enhanced instruction set SPARC *) +let elf_ma_sparc32plus : Nat_big_num.num= (Nat_big_num.of_int 18) +(** Intel 80960 *) +let elf_ma_960 : Nat_big_num.num= (Nat_big_num.of_int 19) +(** PowerPC *) +let elf_ma_ppc : Nat_big_num.num= (Nat_big_num.of_int 20) +(** 64-bit PowerPC *) +let elf_ma_ppc64 : Nat_big_num.num= (Nat_big_num.of_int 21) +(** IBM System/390 Processor *) +let elf_ma_s390 : Nat_big_num.num= (Nat_big_num.of_int 22) +(** IBM SPU/SPC *) +let elf_ma_spu : Nat_big_num.num= (Nat_big_num.of_int 23) +(** NEC V800 *) +let elf_ma_v800 : Nat_big_num.num= (Nat_big_num.of_int 36) +(** Fujitsu FR20 *) +let elf_ma_fr20 : Nat_big_num.num= (Nat_big_num.of_int 37) +(** TRW RH-32 *) +let elf_ma_rh32 : Nat_big_num.num= (Nat_big_num.of_int 38) +(** Motorola RCE *) +let elf_ma_rce : Nat_big_num.num= (Nat_big_num.of_int 39) +(** ARM 32-bit architecture (AARCH32) *) +let elf_ma_arm : Nat_big_num.num= (Nat_big_num.of_int 40) +(** Digital Alpha *) +let elf_ma_alpha : Nat_big_num.num= (Nat_big_num.of_int 41) +(** Hitachi SH *) +let elf_ma_sh : Nat_big_num.num= (Nat_big_num.of_int 42) +(** SPARC Version 9 *) +let elf_ma_sparcv9 : Nat_big_num.num= (Nat_big_num.of_int 43) +(** Siemens TriCore embedded processor *) +let elf_ma_tricore : Nat_big_num.num= (Nat_big_num.of_int 44) +(** Argonaut RISC Core, Argonaut Technologies Inc. *) +let elf_ma_arc : Nat_big_num.num= (Nat_big_num.of_int 45) +(** Hitachi H8/300 *) +let elf_ma_h8_300 : Nat_big_num.num= (Nat_big_num.of_int 46) +(** Hitachi H8/300H *) +let elf_ma_h8_300h : Nat_big_num.num= (Nat_big_num.of_int 47) +(** Hitachi H8S *) +let elf_ma_h8s : Nat_big_num.num= (Nat_big_num.of_int 48) +(** Hitachi H8/500 *) +let elf_ma_h8_500 : Nat_big_num.num= (Nat_big_num.of_int 49) +(** Intel IA-64 processor architecture *) +let elf_ma_ia_64 : Nat_big_num.num= (Nat_big_num.of_int 50) +(** Stanford MIPS-X *) +let elf_ma_mips_x : Nat_big_num.num= (Nat_big_num.of_int 51) +(** Motorola ColdFire *) +let elf_ma_coldfire : Nat_big_num.num= (Nat_big_num.of_int 52) +(** Motorola M68HC12 *) +let elf_ma_68hc12 : Nat_big_num.num= (Nat_big_num.of_int 53) +(** Fujitsu MMA Multimedia Accelerator *) +let elf_ma_mma : Nat_big_num.num= (Nat_big_num.of_int 54) +(** Siemens PCP *) +let elf_ma_pcp : Nat_big_num.num= (Nat_big_num.of_int 55) +(** Sony nCPU embedded RISC processor *) +let elf_ma_ncpu : Nat_big_num.num= (Nat_big_num.of_int 56) +(** Denso NDR1 microprocessor *) +let elf_ma_ndr1 : Nat_big_num.num= (Nat_big_num.of_int 57) +(** Motorola Star*Core processor *) +let elf_ma_starcore : Nat_big_num.num= (Nat_big_num.of_int 58) +(** Toyota ME16 processor *) +let elf_ma_me16 : Nat_big_num.num= (Nat_big_num.of_int 59) +(** STMicroelectronics ST100 processor *) +let elf_ma_st100 : Nat_big_num.num= (Nat_big_num.of_int 60) +(** Advanced Logic Corp. TinyJ embedded processor family *) +let elf_ma_tinyj : Nat_big_num.num= (Nat_big_num.of_int 61) +(** AMD x86-64 architecture *) +let elf_ma_x86_64 : Nat_big_num.num= (Nat_big_num.of_int 62) +(** Sony DSP Processor *) +let elf_ma_pdsp : Nat_big_num.num= (Nat_big_num.of_int 63) +(** Digital Equipment Corp. PDP-10 *) +let elf_ma_pdp10 : Nat_big_num.num= (Nat_big_num.of_int 64) +(** Digital Equipment Corp. PDP-11 *) +let elf_ma_pdp11 : Nat_big_num.num= (Nat_big_num.of_int 65) +(** Siemens FX66 microcontroller *) +let elf_ma_fx66 : Nat_big_num.num= (Nat_big_num.of_int 66) +(** STMicroelectronics ST9+ 8/16 bit microcontroller *) +let elf_ma_st9plus : Nat_big_num.num= (Nat_big_num.of_int 67) +(** STMicroelectronics ST7 8-bit microcontroller *) +let elf_ma_st7 : Nat_big_num.num= (Nat_big_num.of_int 68) +(** Motorola MC68HC16 Microcontroller *) +let elf_ma_68hc16 : Nat_big_num.num= (Nat_big_num.of_int 69) +(** Motorola MC68HC11 Microcontroller *) +let elf_ma_68hc11 : Nat_big_num.num= (Nat_big_num.of_int 70) +(** Motorola MC68HC08 Microcontroller *) +let elf_ma_68hc08 : Nat_big_num.num= (Nat_big_num.of_int 71) +(** Motorola MC68HC05 Microcontroller *) +let elf_ma_68hc05 : Nat_big_num.num= (Nat_big_num.of_int 72) +(** Silicon Graphics SVx *) +let elf_ma_svx : Nat_big_num.num= (Nat_big_num.of_int 73) +(** STMicroelectronics ST19 8-bit microcontroller *) +let elf_ma_st19 : Nat_big_num.num= (Nat_big_num.of_int 74) +(** Digital VAX *) +let elf_ma_vax : Nat_big_num.num= (Nat_big_num.of_int 75) +(** Axis Communications 32-bit embedded processor *) +let elf_ma_cris : Nat_big_num.num= (Nat_big_num.of_int 76) +(** Infineon Technologies 32-bit embedded processor *) +let elf_ma_javelin : Nat_big_num.num= (Nat_big_num.of_int 77) +(** Element 14 64-bit DSP Processor *) +let elf_ma_firepath : Nat_big_num.num= (Nat_big_num.of_int 78) +(** Reserved by Intel *) +let elf_ma_intel209 : Nat_big_num.num= (Nat_big_num.of_int 209) +(** Reserved by Intel *) +let elf_ma_intel208 : Nat_big_num.num= (Nat_big_num.of_int 208) +(** Reserved by Intel *) +let elf_ma_intel207 : Nat_big_num.num= (Nat_big_num.of_int 207) +(** Reserved by Intel *) +let elf_ma_intel206 : Nat_big_num.num= (Nat_big_num.of_int 206) +(** Reserved by Intel *) +let elf_ma_intel205 : Nat_big_num.num= (Nat_big_num.of_int 205) +(** Reserved by Intel *) +let elf_ma_intel182 : Nat_big_num.num= (Nat_big_num.of_int 182) +(** Reserved by ARM *) +let elf_ma_arm184 : Nat_big_num.num= (Nat_big_num.of_int 184) +(** Reserved for future use *) +let elf_ma_reserved6 : Nat_big_num.num= (Nat_big_num.of_int 6) +(** Reserved for future use *) +let elf_ma_reserved11 : Nat_big_num.num= (Nat_big_num.of_int 11) +(** Reserved for future use *) +let elf_ma_reserved12 : Nat_big_num.num= (Nat_big_num.of_int 12) +(** Reserved for future use *) +let elf_ma_reserved13 : Nat_big_num.num= (Nat_big_num.of_int 13) +(** Reserved for future use *) +let elf_ma_reserved14 : Nat_big_num.num= (Nat_big_num.of_int 14) +(** Reserved for future use *) +let elf_ma_reserved16 : Nat_big_num.num= (Nat_big_num.of_int 16) +(** Reserved for future use *) +let elf_ma_reserved24 : Nat_big_num.num= (Nat_big_num.of_int 24) +(** Reserved for future use *) +let elf_ma_reserved25 : Nat_big_num.num= (Nat_big_num.of_int 25) +(** Reserved for future use *) +let elf_ma_reserved26 : Nat_big_num.num= (Nat_big_num.of_int 26) +(** Reserved for future use *) +let elf_ma_reserved27 : Nat_big_num.num= (Nat_big_num.of_int 27) +(** Reserved for future use *) +let elf_ma_reserved28 : Nat_big_num.num= (Nat_big_num.of_int 28) +(** Reserved for future use *) +let elf_ma_reserved29 : Nat_big_num.num= (Nat_big_num.of_int 29) +(** Reserved for future use *) +let elf_ma_reserved30 : Nat_big_num.num= (Nat_big_num.of_int 30) +(** Reserved for future use *) +let elf_ma_reserved31 : Nat_big_num.num= (Nat_big_num.of_int 31) +(** Reserved for future use *) +let elf_ma_reserved32 : Nat_big_num.num= (Nat_big_num.of_int 32) +(** Reserved for future use *) +let elf_ma_reserved33 : Nat_big_num.num= (Nat_big_num.of_int 33) +(** Reserved for future use *) +let elf_ma_reserved34 : Nat_big_num.num= (Nat_big_num.of_int 34) +(** Reserved for future use *) +let elf_ma_reserved35 : Nat_big_num.num= (Nat_big_num.of_int 35) +(** Reserved for future use *) +let elf_ma_reserved121 : Nat_big_num.num= (Nat_big_num.of_int 121) +(** Reserved for future use *) +let elf_ma_reserved122 : Nat_big_num.num= (Nat_big_num.of_int 122) +(** Reserved for future use *) +let elf_ma_reserved123 : Nat_big_num.num= (Nat_big_num.of_int 123) +(** Reserved for future use *) +let elf_ma_reserved124 : Nat_big_num.num= (Nat_big_num.of_int 124) +(** Reserved for future use *) +let elf_ma_reserved125 : Nat_big_num.num= (Nat_big_num.of_int 125) +(** Reserved for future use *) +let elf_ma_reserved126 : Nat_big_num.num= (Nat_big_num.of_int 126) +(** Reserved for future use *) +let elf_ma_reserved127 : Nat_big_num.num= (Nat_big_num.of_int 127) +(** Reserved for future use *) +let elf_ma_reserved128 : Nat_big_num.num= (Nat_big_num.of_int 128) +(** Reserved for future use *) +let elf_ma_reserved129 : Nat_big_num.num= (Nat_big_num.of_int 129) +(** Reserved for future use *) +let elf_ma_reserved130 : Nat_big_num.num= (Nat_big_num.of_int 130) +(** Reserved for future use *) +let elf_ma_reserved143 : Nat_big_num.num= (Nat_big_num.of_int 143) +(** Reserved for future use *) +let elf_ma_reserved144 : Nat_big_num.num= (Nat_big_num.of_int 144) +(** Reserved for future use *) +let elf_ma_reserved145 : Nat_big_num.num= (Nat_big_num.of_int 145) +(** Reserved for future use *) +let elf_ma_reserved146 : Nat_big_num.num= (Nat_big_num.of_int 146) +(** Reserved for future use *) +let elf_ma_reserved147 : Nat_big_num.num= (Nat_big_num.of_int 147) +(** Reserved for future use *) +let elf_ma_reserved148 : Nat_big_num.num= (Nat_big_num.of_int 148) +(** Reserved for future use *) +let elf_ma_reserved149 : Nat_big_num.num= (Nat_big_num.of_int 149) +(** Reserved for future use *) +let elf_ma_reserved150 : Nat_big_num.num= (Nat_big_num.of_int 150) +(** Reserved for future use *) +let elf_ma_reserved151 : Nat_big_num.num= (Nat_big_num.of_int 151) +(** Reserved for future use *) +let elf_ma_reserved152 : Nat_big_num.num= (Nat_big_num.of_int 152) +(** Reserved for future use *) +let elf_ma_reserved153 : Nat_big_num.num= (Nat_big_num.of_int 153) +(** Reserved for future use *) +let elf_ma_reserved154 : Nat_big_num.num= (Nat_big_num.of_int 154) +(** Reserved for future use *) +let elf_ma_reserved155 : Nat_big_num.num= (Nat_big_num.of_int 155) +(** Reserved for future use *) +let elf_ma_reserved156 : Nat_big_num.num= (Nat_big_num.of_int 156) +(** Reserved for future use *) +let elf_ma_reserved157 : Nat_big_num.num= (Nat_big_num.of_int 157) +(** Reserved for future use *) +let elf_ma_reserved158 : Nat_big_num.num= (Nat_big_num.of_int 158) +(** Reserved for future use *) +let elf_ma_reserved159 : Nat_big_num.num= (Nat_big_num.of_int 159) + +(** [string_of_elf_machine_architecture m] produces a string representation of + * the numeric encoding [m] of the ELF machine architecture. + * TODO: finish this . + *) +(*val string_of_elf_machine_architecture : natural -> string*) +let string_of_elf_machine_architecture m:string= + (if Nat_big_num.equal m elf_ma_386 then + "Intel 80386" + else if Nat_big_num.equal m elf_ma_ppc then + "PowerPC" + else if Nat_big_num.equal m elf_ma_ppc64 then + "PowerPC64" + else if Nat_big_num.equal m elf_ma_arm then + "AArch" + else if Nat_big_num.equal m elf_ma_x86_64 then + "Advanced Micro Devices X86-64" + else if Nat_big_num.equal m elf_ma_aarch64 then + "AArch64" + else + "Other architecture") + +(** ELF version numbers. Denotes the ELF version number of an ELF file. Current is + * defined to have a value of 1 with the present specification. Extensions + * may create versions of ELF with higher version numbers. + *) + +(** Invalid version *) +let elf_ev_none : Nat_big_num.num= (Nat_big_num.of_int 0) +(** Current version *) +let elf_ev_current : Nat_big_num.num= (Nat_big_num.of_int 1) + +(** [string_of_elf_version_number m] produces a string representation of the + * numeric encoding [m] of the ELF version number. + *) +(*val string_of_elf_version_number : natural -> string*) +let string_of_elf_version_number m:string= + (if Nat_big_num.equal m elf_ev_none then + "Invalid ELF version" + else if Nat_big_num.equal m elf_ev_current then + "1 (current)" + else + "Extended ELF version") + +(** Check that an extended version number is correct (i.e. greater than 1). *) +let is_valid_extended_version_number (n : Nat_big_num.num):bool= (Nat_big_num.greater n(Nat_big_num.of_int 1)) + +(** Identification indices. The initial bytes of an ELF header (and an object + * file) correspond to the e_ident member. + *) + +(** File identification *) +let elf_ii_mag0 : Nat_big_num.num= (Nat_big_num.of_int 0) +(** File identification *) +let elf_ii_mag1 : Nat_big_num.num= (Nat_big_num.of_int 1) +(** File identification *) +let elf_ii_mag2 : Nat_big_num.num= (Nat_big_num.of_int 2) +(** File identification *) +let elf_ii_mag3 : Nat_big_num.num= (Nat_big_num.of_int 3) +(** File class *) +let elf_ii_class : Nat_big_num.num= (Nat_big_num.of_int 4) +(** Data encoding *) +let elf_ii_data : Nat_big_num.num= (Nat_big_num.of_int 5) +(** File version *) +let elf_ii_version : Nat_big_num.num= (Nat_big_num.of_int 6) +(** Operating system/ABI identification *) +let elf_ii_osabi : Nat_big_num.num= (Nat_big_num.of_int 7) +(** ABI version *) +let elf_ii_abiversion : Nat_big_num.num= (Nat_big_num.of_int 8) +(** Start of padding bytes *) +let elf_ii_pad : Nat_big_num.num= (Nat_big_num.of_int 9) +(** Size of e*_ident[] *) +let elf_ii_nident : Nat_big_num.num= (Nat_big_num.of_int 16) + +(** Magic number indices. A file's first 4 bytes hold a ``magic number,'' + * identifying the file as an ELF object file. + *) + +(** Position: e*_ident[elf_ii_mag0], 0x7f magic number *) +let elf_mn_mag0 : Uint32.uint32= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 127))) +(** Position: e*_ident[elf_ii_mag1], 'E' format identifier *) +let elf_mn_mag1 : Uint32.uint32= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 69))) +(** Position: e*_ident[elf_ii_mag2], 'L' format identifier *) +let elf_mn_mag2 : Uint32.uint32= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 76))) +(** Position: e*_ident[elf_ii_mag3], 'F' format identifier *) +let elf_mn_mag3 : Uint32.uint32= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 70))) + +(** ELf file classes. The file format is designed to be portable among machines + * of various sizes, without imposing the sizes of the largest machine on the + * smallest. The class of the file defines the basic types used by the data + * structures of the object file container itself. + *) + +(** Invalid class *) +let elf_class_none : Nat_big_num.num= (Nat_big_num.of_int 0) +(** 32 bit objects *) +let elf_class_32 : Nat_big_num.num= (Nat_big_num.of_int 1) +(** 64 bit objects *) +let elf_class_64 : Nat_big_num.num= (Nat_big_num.of_int 2) + +(** [string_of_elf_file_class m] produces a string representation of the numeric + * encoding [m] of the ELF file class. + *) +(*val string_of_elf_file_class : natural -> string*) +let string_of_elf_file_class m:string= + (if Nat_big_num.equal m elf_class_none then + "Invalid ELF file class" + else if Nat_big_num.equal m elf_class_32 then + "ELF32" + else if Nat_big_num.equal m elf_class_64 then + "ELF64" + else + "Invalid ELF file class") + +(** ELF data encodings. Byte e_ident[elf_ei_data] specifies the encoding of both the + * data structures used by object file container and data contained in object + * file sections. + *) + +(** Invalid data encoding *) +let elf_data_none : Nat_big_num.num= (Nat_big_num.of_int 0) +(** Two's complement values, least significant byte occupying lowest address *) +let elf_data_2lsb : Nat_big_num.num= (Nat_big_num.of_int 1) +(** Two's complement values, most significant byte occupying lowest address *) +let elf_data_2msb : Nat_big_num.num= (Nat_big_num.of_int 2) + +(** [string_of_elf_data_encoding m] produces a string representation of the + * numeric encoding [m] of the ELF data encoding. + *) +(*val string_of_elf_data_encoding : natural -> string*) +let string_of_elf_data_encoding m:string= + (if Nat_big_num.equal m elf_data_none then + "Invalid data encoding" + else if Nat_big_num.equal m elf_data_2lsb then + "2's complement, little endian" + else if Nat_big_num.equal m elf_data_2msb then + "2's complement, big endian" + else + "Invalid data encoding") + +(** OS and ABI versions. Byte e_ident[elf_ei_osabi] identifies the OS- or + * ABI-specific ELF extensions used by this file. Some fields in other ELF + * structures have flags and values that have operating system and/or ABI + * specific meanings; the interpretation of those fields is determined by the + * value of this byte. + *) + +(** No extensions or unspecified *) +let elf_osabi_none : Nat_big_num.num= (Nat_big_num.of_int 0) +(** Hewlett-Packard HP-UX *) +let elf_osabi_hpux : Nat_big_num.num= (Nat_big_num.of_int 1) +(** NetBSD *) +let elf_osabi_netbsd : Nat_big_num.num= (Nat_big_num.of_int 2) +(** GNU *) +let elf_osabi_gnu : Nat_big_num.num= (Nat_big_num.of_int 3) +(** Linux, historical alias for GNU *) +let elf_osabi_linux : Nat_big_num.num= (Nat_big_num.of_int 3) +(** Sun Solaris *) +let elf_osabi_solaris : Nat_big_num.num= (Nat_big_num.of_int 6) +(** AIX *) +let elf_osabi_aix : Nat_big_num.num= (Nat_big_num.of_int 7) +(** IRIX *) +let elf_osabi_irix : Nat_big_num.num= (Nat_big_num.of_int 8) +(** FreeBSD *) +let elf_osabi_freebsd : Nat_big_num.num= (Nat_big_num.of_int 9) +(** Compaq Tru64 Unix *) +let elf_osabi_tru64 : Nat_big_num.num= (Nat_big_num.of_int 10) +(** Novell Modesto *) +let elf_osabi_modesto : Nat_big_num.num= (Nat_big_num.of_int 11) +(** OpenBSD *) +let elf_osabi_openbsd : Nat_big_num.num= (Nat_big_num.of_int 12) +(** OpenVMS *) +let elf_osabi_openvms : Nat_big_num.num= (Nat_big_num.of_int 13) +(** Hewlett-Packard Non-stop Kernel *) +let elf_osabi_nsk : Nat_big_num.num= (Nat_big_num.of_int 14) +(** Amiga Research OS *) +let elf_osabi_aros : Nat_big_num.num= (Nat_big_num.of_int 15) +(** FenixOS highly-scalable multi-core OS *) +let elf_osabi_fenixos : Nat_big_num.num= (Nat_big_num.of_int 16) +(** Nuxi CloudABI *) +let elf_osabi_cloudabi : Nat_big_num.num= (Nat_big_num.of_int 17) +(** Stratus technologies OpenVOS *) +let elf_osabi_openvos : Nat_big_num.num= (Nat_big_num.of_int 18) + +(** Checks an architecture defined OSABI version is correct, i.e. in the range + * 64 to 255 inclusive. + *) +let is_valid_architecture_defined_osabi_version (n : Nat_big_num.num):bool= (Nat_big_num.greater_equal + n(Nat_big_num.of_int 64) && Nat_big_num.less_equal n(Nat_big_num.of_int 255)) + +(** [string_of_elf_osabi_version m] produces a string representation of the + * numeric encoding [m] of the ELF OSABI version. + *) +(*val string_of_elf_osabi_version : (natural -> string) -> natural -> string*) +let string_of_elf_osabi_version arch m:string= + (if Nat_big_num.equal m elf_osabi_none then + "UNIX - System V" + else if Nat_big_num.equal m elf_osabi_netbsd then + "Hewlett-Packard HP-UX" + else if Nat_big_num.equal m elf_osabi_netbsd then + "NetBSD" + else if Nat_big_num.equal m elf_osabi_gnu then + "UNIX - GNU" + else if Nat_big_num.equal m elf_osabi_linux then + "Linux" + else if Nat_big_num.equal m elf_osabi_solaris then + "Sun Solaris" + else if Nat_big_num.equal m elf_osabi_aix then + "AIX" + else if Nat_big_num.equal m elf_osabi_irix then + "IRIX" + else if Nat_big_num.equal m elf_osabi_freebsd then + "FreeBSD" + else if Nat_big_num.equal m elf_osabi_tru64 then + "Compaq Tru64 Unix" + else if Nat_big_num.equal m elf_osabi_modesto then + "Novell Modesto" + else if Nat_big_num.equal m elf_osabi_openbsd then + "OpenBSD" + else if Nat_big_num.equal m elf_osabi_openvms then + "OpenVMS" + else if Nat_big_num.equal m elf_osabi_nsk then + "Hewlett-Packard Non-stop Kernel" + else if Nat_big_num.equal m elf_osabi_aros then + "Amiga Research OS" + else if Nat_big_num.equal m elf_osabi_fenixos then + "FenixOS highly-scalable multi-core OS" + else if Nat_big_num.equal m elf_osabi_cloudabi then + "Nuxi CloudABI" + else if Nat_big_num.equal m elf_osabi_openvos then + "Stratus technologies OpenVOS" + else if is_valid_architecture_defined_osabi_version m then + arch m + else + "Invalid OSABI version") + +(** ELF Header type *) + +(** [ei_nident] is the fixed length of the identification field in the + * [elf32_ehdr] type. + *) +(*val ei_nident : natural*) +let ei_nident:Nat_big_num.num= (Nat_big_num.of_int 16) + +(** [elf32_header] is the type of headers for 32-bit ELF files. + *) +type elf32_header = + { elf32_ident : Uint32.uint32 list (** Identification field *) + ; elf32_type : Uint32.uint32 (** The object file type *) + ; elf32_machine : Uint32.uint32 (** Required machine architecture *) + ; elf32_version : Uint32.uint32 (** Object file version *) + ; elf32_entry : Uint32.uint32 (** Virtual address for transfer of control *) + ; elf32_phoff : Uint32.uint32 (** Program header table offset in bytes *) + ; elf32_shoff : Uint32.uint32 (** Section header table offset in bytes *) + ; elf32_flags : Uint32.uint32 (** Processor-specific flags *) + ; elf32_ehsize : Uint32.uint32 (** ELF header size in bytes *) + ; elf32_phentsize: Uint32.uint32 (** Program header table entry size in bytes *) + ; elf32_phnum : Uint32.uint32 (** Number of entries in program header table *) + ; elf32_shentsize: Uint32.uint32 (** Section header table entry size in bytes *) + ; elf32_shnum : Uint32.uint32 (** Number of entries in section header table *) + ; elf32_shstrndx : Uint32.uint32 (** Section header table entry for section name string table *) + } + +(** [elf64_header] is the type of headers for 64-bit ELF files. + *) +type elf64_header = + { elf64_ident : Uint32.uint32 list (** Identification field *) + ; elf64_type : Uint32.uint32 (** The object file type *) + ; elf64_machine : Uint32.uint32 (** Required machine architecture *) + ; elf64_version : Uint32.uint32 (** Object file version *) + ; elf64_entry : Uint64.uint64 (** Virtual address for transfer of control *) + ; elf64_phoff : Uint64.uint64 (** Program header table offset in bytes *) + ; elf64_shoff : Uint64.uint64 (** Section header table offset in bytes *) + ; elf64_flags : Uint32.uint32 (** Processor-specific flags *) + ; elf64_ehsize : Uint32.uint32 (** ELF header size in bytes *) + ; elf64_phentsize: Uint32.uint32 (** Program header table entry size in bytes *) + ; elf64_phnum : Uint32.uint32 (** Number of entries in program header table *) + ; elf64_shentsize: Uint32.uint32 (** Section header table entry size in bytes *) + ; elf64_shnum : Uint32.uint32 (** Number of entries in section header table *) + ; elf64_shstrndx : Uint32.uint32 (** Section header table entry for section name string table *) + } + +(** [is_valid_elf32_header hdr] checks whether header [hdr] is valid, i.e. has + * the correct magic numbers. + * TODO: this should be expanded, presumably, or merged with some of the other + * checks. + *) +(*val is_valid_elf32_header : elf32_header -> bool*) +let is_valid_elf32_header hdr:bool= (listEqualBy (=) +(Lem_list.take( 4) hdr.elf32_ident) [elf_mn_mag0; elf_mn_mag1; elf_mn_mag2; elf_mn_mag3]) + +(** [is_valid_elf64_header hdr] checks whether header [hdr] is valid, i.e. has + * the correct magic numbers. + * TODO: this should be expanded, presumably, or merged with some of the other + * checks. + *) +(*val is_valid_elf64_header : elf64_header -> bool*) +let is_valid_elf64_header hdr:bool= (listEqualBy (=) +(Lem_list.take( 4) hdr.elf64_ident) [elf_mn_mag0; elf_mn_mag1; elf_mn_mag2; elf_mn_mag3]) + +(** [elf32_header_compare hdr1 hdr2] is an ordering comparison function for + * ELF headers suitable for use in sets, finite maps and other ordered + * data types. + *) +(*val elf32_header_compare : elf32_header -> elf32_header -> Basic_classes.ordering*) +let elf32_header_compare h1 h2:int= + (pairCompare (lexicographic_compare Nat_big_num.compare) (lexicographic_compare Nat_big_num.compare) (Lem_list.map (fun u->Nat_big_num.of_string (Uint32.to_string u)) h1.elf32_ident, [Nat_big_num.of_string (Uint32.to_string h1.elf32_type); + Nat_big_num.of_string (Uint32.to_string h1.elf32_machine) ; Nat_big_num.of_string (Uint32.to_string h1.elf32_version) ; + Nat_big_num.of_string (Uint32.to_string h1.elf32_entry) ; Nat_big_num.of_string (Uint32.to_string h1.elf32_phoff) ; Nat_big_num.of_string (Uint32.to_string h1.elf32_shoff) ; + Nat_big_num.of_string (Uint32.to_string h1.elf32_flags) ; Nat_big_num.of_string (Uint32.to_string h1.elf32_ehsize) ; + Nat_big_num.of_string (Uint32.to_string h1.elf32_phentsize); Nat_big_num.of_string (Uint32.to_string h1.elf32_phnum) ; + Nat_big_num.of_string (Uint32.to_string h1.elf32_shentsize); Nat_big_num.of_string (Uint32.to_string h1.elf32_shnum) ; + Nat_big_num.of_string (Uint32.to_string h1.elf32_shstrndx)]) + (Lem_list.map (fun u->Nat_big_num.of_string (Uint32.to_string u)) h2.elf32_ident, [Nat_big_num.of_string (Uint32.to_string h2.elf32_type); + Nat_big_num.of_string (Uint32.to_string h2.elf32_machine) ; Nat_big_num.of_string (Uint32.to_string h2.elf32_version) ; + Nat_big_num.of_string (Uint32.to_string h2.elf32_entry) ; Nat_big_num.of_string (Uint32.to_string h2.elf32_phoff) ; Nat_big_num.of_string (Uint32.to_string h2.elf32_shoff) ; + Nat_big_num.of_string (Uint32.to_string h2.elf32_flags) ; Nat_big_num.of_string (Uint32.to_string h2.elf32_ehsize) ; + Nat_big_num.of_string (Uint32.to_string h2.elf32_phentsize); Nat_big_num.of_string (Uint32.to_string h2.elf32_phnum) ; + Nat_big_num.of_string (Uint32.to_string h2.elf32_shentsize); Nat_big_num.of_string (Uint32.to_string h2.elf32_shnum) ; + Nat_big_num.of_string (Uint32.to_string h2.elf32_shstrndx)])) + +let instance_Basic_classes_Ord_Elf_header_elf32_header_dict:(elf32_header)ord_class= ({ + + compare_method = elf32_header_compare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf32_header_compare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf32_header_compare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf32_header_compare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf32_header_compare f1 f2)(Pset.from_list compare [1; 0])))}) + +(** [elf64_header_compare hdr1 hdr2] is an ordering comparison function for + * ELF headers suitable for use in sets, finite maps and other ordered + * data types. + *) +(*val elf64_header_compare : elf64_header -> elf64_header -> Basic_classes.ordering*) +let elf64_header_compare h1 h2:int= + (pairCompare (lexicographic_compare Nat_big_num.compare) (lexicographic_compare Nat_big_num.compare) (Lem_list.map (fun u->Nat_big_num.of_string (Uint32.to_string u)) h1.elf64_ident, [Nat_big_num.of_string (Uint32.to_string h1.elf64_type); + Nat_big_num.of_string (Uint32.to_string h1.elf64_machine) ; Nat_big_num.of_string (Uint32.to_string h1.elf64_version) ; + Ml_bindings.nat_big_num_of_uint64 h1.elf64_entry ; Nat_big_num.of_string (Uint64.to_string h1.elf64_phoff) ; Nat_big_num.of_string (Uint64.to_string h1.elf64_shoff) ; + Nat_big_num.of_string (Uint32.to_string h1.elf64_flags) ; Nat_big_num.of_string (Uint32.to_string h1.elf64_ehsize) ; + Nat_big_num.of_string (Uint32.to_string h1.elf64_phentsize); Nat_big_num.of_string (Uint32.to_string h1.elf64_phnum) ; + Nat_big_num.of_string (Uint32.to_string h1.elf64_shentsize); Nat_big_num.of_string (Uint32.to_string h1.elf64_shnum) ; + Nat_big_num.of_string (Uint32.to_string h1.elf64_shstrndx)]) + (Lem_list.map (fun u->Nat_big_num.of_string (Uint32.to_string u)) h2.elf64_ident, [Nat_big_num.of_string (Uint32.to_string h2.elf64_type); + Nat_big_num.of_string (Uint32.to_string h2.elf64_machine) ; Nat_big_num.of_string (Uint32.to_string h2.elf64_version) ; + Ml_bindings.nat_big_num_of_uint64 h2.elf64_entry ; Nat_big_num.of_string (Uint64.to_string h2.elf64_phoff) ; Nat_big_num.of_string (Uint64.to_string h2.elf64_shoff) ; + Nat_big_num.of_string (Uint32.to_string h2.elf64_flags) ; Nat_big_num.of_string (Uint32.to_string h2.elf64_ehsize) ; + Nat_big_num.of_string (Uint32.to_string h2.elf64_phentsize); Nat_big_num.of_string (Uint32.to_string h2.elf64_phnum) ; + Nat_big_num.of_string (Uint32.to_string h2.elf64_shentsize); Nat_big_num.of_string (Uint32.to_string h2.elf64_shnum) ; + Nat_big_num.of_string (Uint32.to_string h2.elf64_shstrndx)])) + +let instance_Basic_classes_Ord_Elf_header_elf64_header_dict:(elf64_header)ord_class= ({ + + compare_method = elf64_header_compare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf64_header_compare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf64_header_compare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf64_header_compare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf64_header_compare f1 f2)(Pset.from_list compare [1; 0])))}) + +(** [is_elf32_executable_file hdr] checks whether the header [hdr] states if the + * ELF file is of executable type. + *) +(*val is_elf32_executable_file : elf32_header -> bool*) +let is_elf32_executable_file hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf32_type)) elf_ft_exec) + +(** [is_elf64_executable_file hdr] checks whether the header [hdr] states if the + * ELF file is of executable type. + *) +(*val is_elf64_executable_file : elf64_header -> bool*) +let is_elf64_executable_file hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf64_type)) elf_ft_exec) + +(** [is_elf32_shared_object_file hdr] checks whether the header [hdr] states if the + * ELF file is of shared object type. + *) +(*val is_elf32_shared_object_file : elf32_header -> bool*) +let is_elf32_shared_object_file hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf32_type)) elf_ft_dyn) + +(** [is_elf64_shared_object_file hdr] checks whether the header [hdr] states if the + * ELF file is of shared object type. + *) +(*val is_elf64_shared_object_file : elf64_header -> bool*) +let is_elf64_shared_object_file hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf64_type)) elf_ft_dyn) + +(** [is_elf32_relocatable_file hdr] checks whether the header [hdr] states if the + * ELF file is of relocatable type. + *) +(*val is_elf32_relocatable_file : elf32_header -> bool*) +let is_elf32_relocatable_file hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf32_type)) elf_ft_rel) + +(** [is_elf64_relocatable_file hdr] checks whether the header [hdr] states if the + * ELF file is of relocatable type. + *) +(*val is_elf64_relocatable_file : elf64_header -> bool*) +let is_elf64_relocatable_file hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf64_type)) elf_ft_rel) + +(** [is_elf32_linkable_file hdr] checks whether the header [hdr] states if the + * ELF file is of linkable (shared object or relocatable) type. + *) +(*val is_elf32_linkable_file : elf32_header -> bool*) +let is_elf32_linkable_file hdr:bool= + (is_elf32_shared_object_file hdr || is_elf32_relocatable_file hdr) + +(** [is_elf64_linkable_file hdr] checks whether the header [hdr] states if the + * ELF file is of linkable (shared object or relocatable) type. + *) +(*val is_elf64_linkable_file : elf64_header -> bool*) +let is_elf64_linkable_file hdr:bool= + (is_elf64_shared_object_file hdr || is_elf64_relocatable_file hdr) + +(** [get_elf32_machine_architecture hdr] returns the ELF file's declared machine + * architecture, extracting the information from header [hdr]. + *) +(*val get_elf32_machine_architecture : elf32_header -> natural*) +let get_elf32_machine_architecture hdr:Nat_big_num.num= + (Nat_big_num.of_string (Uint32.to_string hdr.elf32_machine)) + +(** [get_elf64_machine_architecture hdr] returns the ELF file's declared machine + * architecture, extracting the information from header [hdr]. + *) +(*val get_elf64_machine_architecture : elf64_header -> natural*) +let get_elf64_machine_architecture hdr:Nat_big_num.num= + (Nat_big_num.of_string (Uint32.to_string hdr.elf64_machine)) + +(** [get_elf32_osabi hdr] returns the ELF file's declared OS/ABI + * architecture, extracting the information from header [hdr]. + *) +(*val get_elf32_osabi : elf32_header -> natural*) +let get_elf32_osabi hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf32_ident (Nat_big_num.to_int elf_ii_osabi) with + | Some osabi -> Nat_big_num.of_string (Uint32.to_string osabi) + | None -> failwith "get_elf32_osabi: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf64_osabi hdr] returns the ELF file's declared OS/ABI + * architecture, extracting the information from header [hdr]. + *) +(*val get_elf64_osabi : elf64_header -> natural*) +let get_elf64_osabi hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf64_ident (Nat_big_num.to_int elf_ii_osabi) with + | Some osabi -> Nat_big_num.of_string (Uint32.to_string osabi) + | None -> failwith "get_elf64_osabi: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf32_data_encoding hdr] returns the ELF file's declared data + * encoding, extracting the information from header [hdr]. + *) +(*val get_elf32_data_encoding : elf32_header -> natural*) +let get_elf32_data_encoding hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf32_ident (Nat_big_num.to_int elf_ii_data) with + | Some data -> Nat_big_num.of_string (Uint32.to_string data) + | None -> failwith "get_elf32_data_encoding: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf64_data_encoding hdr] returns the ELF file's declared data + * encoding, extracting the information from header [hdr]. + *) +(*val get_elf64_data_encoding : elf64_header -> natural*) +let get_elf64_data_encoding hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf64_ident (Nat_big_num.to_int elf_ii_data) with + | Some data -> Nat_big_num.of_string (Uint32.to_string data) + | None -> failwith "get_elf64_data_encoding: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf32_file_class hdr] returns the ELF file's declared file + * class, extracting the information from header [hdr]. + *) +(*val get_elf32_file_class : elf32_header -> natural*) +let get_elf32_file_class hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf32_ident (Nat_big_num.to_int elf_ii_class) with + | Some cls -> Nat_big_num.of_string (Uint32.to_string cls) + | None -> failwith "get_elf32_file_class: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf64_file_class hdr] returns the ELF file's declared file + * class, extracting the information from header [hdr]. + *) +(*val get_elf64_file_class : elf64_header -> natural*) +let get_elf64_file_class hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf64_ident (Nat_big_num.to_int elf_ii_class) with + | Some cls -> Nat_big_num.of_string (Uint32.to_string cls) + | None -> failwith "get_elf64_file_class: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf32_version_number hdr] returns the ELF file's declared version + * number, extracting the information from header [hdr]. + *) +(*val get_elf32_version_number : elf32_header -> natural*) +let get_elf32_version_number hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf32_ident (Nat_big_num.to_int elf_ii_version) with + | Some ver -> Nat_big_num.of_string (Uint32.to_string ver) + | None -> failwith "get_elf32_version_number: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf64_version_number hdr] returns the ELF file's declared version + * number, extracting the information from header [hdr]. + *) +(*val get_elf64_version_number : elf64_header -> natural*) +let get_elf64_version_number hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf64_ident (Nat_big_num.to_int elf_ii_version) with + | Some ver -> Nat_big_num.of_string (Uint32.to_string ver) + | None -> failwith "get_elf64_version_number: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [is_valid_elf32_version_number hdr] checks whether an ELF file's declared + * version number matches the current, mandatory version number. + * TODO: this should be merged into [is_valid_elf32_header] to create a single + * correctness check. + *) +(*val is_valid_elf32_version_number : elf32_header -> bool*) +let is_valid_elf32_version_numer hdr:bool= (Nat_big_num.equal +(get_elf32_version_number hdr) elf_ev_current) + +(** [is_valid_elf64_version_number hdr] checks whether an ELF file's declared + * version number matches the current, mandatory version number. + * TODO: this should be merged into [is_valid_elf64_header] to create a single + * correctness check. + *) +(*val is_valid_elf64_version_number : elf64_header -> bool*) +let is_valid_elf64_version_numer hdr:bool= (Nat_big_num.equal +(get_elf64_version_number hdr) elf_ev_current) + +(** [get_elf32_abi_version hdr] returns the ELF file's declared ABI version + * number, extracting the information from header [hdr]. + *) +(*val get_elf32_abi_version : elf32_header -> natural*) +let get_elf32_abi_version hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf32_ident (Nat_big_num.to_int elf_ii_abiversion) with + | Some ver -> Nat_big_num.of_string (Uint32.to_string ver) + | None -> failwith "get_elf32_abi_version: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [get_elf64_abi_version hdr] returns the ELF file's declared ABI version + * number, extracting the information from header [hdr]. + *) +(*val get_elf64_abi_version : elf64_header -> natural*) +let get_elf64_abi_version hdr:Nat_big_num.num= + ((match Lem_list.list_index hdr.elf64_ident (Nat_big_num.to_int elf_ii_abiversion) with + | Some ver -> Nat_big_num.of_string (Uint32.to_string ver) + | None -> failwith "get_elf64_abi_version: lookup in ident failed" + )) (* Partial: should never return Nothing *) + +(** [deduce_endianness uc] deduces the endianness of an ELF file based on the ELF + * header's magic number [uc]. + *) +(*val deduce_endianness : list unsigned_char -> endianness*) +let deduce_endianness id2:endianness= + ((match Lem_list.list_index id2( 5) with + | None -> failwith "deduce_endianness: read of magic number has failed" + | Some v -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string v)) elf_data_2lsb then + Little + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string v)) elf_data_2msb then + Big + else + failwith "deduce_endianness: value is not valid" + )) + +(** [get_elf32_header_endianness hdr] returns the endianness of the ELF file + * as declared in its header, [hdr]. + *) +(*val get_elf32_header_endianness : elf32_header -> endianness*) +let get_elf32_header_endianness hdr:endianness= + (deduce_endianness (hdr.elf32_ident)) + +(** [get_elf64_header_endianness hdr] returns the endianness of the ELF file + * as declared in its header, [hdr]. + *) +(*val get_elf64_header_endianness : elf64_header -> endianness*) +let get_elf64_header_endianness hdr:endianness= + (deduce_endianness (hdr.elf64_ident)) + +(** [has_elf32_header_associated_entry_point hdr] checks whether the header + * [hdr] declares an entry point for the program. + *) +(*val has_elf32_header_associated_entry_point : elf32_header -> bool*) +let has_elf32_header_associated_entry_point hdr:bool= (not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string hdr.elf32_entry))(Nat_big_num.of_int 0))) + +(** [has_elf64_header_associated_entry_point hdr] checks whether the header + * [hdr] declares an entry point for the program. + *) +(*val has_elf64_header_associated_entry_point : elf64_header -> bool*) +let has_elf64_header_associated_entry_point hdr:bool= (not (Nat_big_num.equal (Ml_bindings.nat_big_num_of_uint64 hdr.elf64_entry)(Nat_big_num.of_int 0))) + +(** [has_elf32_header_string_table hdr] checks whether the header + * [hdr] declares whether the program has a string table or not. + *) +(*val has_elf32_header_string_table : elf32_header -> bool*) +let has_elf32_header_string_table hdr:bool= (not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string hdr.elf32_shstrndx)) shn_undef)) + +(** [has_elf64_header_string_table hdr] checks whether the header + * [hdr] declares whether the program has a string table or not. + *) +(*val has_elf64_header_string_table : elf64_header -> bool*) +let has_elf64_header_string_table hdr:bool= (not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string hdr.elf64_shstrndx)) shn_undef)) + +(** [is_elf32_header_section_size_in_section_header_table hdr] checks whether the header + * [hdr] declares whether the section size is too large to fit in the header + * field and is instead stored in the section header table. + *) +(*val is_elf32_header_section_size_in_section_header_table : elf32_header -> bool*) +let is_elf32_header_section_size_in_section_header_table hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf32_shnum))(Nat_big_num.of_int 0)) + +(** [is_elf64_header_section_size_in_section_header_table hdr] checks whether the header + * [hdr] declares whether the section size is too large to fit in the header + * field and is instead stored in the section header table. + *) +(*val is_elf64_header_section_size_in_section_header_table : elf64_header -> bool*) +let is_elf64_header_section_size_in_section_header_table hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf64_shnum))(Nat_big_num.of_int 0)) + +(** [is_elf32_header_string_table_index_in_link hdr] checks whether the header + * [hdr] declares whether the string table index is too large to fit in the + * header's field and is instead stored in the link field of an entry in the + * section header table. + *) +(*val is_elf32_header_string_table_index_in_link : elf32_header -> bool*) +let is_elf32_header_string_table_index_in_link hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf32_shstrndx)) shn_xindex) + +(** [is_elf64_header_string_table_index_in_link hdr] checks whether the header + * [hdr] declares whether the string table index is too large to fit in the + * header's field and is instead stored in the link field of an entry in the + * section header table. + *) +(*val is_elf64_header_string_table_index_in_link : elf64_header -> bool*) +let is_elf64_header_string_table_index_in_link hdr:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string hdr.elf64_shstrndx)) shn_xindex) + +(** The [hdr_print_bundle] type is used to tidy up other type signatures. Some of the + * top-level string_of_ functions require six or more functions passed to them, + * which quickly gets out of hand. This type is used to reduce that complexity. + * The first component of the type is an OS specific print function, the second is + * a processor specific print function. + *) +type hdr_print_bundle = (Nat_big_num.num -> string) * (Nat_big_num.num -> string) + +(** [string_of_elf32_header hdr_bdl hdr] returns a string-based representation + * of header [hdr] using the ABI-specific print bundle [hdr_bdl]. + *) +(*val string_of_elf32_header : hdr_print_bundle -> elf32_header -> string*) +let string_of_elf32_header (os, proc) hdr:string= + (unlines [ +("\t" ^ ("Magic number: " ^ string_of_list + instance_Show_Show_Elf_types_native_uint_unsigned_char_dict hdr.elf32_ident)) + ; ("\t" ^ ("Endianness: " ^ string_of_endianness (deduce_endianness hdr.elf32_ident))) + ; ("\t" ^ ("Type: " ^ string_of_elf_file_type os proc (Nat_big_num.of_string (Uint32.to_string hdr.elf32_type)))) + ; ("\t" ^ ("Version: " ^ string_of_elf_version_number (Nat_big_num.of_string (Uint32.to_string hdr.elf32_version)))) + ; ("\t" ^ ("Machine: " ^ string_of_elf_machine_architecture (Nat_big_num.of_string (Uint32.to_string hdr.elf32_machine)))) + ; ("\t" ^ ("Entry point: " ^ Uint32.to_string hdr.elf32_entry)) + ; ("\t" ^ ("Flags: " ^ Uint32.to_string hdr.elf32_flags)) + ; ("\t" ^ ("Entries in program header table: " ^ Uint32.to_string hdr.elf32_phnum)) + ; ("\t" ^ ("Entries in section header table: " ^ Uint32.to_string hdr.elf32_shnum)) + ]) + +(** [string_of_elf64_header hdr_bdl hdr] returns a string-based representation + * of header [hdr] using the ABI-specific print bundle [hdr_bdl]. + *) +(*val string_of_elf64_header : hdr_print_bundle -> elf64_header -> string*) +let string_of_elf64_header (os, proc) hdr:string= + (unlines [ +("\t" ^ ("Magic number: " ^ string_of_list + instance_Show_Show_Elf_types_native_uint_unsigned_char_dict hdr.elf64_ident)) + ; ("\t" ^ ("Endianness: " ^ string_of_endianness (deduce_endianness hdr.elf64_ident))) + ; ("\t" ^ ("Type: " ^ string_of_elf_file_type os proc (Nat_big_num.of_string (Uint32.to_string hdr.elf64_type)))) + ; ("\t" ^ ("Version: " ^ string_of_elf_version_number (Nat_big_num.of_string (Uint32.to_string hdr.elf64_version)))) + ; ("\t" ^ ("Machine: " ^ string_of_elf_machine_architecture (Nat_big_num.of_string (Uint32.to_string hdr.elf64_machine)))) + ; ("\t" ^ ("Entry point: " ^ Uint64.to_string hdr.elf64_entry)) + ; ("\t" ^ ("Flags: " ^ Uint32.to_string hdr.elf64_flags)) + ; ("\t" ^ ("Entries in program header table: " ^ Uint32.to_string hdr.elf64_phnum)) + ; ("\t" ^ ("Entries in section header table: " ^ Uint32.to_string hdr.elf64_shnum)) + ]) + +(** The following are thin wrappers around the pretty-printing functions above + * using a default print bundle for the header. + *) + +(*val string_of_elf32_header_default : elf32_header -> string*) +let string_of_elf32_header_default:elf32_header ->string= + (string_of_elf32_header + (default_os_specific_print, + default_proc_specific_print)) + +(*val string_of_elf64_header_default : elf64_header -> string*) +let string_of_elf64_header_default:elf64_header ->string= + (string_of_elf64_header + (default_os_specific_print, + default_proc_specific_print)) + +let instance_Show_Show_Elf_header_elf32_header_dict:(elf32_header)show_class= ({ + + show_method = string_of_elf32_header_default}) + +let instance_Show_Show_Elf_header_elf64_header_dict:(elf64_header)show_class= ({ + + show_method = string_of_elf64_header_default}) + +(** [read_elf_ident bs0] reads the initial bytes of an ELF file from byte sequence + * [bs0], returning the remainder of the byte sequence too. + * Fails if transcription fails. + *) +(*val read_elf_ident : byte_sequence -> error (list unsigned_char * byte_sequence)*) +let read_elf_ident bs:((Uint32.uint32)list*byte_sequence)error= +(repeatM' ei_nident bs (read_unsigned_char default_endianness)) + +(** [bytes_of_elf32_header hdr] blits an ELF header [hdr] to a byte sequence, + * ready for transcription to a binary file. + *) +(*val bytes_of_elf32_header : elf32_header -> byte_sequence*) +let bytes_of_elf32_header hdr:byte_sequence= + (let endian = (deduce_endianness hdr.elf32_ident) in + Byte_sequence.from_byte_lists [ + Lem_list.map (fun u->Char.chr (Uint32.to_int u)) hdr.elf32_ident + ; bytes_of_elf32_half endian hdr.elf32_type + ; bytes_of_elf32_half endian hdr.elf32_machine + ; bytes_of_elf32_word endian hdr.elf32_version + ; bytes_of_elf32_addr endian hdr.elf32_entry + ; bytes_of_elf32_off endian hdr.elf32_phoff + ; bytes_of_elf32_off endian hdr.elf32_shoff + ; bytes_of_elf32_word endian hdr.elf32_flags + ; bytes_of_elf32_half endian hdr.elf32_ehsize + ; bytes_of_elf32_half endian hdr.elf32_phentsize + ; bytes_of_elf32_half endian hdr.elf32_phnum + ; bytes_of_elf32_half endian hdr.elf32_shentsize + ; bytes_of_elf32_half endian hdr.elf32_shnum + ; bytes_of_elf32_half endian hdr.elf32_shstrndx + ]) + +(** [bytes_of_elf64_header hdr] blits an ELF header [hdr] to a byte sequence, + * ready for transcription to a binary file. + *) +(*val bytes_of_elf64_header : elf64_header -> byte_sequence*) +let bytes_of_elf64_header hdr:byte_sequence= + (let endian = (deduce_endianness hdr.elf64_ident) in + Byte_sequence.from_byte_lists [ + Lem_list.map (fun u->Char.chr (Uint32.to_int u)) hdr.elf64_ident + ; bytes_of_elf64_half endian hdr.elf64_type + ; bytes_of_elf64_half endian hdr.elf64_machine + ; bytes_of_elf64_word endian hdr.elf64_version + ; bytes_of_elf64_addr endian hdr.elf64_entry + ; bytes_of_elf64_off endian hdr.elf64_phoff + ; bytes_of_elf64_off endian hdr.elf64_shoff + ; bytes_of_elf64_word endian hdr.elf64_flags + ; bytes_of_elf64_half endian hdr.elf64_ehsize + ; bytes_of_elf64_half endian hdr.elf64_phentsize + ; bytes_of_elf64_half endian hdr.elf64_phnum + ; bytes_of_elf64_half endian hdr.elf64_shentsize + ; bytes_of_elf64_half endian hdr.elf64_shnum + ; bytes_of_elf64_half endian hdr.elf64_shstrndx + ]) + +(*val is_elf32_header_padding_correct : elf32_header -> bool*) +let is_elf32_header_padding_correct ehdr:bool= ((Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 9)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) && ((Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 10)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) && ((Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 11)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) && ((Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 12)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) && ((Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 13)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) && ((Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 14)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) && (Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 15)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))))))))) + +(*val is_magic_number_correct : list unsigned_char -> bool*) +let is_magic_number_correct ident:bool= ((Lem.option_equal (=) +(Lem_list.list_index ident( 0)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 127))))) && ((Lem.option_equal (=) +(Lem_list.list_index ident( 1)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 69))))) && ((Lem.option_equal (=) +(Lem_list.list_index ident( 2)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 76))))) && (Lem.option_equal (=) +(Lem_list.list_index ident( 3)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 70)))))))) + +(** [read_elf32_header bs0] reads an ELF header from the byte sequence [bs0]. + * Fails if transcription fails. + *) +(*val read_elf32_header : byte_sequence -> error (elf32_header * byte_sequence)*) +let read_elf32_header bs:(elf32_header*byte_sequence)error= + (read_elf_ident bs >>= (fun (ident, bs) -> + if not (is_magic_number_correct ident) then + fail "read_elf32_header: magic number incorrect" + else + let endian = (deduce_endianness ident) in + read_elf32_half endian bs >>= (fun (typ, bs) -> + read_elf32_half endian bs >>= (fun (machine, bs) -> + read_elf32_word endian bs >>= (fun (version, bs) -> + read_elf32_addr endian bs >>= (fun (entry, bs) -> + read_elf32_off endian bs >>= (fun (phoff, bs) -> + read_elf32_off endian bs >>= (fun (shoff, bs) -> + read_elf32_word endian bs >>= (fun (flags, bs) -> + read_elf32_half endian bs >>= (fun (ehsize, bs) -> + read_elf32_half endian bs >>= (fun (phentsize, bs) -> + read_elf32_half endian bs >>= (fun (phnum, bs) -> + read_elf32_half endian bs >>= (fun (shentsize, bs) -> + read_elf32_half endian bs >>= (fun (shnum, bs) -> + read_elf32_half endian bs >>= (fun (shstrndx, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "read_elf32_header: transcription of ELF identifier failed" + | Some c -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) elf_class_32 then + return ({ elf32_ident = ident; elf32_type = typ; + elf32_machine = machine; elf32_version = version; + elf32_entry = entry; elf32_phoff = phoff; + elf32_shoff = shoff; elf32_flags = flags; + elf32_ehsize = ehsize; elf32_phentsize = phentsize; + elf32_phnum = phnum; elf32_shentsize = shentsize; + elf32_shnum = shnum; elf32_shstrndx = shstrndx }, bs) + else + fail "read_elf32_header: not a 32-bit ELF file" + )))))))))))))))) + +(** [read_elf64_header bs0] reads an ELF header from the byte sequence [bs0]. + * Fails if transcription fails. + *) +(*val read_elf64_header : byte_sequence -> error (elf64_header * byte_sequence)*) +let read_elf64_header bs:(elf64_header*byte_sequence)error= + (read_elf_ident bs >>= (fun (ident, bs) -> + if not (is_magic_number_correct ident) then + fail "read_elf64_header: magic number incorrect" + else + let endian = (deduce_endianness ident) in + read_elf64_half endian bs >>= (fun (typ, bs) -> + read_elf64_half endian bs >>= (fun (machine, bs) -> + read_elf64_word endian bs >>= (fun (version, bs) -> + read_elf64_addr endian bs >>= (fun (entry, bs) -> + read_elf64_off endian bs >>= (fun (phoff, bs) -> + read_elf64_off endian bs >>= (fun (shoff, bs) -> + read_elf64_word endian bs >>= (fun (flags, bs) -> + read_elf64_half endian bs >>= (fun (ehsize, bs) -> + read_elf64_half endian bs >>= (fun (phentsize, bs) -> + read_elf64_half endian bs >>= (fun (phnum, bs) -> + read_elf64_half endian bs >>= (fun (shentsize, bs) -> + read_elf64_half endian bs >>= (fun (shnum, bs) -> + read_elf64_half endian bs >>= (fun (shstrndx, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> fail "read_elf64_header: transcription of ELF identifier failed" + | Some c -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) elf_class_64 then + return ({ elf64_ident = ident; elf64_type = typ; + elf64_machine = machine; elf64_version = version; + elf64_entry = entry; elf64_phoff = phoff; + elf64_shoff = shoff; elf64_flags = flags; + elf64_ehsize = ehsize; elf64_phentsize = phentsize; + elf64_phnum = phnum; elf64_shentsize = shentsize; + elf64_shnum = shnum; elf64_shstrndx = shstrndx }, bs) + else + fail "read_elf64_header: not a 64-bit ELF file" + )))))))))))))))) + +(** [is_elf32_header_class_correct hdr] checks whether the declared file class + * is correct. + *) +(*val is_elf32_header_class_correct : elf32_header -> bool*) +let is_elf32_header_class_correct ehdr:bool= (Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 4)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))))) + +(** [is_elf64_header_class_correct hdr] checks whether the declared file class + * is correct. + *) +(*val is_elf64_header_class_correct : elf64_header -> bool*) +let is_elf64_header_class_correct ehdr:bool= (Lem.option_equal (=) +(Lem_list.list_index ehdr.elf64_ident( 4)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))))) + +(** [is_elf32_header_version_correct hdr] checks whether the declared file version + * is correct. + *) +(*val is_elf32_header_version_correct : elf32_header -> bool*) +let is_elf32_header_version_correct ehdr:bool= (Lem.option_equal (=) +(Lem_list.list_index ehdr.elf32_ident( 6)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))))) + +(** [is_elf64_header_version_correct hdr] checks whether the declared file version + * is correct. + *) +(*val is_elf64_header_version_correct : elf64_header -> bool*) +let is_elf64_header_version_correct ehdr:bool= (Lem.option_equal (=) +(Lem_list.list_index ehdr.elf64_ident( 6)) (Some (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))))) + +(** [is_elf32_header_valid] checks whether an [elf32_header] value is a valid 32-bit + * ELF file header (i.e. [elf32_ident] is [ei_nident] entries long, and other + * constraints on headers). + *) +(*val is_elf32_header_valid : elf32_header -> bool*) +let is_elf32_header_valid ehdr:bool= (Nat_big_num.equal +(Nat_big_num.of_int (List.length ehdr.elf32_ident)) ei_nident && +(is_magic_number_correct ehdr.elf32_ident && +(is_elf32_header_padding_correct ehdr && +(is_elf32_header_class_correct ehdr && + is_elf32_header_version_correct ehdr)))) + +(** [get_elf32_header_program_table_size] calculates the size of the program table + * (entry size x number of entries) based on data in the ELF header. + *) +(*val get_elf32_header_program_table_size : elf32_header -> natural*) +let get_elf32_header_program_table_size ehdr:Nat_big_num.num= + (let phentsize = (Nat_big_num.of_string (Uint32.to_string ehdr.elf32_phentsize)) in + let phnum = (Nat_big_num.of_string (Uint32.to_string ehdr.elf32_phnum)) in Nat_big_num.mul + phentsize phnum) + +(** [get_elf64_header_program_table_size] calculates the size of the program table + * (entry size x number of entries) based on data in the ELF header. + *) +(*val get_elf64_header_program_table_size : elf64_header -> natural*) +let get_elf64_header_program_table_size ehdr:Nat_big_num.num= + (let phentsize = (Nat_big_num.of_string (Uint32.to_string ehdr.elf64_phentsize)) in + let phnum = (Nat_big_num.of_string (Uint32.to_string ehdr.elf64_phnum)) in Nat_big_num.mul + phentsize phnum) + +(** [is_elf32_header_section_table_present] calculates whether a section table + * is present in the ELF file or not. + *) +(*val is_elf32_header_section_table_present : elf32_header -> bool*) +let is_elf32_header_section_table_present ehdr:bool= + (not ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ehdr.elf32_shoff))(Nat_big_num.of_int 0))) + +(** [is_elf64_header_section_table_present] calculates whether a section table + * is present in the ELF file or not. + *) +(*val is_elf64_header_section_table_present : elf64_header -> bool*) +let is_elf64_header_section_table_present ehdr:bool= + (not ( Nat_big_num.equal(Nat_big_num.of_string (Uint64.to_string ehdr.elf64_shoff))(Nat_big_num.of_int 0))) + +(** [get_elf32_header_section_table_size] calculates the size of the section table + * (entry size x number of entries) based on data in the ELF header. + *) +(*val get_elf32_header_section_table_size : elf32_header -> natural*) +let get_elf32_header_section_table_size ehdr:Nat_big_num.num= + (let shentsize = (Nat_big_num.of_string (Uint32.to_string ehdr.elf32_shentsize)) in + let shnum = (Nat_big_num.of_string (Uint32.to_string ehdr.elf32_shnum)) in Nat_big_num.mul + shentsize shnum) + +(** [get_elf64_header_section_table_size] calculates the size of the section table + * (entry size x number of entries) based on data in the ELF header. + *) +(*val get_elf64_header_section_table_size : elf64_header -> natural*) +let get_elf64_header_section_table_size ehdr:Nat_big_num.num= + (let shentsize = (Nat_big_num.of_string (Uint32.to_string ehdr.elf64_shentsize)) in + let shnum = (Nat_big_num.of_string (Uint32.to_string ehdr.elf64_shnum)) in Nat_big_num.mul + shentsize shnum) diff --git a/lib/ocaml_rts/linksem/elf_interpreted_section.ml b/lib/ocaml_rts/linksem/elf_interpreted_section.ml new file mode 100644 index 00000000..7fcf59b4 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_interpreted_section.ml @@ -0,0 +1,305 @@ +(*Generated by Lem from elf_interpreted_section.lem.*) +(** Module [elf_interpreted_section] provides a record of "interpreted" sections, + * i.e. the data stored in the section header table converted to more amenable + * infinite precision types, and operation on those records. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string + +open Byte_sequence +open Error +open String_table + +open Elf_types_native_uint +open Elf_section_header_table + +open Missing_pervasives +open Show + +(** [elf32_interpreted_section] exactly mirrors the structure of a section header + * table entry, barring the conversion of all fields to more amenable types. + *) +type elf32_interpreted_section = + { elf32_section_name : Nat_big_num.num (** Name of the section *) + ; elf32_section_type : Nat_big_num.num (** Type of the section *) + ; elf32_section_flags : Nat_big_num.num (** Flags associated with the section *) + ; elf32_section_addr : Nat_big_num.num (** Base address of the section in memory *) + ; elf32_section_offset : Nat_big_num.num (** Offset from beginning of file *) + ; elf32_section_size : Nat_big_num.num (** Section size in bytes *) + ; elf32_section_link : Nat_big_num.num (** Section header table index link *) + ; elf32_section_info : Nat_big_num.num (** Extra information, depends on section type *) + ; elf32_section_align : Nat_big_num.num (** Alignment constraints for section *) + ; elf32_section_entsize : Nat_big_num.num (** Size of each entry in table, if section is one *) + ; elf32_section_body : byte_sequence (** Body of section *) + ; elf32_section_name_as_string : string (** Name of the section, as a string; "" for no name (name = 0) *) + } + +(** [elf32_interpreted_section_equal s1 s2] is an equality test on interpreted + * sections [s1] and [s2]. + *) +(*val elf32_interpreted_section_equal : elf32_interpreted_section -> elf32_interpreted_section -> bool*) +let elf32_interpreted_section_equal x y:bool= (Nat_big_num.equal + x.elf32_section_name y.elf32_section_name && (Nat_big_num.equal + x.elf32_section_type y.elf32_section_type && (Nat_big_num.equal + x.elf32_section_flags y.elf32_section_flags && (Nat_big_num.equal + x.elf32_section_addr y.elf32_section_addr && (Nat_big_num.equal + x.elf32_section_offset y.elf32_section_offset && (Nat_big_num.equal + x.elf32_section_size y.elf32_section_size && (Nat_big_num.equal + x.elf32_section_link y.elf32_section_link && (Nat_big_num.equal + x.elf32_section_info y.elf32_section_info && (Nat_big_num.equal + x.elf32_section_align y.elf32_section_align && (Nat_big_num.equal + x.elf32_section_entsize y.elf32_section_entsize && (equal + x.elf32_section_body y.elf32_section_body && +(x.elf32_section_name_as_string = y.elf32_section_name_as_string)))))))))))) + +let instance_Basic_classes_Eq_Elf_interpreted_section_elf32_interpreted_section_dict:(elf32_interpreted_section)eq_class= ({ + + isEqual_method = elf32_interpreted_section_equal; + + isInequal_method = (fun x y->not (elf32_interpreted_section_equal x y))}) + +(** [elf64_interpreted_section] exactly mirrors the structure of a section header + * table entry, barring the conversion of all fields to more amenable types. + *) +type elf64_interpreted_section = + { elf64_section_name : Nat_big_num.num (** Name of the section *) + ; elf64_section_type : Nat_big_num.num (** Type of the section *) + ; elf64_section_flags : Nat_big_num.num (** Flags associated with the section *) + ; elf64_section_addr : Nat_big_num.num (** Base address of the section in memory *) + ; elf64_section_offset : Nat_big_num.num (** Offset from beginning of file *) + ; elf64_section_size : Nat_big_num.num (** Section size in bytes *) + ; elf64_section_link : Nat_big_num.num (** Section header table index link *) + ; elf64_section_info : Nat_big_num.num (** Extra information, depends on section type *) + ; elf64_section_align : Nat_big_num.num (** Alignment constraints for section *) + ; elf64_section_entsize : Nat_big_num.num (** Size of each entry in table, if section is one *) + ; elf64_section_body : byte_sequence (** Body of section *) + ; elf64_section_name_as_string : string (** Name of the section, as a string; "" for no name (name = 0) *) + } + +(** [compare_elf64_interpreted_section s1 s2] is an ordering comparison function + * on interpreted sections suitable for use in sets, finite maps and other + * ordered structures. + *) +(*val compare_elf64_interpreted_section : elf64_interpreted_section -> elf64_interpreted_section -> + ordering*) +let compare_elf64_interpreted_section s1 s2:int= + (pairCompare (lexicographic_compare Nat_big_num.compare) compare_byte_sequence + ([s1.elf64_section_name ; + s1.elf64_section_type ; + s1.elf64_section_flags ; + s1.elf64_section_addr ; + s1.elf64_section_offset ; + s1.elf64_section_size ; + s1.elf64_section_link ; + s1.elf64_section_info ; + s1.elf64_section_align ; + s1.elf64_section_entsize], s1.elf64_section_body) + ([s2.elf64_section_name ; + s2.elf64_section_type ; + s2.elf64_section_flags ; + s2.elf64_section_addr ; + s2.elf64_section_offset ; + s2.elf64_section_size ; + s2.elf64_section_link ; + s2.elf64_section_info ; + s2.elf64_section_align ; + s2.elf64_section_entsize], s2.elf64_section_body)) + +let instance_Basic_classes_Ord_Elf_interpreted_section_elf64_interpreted_section_dict:(elf64_interpreted_section)ord_class= ({ + + compare_method = compare_elf64_interpreted_section; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_interpreted_section f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf64_interpreted_section f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_interpreted_section f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf64_interpreted_section f1 f2)(Pset.from_list compare [1; 0])))}) + +(** [elf64_interpreted_section_equal s1 s2] is an equality test on interpreted + * sections [s1] and [s2]. + *) +(*val elf64_interpreted_section_equal : elf64_interpreted_section -> elf64_interpreted_section -> bool*) +let elf64_interpreted_section_equal x y:bool= (Nat_big_num.equal + x.elf64_section_name y.elf64_section_name && (Nat_big_num.equal + x.elf64_section_type y.elf64_section_type && (Nat_big_num.equal + x.elf64_section_flags y.elf64_section_flags && (Nat_big_num.equal + x.elf64_section_addr y.elf64_section_addr && (Nat_big_num.equal + x.elf64_section_offset y.elf64_section_offset && (Nat_big_num.equal + x.elf64_section_size y.elf64_section_size && (Nat_big_num.equal + x.elf64_section_link y.elf64_section_link && (Nat_big_num.equal + x.elf64_section_info y.elf64_section_info && (Nat_big_num.equal + x.elf64_section_align y.elf64_section_align && (Nat_big_num.equal + x.elf64_section_entsize y.elf64_section_entsize && (equal + x.elf64_section_body y.elf64_section_body && +(x.elf64_section_name_as_string = y.elf64_section_name_as_string)))))))))))) + +(** [null_elf32_interpreted_section] --- the null interpreted section. + *) +(*val null_elf32_interpreted_section : elf32_interpreted_section*) +let null_elf32_interpreted_section:elf32_interpreted_section= + ({ elf32_section_name =(Nat_big_num.of_int 0) + ; elf32_section_type =(Nat_big_num.of_int 0) + ; elf32_section_flags =(Nat_big_num.of_int 0) + ; elf32_section_addr =(Nat_big_num.of_int 0) + ; elf32_section_offset =(Nat_big_num.of_int 0) + ; elf32_section_size =(Nat_big_num.of_int 0) + ; elf32_section_link =(Nat_big_num.of_int 0) + ; elf32_section_info =(Nat_big_num.of_int 0) + ; elf32_section_align =(Nat_big_num.of_int 0) + ; elf32_section_entsize =(Nat_big_num.of_int 0) + ; elf32_section_body = Byte_sequence.empty + ; elf32_section_name_as_string = "" + }) + +(** [null_elf64_interpreted_section] --- the null interpreted section. + *) +(*val null_elf64_interpreted_section : elf64_interpreted_section*) +let null_elf64_interpreted_section:elf64_interpreted_section= + ({ elf64_section_name =(Nat_big_num.of_int 0) + ; elf64_section_type =(Nat_big_num.of_int 0) + ; elf64_section_flags =(Nat_big_num.of_int 0) + ; elf64_section_addr =(Nat_big_num.of_int 0) + ; elf64_section_offset =(Nat_big_num.of_int 0) + ; elf64_section_size =(Nat_big_num.of_int 0) + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 0) + ; elf64_section_entsize =(Nat_big_num.of_int 0) + ; elf64_section_body = Byte_sequence.empty + ; elf64_section_name_as_string = "" + }) + +let instance_Basic_classes_Eq_Elf_interpreted_section_elf64_interpreted_section_dict:(elf64_interpreted_section)eq_class= ({ + + isEqual_method = elf64_interpreted_section_equal; + + isInequal_method = (fun x y->not (elf64_interpreted_section_equal x y))}) + +(** [elf64_interpreted_section_matches_section_header sect ent] checks whether + * the interpreted section and the corresponding section header table entry + * match. + *) +(*val elf64_interpreted_section_matches_section_header : + elf64_interpreted_section + -> elf64_section_header_table_entry + -> bool*) +let elf64_interpreted_section_matches_section_header i sh:bool= (Nat_big_num.equal + i.elf64_section_name (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_name)) && (Nat_big_num.equal + i.elf64_section_type (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_type)) && (Nat_big_num.equal + i.elf64_section_flags (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_flags) && (Nat_big_num.equal + i.elf64_section_addr (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_addr) && (Nat_big_num.equal + i.elf64_section_offset (Nat_big_num.of_string (Uint64.to_string sh.elf64_sh_offset)) && (Nat_big_num.equal + i.elf64_section_size (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_size) && (Nat_big_num.equal + i.elf64_section_link (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_link)) && (Nat_big_num.equal + i.elf64_section_info (Nat_big_num.of_string (Uint32.to_string sh.elf64_sh_info)) && (Nat_big_num.equal + i.elf64_section_align (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_addralign) (* WHY? *) && Nat_big_num.equal + i.elf64_section_entsize (Ml_bindings.nat_big_num_of_uint64 sh.elf64_sh_entsize)))))))))) + (* Don't compare the name as a string, because it's implied by the shshtrtab index. *) + (* NOTE that we can have multiple sections *indistinguishable* + * except by their section header table index. Imagine + * multiple zero-size bss sections at the same address with the same name. + * That's why in elf_memory_image we always label each ElfSection + * with its SHT index. + *) + +type elf32_interpreted_sections = elf32_interpreted_section list +type elf64_interpreted_sections = elf64_interpreted_section list + +(** [string_of_elf32_interpreted_section sect] returns a string-based representation + * of interpreted section, [sect]. + *) +(*val string_of_elf32_interpreted_section : elf32_interpreted_section -> string*) +let string_of_elf32_interpreted_section is:string= + (unlines [ +("Name: " ^ (is.elf32_section_name_as_string ^ ("(" ^ ((Nat_big_num.to_string is.elf32_section_name) ^ ")")))) + ; ("Type: " ^ Nat_big_num.to_string is.elf32_section_type) + ; ("Flags: " ^ Nat_big_num.to_string is.elf32_section_type) + ; ("Base address: " ^ Nat_big_num.to_string is.elf32_section_addr) + ; ("Section offset: " ^ Nat_big_num.to_string is.elf32_section_offset) + ; ("Section size: " ^ Nat_big_num.to_string is.elf32_section_size) + ; ("Link: " ^ Nat_big_num.to_string is.elf32_section_link) + ; ("Info: " ^ Nat_big_num.to_string is.elf32_section_info) + ; ("Section alignment: " ^ Nat_big_num.to_string is.elf32_section_align) + ; ("Entry size: " ^ Nat_big_num.to_string is.elf32_section_entsize) + ]) + +(** [string_of_elf64_interpreted_section sect] returns a string-based representation + * of interpreted section, [sect]. + *) +(*val string_of_elf64_interpreted_section : elf64_interpreted_section -> string*) +let string_of_elf64_interpreted_section is:string= + (unlines [ +("Name: " ^ (is.elf64_section_name_as_string ^ ("(" ^ ((Nat_big_num.to_string is.elf64_section_name) ^ ")")))) + ; ("Type: " ^ Nat_big_num.to_string is.elf64_section_type) + ; ("Flags: " ^ Nat_big_num.to_string is.elf64_section_type) + ; ("Base address: " ^ Nat_big_num.to_string is.elf64_section_addr) + ; ("Section offset: " ^ Nat_big_num.to_string is.elf64_section_offset) + ; ("Section size: " ^ Nat_big_num.to_string is.elf64_section_size) + ; ("Link: " ^ Nat_big_num.to_string is.elf64_section_link) + ; ("Info: " ^ Nat_big_num.to_string is.elf64_section_info) + ; ("Section alignment: " ^ Nat_big_num.to_string is.elf64_section_align) + ; ("Entry size: " ^ Nat_big_num.to_string is.elf64_section_entsize) + ]) + +(** [is_valid_elf32_section_header_table_entry sect stab] checks whether a + * interpreted section conforms with the prescribed flags and types declared + * in the "special sections" table of the ELF specification. + * TODO: some of these entries in the table are overridden by ABI supplements. + * Make sure it is these that are passed in rather than the default table + * declared in the spec? + *) +(*val is_valid_elf32_section_header_table_entry : elf32_interpreted_section -> + string_table -> bool*) +let is_valid_elf32_section_header_table_entry ent stbl:bool= + ((match String_table.get_string_at ent.elf32_section_name stbl with + | Fail f -> false + | Success name1 -> + (match Pmap.lookup name1 elf_special_sections with + | None -> false (* ??? *) + | Some (typ, flags) -> Nat_big_num.equal + typ ent.elf32_section_type && Nat_big_num.equal flags ent.elf32_section_flags + ) + )) + +(** [is_valid_elf64_section_header_table_entry sect stab] checks whether a + * interpreted section conforms with the prescribed flags and types declared + * in the "special sections" table of the ELF specification. + * TODO: some of these entries in the table are overridden by ABI supplements. + * Make sure it is these that are passed in rather than the default table + * declared in the spec? + *) +(*val is_valid_elf64_section_header_table_entry : elf64_interpreted_section -> + string_table -> bool*) +let is_valid_elf64_section_header_table_entry ent stbl:bool= + ((match String_table.get_string_at ent.elf64_section_name stbl with + | Fail f -> false + | Success name1 -> + (match Pmap.lookup name1 elf_special_sections with + | None -> false (* ??? *) + | Some (typ, flags) -> Nat_big_num.equal + typ ent.elf64_section_type && Nat_big_num.equal flags ent.elf64_section_flags + ) + )) + +(** [is_valid_elf32_section_header_table sects] checks whether all entries in + * [sect] are valid. + *) +(*val is_valid_elf32_section_header_table : list elf32_interpreted_section -> + string_table -> bool*) +let is_valid_elf32_section_header_table0 ents stbl:bool= + (List.for_all (fun x -> is_valid_elf32_section_header_table_entry x stbl) ents) + +(** [is_valid_elf64_section_header_table sects] checks whether all entries in + * [sect] are valid. + *) +(*val is_valid_elf64_section_header_table : list elf64_interpreted_section -> + string_table -> bool*) +let is_valid_elf64_section_header_table0 ents stbl:bool= + (List.for_all (fun x -> is_valid_elf64_section_header_table_entry x stbl) ents) diff --git a/lib/ocaml_rts/linksem/elf_interpreted_segment.ml b/lib/ocaml_rts/linksem/elf_interpreted_segment.ml new file mode 100644 index 00000000..1971f350 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_interpreted_segment.ml @@ -0,0 +1,167 @@ +(*Generated by Lem from elf_interpreted_segment.lem.*) +(** [elf_interpreted_segment] defines interpreted segments, i.e. the contents of + * a program header table entry converted to more amenable types, and operations + * built on top of them. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_num +open Lem_string + +open Elf_types_native_uint +open Elf_program_header_table + +open Byte_sequence +open Missing_pervasives +open Show + +open Hex_printing + +(** [elf32_interpreted_segment] represents an ELF32 interpreted segment, i.e. the + * contents of an ELF program header table entry converted into more amenable + * (infinite precision) types, for manipulation. + * Invariant: the nth entry of the program header table corresponds to the nth + * entry of the list of interpreted segments in an [elf32_file] record. The + * lengths of the two lists are exactly the same. + *) +type elf32_interpreted_segment = + { elf32_segment_body : byte_sequence (** Body of the segment *) + ; elf32_segment_type : Nat_big_num.num (** Type of the segment *) + ; elf32_segment_size : Nat_big_num.num (** Size of the segment in bytes *) + ; elf32_segment_memsz : Nat_big_num.num (** Size of the segment in memory in bytes *) + ; elf32_segment_base : Nat_big_num.num (** Base address of the segment *) + ; elf32_segment_paddr : Nat_big_num.num (** Physical address of segment *) + ; elf32_segment_align : Nat_big_num.num (** Alignment of the segment *) + ; elf32_segment_offset : Nat_big_num.num (** Offset of the segment *) + ; elf32_segment_flags : (bool * bool * bool) (** READ, WRITE, EXECUTE flags. *) + } + +(** [elf64_interpreted_segment] represents an ELF64 interpreted segment, i.e. the + * contents of an ELF program header table entry converted into more amenable + * (infinite precision) types, for manipulation. + * Invariant: the nth entry of the program header table corresponds to the nth + * entry of the list of interpreted segments in an [elf64_file] record. The + * lengths of the two lists are exactly the same. + *) +type elf64_interpreted_segment = + { elf64_segment_body : byte_sequence (** Body of the segment *) + ; elf64_segment_type : Nat_big_num.num (** Type of the segment *) + ; elf64_segment_size : Nat_big_num.num (** Size of the segment in bytes *) + ; elf64_segment_memsz : Nat_big_num.num (** Size of the segment in memory in bytes *) + ; elf64_segment_base : Nat_big_num.num (** Base address of the segment *) + ; elf64_segment_paddr : Nat_big_num.num (** Physical address of segment *) + ; elf64_segment_align : Nat_big_num.num (** Alignment of the segment *) + ; elf64_segment_offset : Nat_big_num.num (** Offset of the segment *) + ; elf64_segment_flags : (bool * bool * bool) (** READ, WRITE, EXECUTE flags. *) + } + +(** [compare_elf64_interpreted_segment seg1 seg2] is an ordering comparison function + * on interpreted segments suitable for constructing sets, finite maps and other + * ordered data types out of. + *) +(*val compare_elf64_interpreted_segment : elf64_interpreted_segment -> + elf64_interpreted_segment -> ordering*) +let compare_elf64_interpreted_segment s1 s2:int= + (tripleCompare compare_byte_sequence (Lem_list.lexicographic_compare Nat_big_num.compare) (Lem_list.lexicographic_compare Nat_big_num.compare) + (s1.elf64_segment_body, + [s1.elf64_segment_type ; + s1.elf64_segment_size ; + s1.elf64_segment_memsz ; + s1.elf64_segment_base ; + s1.elf64_segment_paddr ; + s1.elf64_segment_align ; + s1.elf64_segment_offset], + (let (f1, f2, f3) = (s1.elf64_segment_flags) in + Lem_list.map natural_of_bool [f1; f2; f3])) + (s2.elf64_segment_body, + [s2.elf64_segment_type ; + s2.elf64_segment_size ; + s2.elf64_segment_memsz ; + s2.elf64_segment_base ; + s2.elf64_segment_paddr ; + s2.elf64_segment_align ; + s2.elf64_segment_offset], +(let (f1, f2, f3) = (s2.elf64_segment_flags) in + Lem_list.map natural_of_bool [f1; f2; f3]))) + +let instance_Basic_classes_Ord_Elf_interpreted_segment_elf64_interpreted_segment_dict:(elf64_interpreted_segment)ord_class= ({ + + compare_method = compare_elf64_interpreted_segment; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_interpreted_segment f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> let result = (compare_elf64_interpreted_segment f1 f2) in Lem.orderingEqual result (-1) || Lem.orderingEqual result 0)); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_interpreted_segment f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> let result = (compare_elf64_interpreted_segment f1 f2) in Lem.orderingEqual result 1 || Lem.orderingEqual result 0))}) + +type elf32_interpreted_segments = elf32_interpreted_segment list +type elf64_interpreted_segments = elf64_interpreted_segment list + +(** [elf32_interpreted_program_header_flags w] extracts a boolean triple of flags + * from the flags field of an interpreted segment. + *) +(*val elf32_interpret_program_header_flags : elf32_word -> (bool * bool * bool)*) +let elf32_interpret_program_header_flags flags:bool*bool*bool= + (let zero = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) in + let one = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))) in + let two = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 2))) in + let four = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 4))) in + (not (Uint32.logand flags one = zero), + not (Uint32.logand flags two = zero), + not (Uint32.logand flags four = zero))) + +(** [elf64_interpreted_program_header_flags w] extracts a boolean triple of flags + * from the flags field of an interpreted segment. + *) +(*val elf64_interpret_program_header_flags : elf64_word -> (bool * bool * bool)*) +let elf64_interpret_program_header_flags flags:bool*bool*bool= + (let zero = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) in + let one = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1))) in + let two = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 2))) in + let four = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 4))) in + (not (Uint32.logand flags one = zero), + not (Uint32.logand flags two = zero), + not (Uint32.logand flags four = zero))) + +(** [string_of_flags bs] produces a string-based representation of an interpreted + * segments flags (represented as a boolean triple). + *) +(*val string_of_flags : (bool * bool * bool) -> string*) +let string_of_flags flags:string= + ((match flags with + | (read, write, execute) -> + bracket [string_of_bool read; string_of_bool write; string_of_bool execute] + )) + +(** [string_of_elf32_interpreted_segment seg] produces a string-based representation + * of interpreted segment [seg]. + *) +(*val string_of_elf32_interpreted_segment : elf32_interpreted_segment -> string*) +let string_of_elf32_interpreted_segment seg:string= + (unlines [ +("Body of length: " ^ unsafe_hex_string_of_natural( 16) (Byte_sequence.length0 seg.elf32_segment_body)) + ; ("Segment type: " ^ string_of_segment_type (fun _ -> "ABI specific") (fun _ -> "ABI specific") seg.elf32_segment_type) + ; ("Segment size: " ^ unsafe_hex_string_of_natural( 16) seg.elf32_segment_size) + ; ("Segment memory size: " ^ unsafe_hex_string_of_natural( 16) seg.elf32_segment_memsz) + ; ("Segment base address: " ^ unsafe_hex_string_of_natural( 16) seg.elf32_segment_base) + ; ("Segment physical address: " ^ unsafe_hex_string_of_natural( 16) seg.elf32_segment_paddr) + ; ("Segment flags: " ^ string_of_flags seg.elf32_segment_flags) + ]) + +(** [string_of_elf64_interpreted_segment seg] produces a string-based representation + * of interpreted segment [seg]. + *) +(*val string_of_elf64_interpreted_segment : elf64_interpreted_segment -> string*) +let string_of_elf64_interpreted_segment seg:string= + (unlines [ +("Body of length: " ^ unsafe_hex_string_of_natural( 16) (Byte_sequence.length0 seg.elf64_segment_body)) + ; ("Segment type: " ^ string_of_segment_type (fun _ -> "ABI specific") (fun _ -> "ABI specific") seg.elf64_segment_type) + ; ("Segment size: " ^ unsafe_hex_string_of_natural( 16) seg.elf64_segment_size) + ; ("Segment memory size: " ^ unsafe_hex_string_of_natural( 16) seg.elf64_segment_memsz) + ; ("Segment base address: " ^ unsafe_hex_string_of_natural( 16) seg.elf64_segment_base) + ; ("Segment physical address: " ^ unsafe_hex_string_of_natural( 16) seg.elf64_segment_paddr) + ; ("Segment flags: " ^ string_of_flags seg.elf64_segment_flags) + ]) diff --git a/lib/ocaml_rts/linksem/elf_memory_image.ml b/lib/ocaml_rts/linksem/elf_memory_image.ml new file mode 100644 index 00000000..d408c358 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_memory_image.ml @@ -0,0 +1,315 @@ +(*Generated by Lem from elf_memory_image.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_map +(*import Set*) +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show +open Endianness + +open Elf_header +open Elf_file +open Elf_interpreted_section +open Elf_interpreted_segment +open Elf_section_header_table +open Elf_program_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation +open String_table + +open Memory_image +open Abis + +type elf_memory_image = any_abi_feature annotated_memory_image + +let elf_section_is_special0 s f:bool= (not (Nat_big_num.equal s.elf64_section_type sht_progbits) + && not (Nat_big_num.equal s.elf64_section_type sht_nobits)) + +(*val noop_reloc : forall 'abifeature. natural -> ((maybe elf64_symbol_table_entry -> natural) * (annotated_memory_image 'abifeature -> maybe natural))*) +let noop_reloc0 r:((elf64_symbol_table_entry)option ->Nat_big_num.num)*('abifeature annotated_memory_image ->(Nat_big_num.num)option)= ((fun r_type ->Nat_big_num.of_int 8), (fun sym_val -> None)) + +let empty_elf_memory_image:(any_abi_feature)annotated_memory_image= ({ + elements = (Pmap.empty compare) + ; by_range = (Pset.empty (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare)) + ; by_tag = (Pset.empty (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))))) +}) + +(* HMM. For the elf_ident, I don't really want to express it this way. + * I want something more bidirectional: something that can tell me + * not only that a given ident is valid for a given ABI, but also, + * to *construct* an ident for a given abstract ELF file satisfying x. + * This is very much like a lens. + * + * Similarly for relocs, I might want a way to map back to an allowable + * *concrete* representation, from some *abstract* description of the + * reloc's intent (i.e. a symbol binding: "point this reference at symbol + * Foo"), given the constraints imposed by the ABI (such as "use only + * RELA, not rel". FIXME: figure out how to lensify what we're doing. *) + +type elf_range_tag = any_abi_feature range_tag + +let null_section_header_table:elf_file_feature= (ElfSectionHeaderTable([])) +let null_program_header_table:elf_file_feature= (ElfProgramHeaderTable([])) +let null_elf_header:elf64_header= ({ + elf64_ident = ([]) + ; elf64_type = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_machine = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_version = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_entry = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_phoff = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_shoff = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_flags = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_ehsize = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_phentsize= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_phnum = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_shentsize= (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_shnum = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_shstrndx = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + +(* Here we build the image of a file in file offset space. + * To transform to memory space, we + * + * - switch positions to be addresses + * - switch lengths of nobits etc. to be memory lengths + * - PROBLEM: an offset might map to >1 virtual address. + * So we have to clone it as multiple elements. + * Each gets a label identifying the "file feature" it came from + * -- i.e. sections, ELF header, SHT and PHT are all file features. + * - PROBLEM: the memory image might only contain part of an element. + * We need to reflect this truncatedness somehow in the label. + * + * Is the offset-space view really useful? + * SORT OF: want to be able to make an image out of relocatable ELF files + * that have no address assignments or phdrs yet. + * AHA. NO. This is not an offset-space view; it's a sectionwise memory view. + * All allocatable sections become elements with Nothing as their address. + * The remainder of the ELF file *should* be represented as labels. + * But, hmm, some stuff like the ELF header and SHT will likely get discarded. + * + * In short, we should work entirely with memory space. + * Then + * + * - do we want to encode the aliasing of multiple virtual addresses + * down to single "features" in offset-space, like multiple mappings + * of the ELF header, say? + *) + +(*val offset_to_vaddr_mappings : elf64_file -> natural -> list (natural * elf64_interpreted_segment)*) +let offset_to_vaddr_mappings f off:(Nat_big_num.num*elf64_interpreted_segment)list= + (Lem_list.mapMaybe (fun ph -> + if Nat_big_num.greater_equal off ph.elf64_segment_offset + && Nat_big_num.less off (Nat_big_num.add ph.elf64_segment_base ph.elf64_segment_size) + then Some ( Nat_big_num.add ph.elf64_segment_base ( Nat_big_num.sub_nat off ph.elf64_segment_offset), ph) + else None + ) f.elf64_file_interpreted_segments) + +(*val gensym : string -> string*) +let gensym hint:string= hint (* FIXME: remember duplicates *) + +(*val extract_symbol : (elf64_symbol_table * string_table * natural) -> natural -> maybe (string * elf64_symbol_table_entry)*) +let extract_symbol symtab_triple symidx:(string*elf64_symbol_table_entry)option= + (let (symtab, strtab, scnidx) = symtab_triple + in + (match Ml_bindings.list_index_big_int symidx symtab with + Some ent -> + (match (get_string_at (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_name)) strtab) with + Success str -> Some (str, ent) + | Fail _ -> Some ("", ent) (* ELF doesn't distinguish "no string" from "empty string" *) + ) + | None -> None + )) + +(*val extract_satisfying_symbols : (elf64_symbol_table * string_table * natural) -> + (elf64_symbol_table_entry -> bool) -> list (string * elf64_symbol_table_entry * natural (* scnidx *) * natural (* symidx *))*) +let extract_satisfying_symbols symtab_triple pred:(string*elf64_symbol_table_entry*Nat_big_num.num*Nat_big_num.num)list= + (let (symtab, strtab, scnidx) = symtab_triple + in + (*let _ = Missing_pervasives.errln ("extracting satisfying symbols from symtab index " ^ (show scnidx) ^ ", size " + ^ (show (length symtab)) ) + in*) + mapMaybei (fun symidx -> (fun ent -> + ((match (get_string_at (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_name)) strtab) with + Success str -> + (* exclude those that don't match *) + if (pred ent) + then Some(str, ent, scnidx, symidx) + else None + | Fail s -> (*let _ = Missing_pervasives.errln ("couldn't get string from strtab of symtab with index " ^ (show scnidx) + ^ ": " ^ s) in *) + None + )) + )) symtab) + +(*val extract_all_symbols : (elf64_symbol_table * string_table * natural) -> list (string * elf64_symbol_table_entry * natural (* scnidx *) * natural (* symidx *))*) +let extract_all_symbols symtab_triple:(string*elf64_symbol_table_entry*Nat_big_num.num*Nat_big_num.num)list= (extract_satisfying_symbols symtab_triple (fun _ -> true)) + +let definitions_pred:elf64_symbol_table_entry ->bool= (fun ent -> not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_shndx)) stn_undef)) +let references_pred:elf64_symbol_table_entry ->bool= (fun ent -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_shndx)) stn_undef && (not (is_elf64_null_entry ent))) + +(*val extract_definitions_from_symtab_of_type : natural -> elf64_file -> list symbol_definition*) +let extract_definitions_from_symtab_of_type t e:(symbol_definition)list= + ((match (find_elf64_symtab_by_type t e >>= (fun symtab -> ( + let (allsyms : (string * elf64_symbol_table_entry * Nat_big_num.num (* scnidx *) * Nat_big_num.num (* symidx *)) list) + = (extract_satisfying_symbols symtab definitions_pred) + in + let (extracted : symbol_definition list) + = (mapMaybei (fun i -> (fun (str, ent, scnidx, symidx) -> Some { + def_symname = str + ; def_syment = ent + ; def_sym_scn = scnidx + ; def_sym_idx = symidx + ; def_linkable_idx =(Nat_big_num.of_int 0) + })) allsyms) + in return extracted + ))) with Fail _ -> [] | Success x -> x )) + +(*val extract_references_from_symtab_of_type : natural -> elf64_file -> list symbol_reference*) +let extract_references_from_symtab_of_type t e:(symbol_reference)list= + ((match (find_elf64_symtab_by_type t e >>= (fun symtab -> ( + let (allsyms : (string * elf64_symbol_table_entry * Nat_big_num.num (* scnidx *) * Nat_big_num.num (* symidx *)) list) + = (extract_satisfying_symbols symtab references_pred) + in + let (extracted : symbol_reference list) = + (mapMaybei (fun symidx -> (fun (str, ent, scnidx, symidx) -> Some { + ref_symname = str + ; ref_syment = ent + ; ref_sym_scn = scnidx + ; ref_sym_idx = symidx + })) allsyms) + in + (*let _ = Missing_pervasives.errs ("Extracted " ^ (show (length allsyms)) ^ " undefined references: " + ^ (show (List.map (fun (str, _, scnidx, symidx) -> (str, scnidx, symidx)) allsyms)) ^ "\n") +(* ^ " (syminds " + ^ (show (List.map (fun extracted -> extracted.ref_sym_idx) x)) ^ ", symnames " + ^ (show (List.map (fun extracted -> extracted.ref_symname) x)) ^ ")") *) + + in*) return extracted + ))) with Fail _ -> [] | Success x -> x )) + +(*val extract_all_relocs : string -> elf64_file -> list (natural (* scn *) * natural (* rel idx *) * natural (* rel src scn *) * elf64_relocation_a)*) +let extract_all_relocs fname1 e:(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*elf64_relocation_a)list= + (let (all_rel_sections : (Nat_big_num.num * elf64_interpreted_section) list) = (mapMaybei (fun i -> (fun isec1 -> + if Nat_big_num.equal isec1.elf64_section_type sht_rel then Some (i, isec1) else None + )) e.elf64_file_interpreted_sections) + in + (*let _ = Missing_pervasives.errln ("File " ^ fname ^ " has " ^ (show (length all_rel_sections)) ^ + " rel sections (indices " ^ (show (List.map (fun (scn, _) -> scn) all_rel_sections)) ^ ")") + in*) + let (all_rela_sections : (Nat_big_num.num * elf64_interpreted_section) list) = (mapMaybei (fun i -> (fun isec1 -> + if Nat_big_num.equal isec1.elf64_section_type sht_rela then Some (i, isec1) else None + )) e.elf64_file_interpreted_sections) + in + (*let _ = Missing_pervasives.errln ("File " ^ fname ^ " has " ^ (show (length all_rela_sections)) ^ + " rela sections (indices " ^ (show (List.map (fun (scn, _) -> scn) all_rela_sections)) ^ ")") + in*) + let rel_to_rela = (fun rel -> { + elf64_ra_offset = (rel.elf64_r_offset) + ; elf64_ra_info = (rel.elf64_r_info) + ; elf64_ra_addend = (Nat_big_num.to_int64(Nat_big_num.of_int 0)) + }) + in + let endian = (get_elf64_header_endianness e.elf64_file_header) + in + (* Build per-section lists of rels paired with their originating section id. + * We also pair each element with its index *in that section*, and then flatten + * the whole lot using mapConcat. *) + let (all_rels_list : (Nat_big_num.num * Nat_big_num.num * Nat_big_num.num * elf64_relocation_a) list) = (list_reverse_concat_map (fun (scn, isec1) -> + (match read_elf64_relocation_section isec1.elf64_section_size endian isec1.elf64_section_body + with + Success (relocs, _) -> + (*let _ = Missing_pervasives.errln ("Rel section with index " ^ (show scn) ^ " has " ^ (show (length relocs)) ^ + " entries") + in*) + mapMaybei (fun idx1 -> (fun rel -> Some (scn, idx1, isec1.elf64_section_info, rel_to_rela rel))) relocs + | Fail _ -> [] + )) all_rel_sections) + in + let (all_relas_list : (Nat_big_num.num * Nat_big_num.num * Nat_big_num.num * elf64_relocation_a) list) = (list_reverse_concat_map (fun (scn, isec1) -> + (match read_elf64_relocation_a_section isec1.elf64_section_size endian isec1.elf64_section_body + with + Success (relocs, _) -> + (*let _ = Missing_pervasives.errln ("Rela section with index " ^ (show scn) ^ " has " ^ (show (length relocs)) ^ + " entries") + in*) + mapMaybei (fun idx1 -> (fun rela -> Some (scn, idx1, isec1.elf64_section_info, rela))) relocs + | Fail _ -> [] + )) all_rela_sections) + in + List.rev_append (List.rev all_rels_list) all_relas_list) + +(*val extract_all_relocs_as_symbol_references : string -> elf64_file -> list symbol_reference_and_reloc_site*) +let extract_all_relocs_as_symbol_references fname1 e:(symbol_reference_and_reloc_site)list= +(let all_relocs = (extract_all_relocs fname1 e) + in + let all_symtab_triples_by_scnidx = (mapMaybei (fun scnidx -> (fun isec1 -> + if Nat_big_num.equal isec1.elf64_section_type sht_symtab + then + let found = (find_elf64_symbols_by_symtab_idx scnidx e) + in + (match found with + Fail _ -> None + | Success triple -> Some (scnidx, triple) + ) + else None + )) e.elf64_file_interpreted_sections) + in + let (all_extracted_symtabs_by_scnidx : ( (Nat_big_num.num, ( (string * elf64_symbol_table_entry * Nat_big_num.num (* scnidx *) * Nat_big_num.num (* symidx *))list))Pmap.map)) + = (List.fold_left (fun acc -> (fun (scnidx, triple) -> Pmap.add scnidx (extract_all_symbols triple) acc)) (Pmap.empty Nat_big_num.compare) all_symtab_triples_by_scnidx) + in + (*let _ = Missing_pervasives.errln ("All extracted symtabs by scnidx: " ^ (show (Set_extra.toList (Map.toSet all_extracted_symtabs_by_scnidx)))) + in*) + let ref_for_relocation_a_in_section_index = (fun rel_scn_idx -> (fun rel_idx -> (fun rela -> + let rela_isec = ((match Ml_bindings.list_index_big_int rel_scn_idx e.elf64_file_interpreted_sections with + Some x -> x + | None -> failwith "relocation references nonexistent section" + )) + in + let symtab_idx = (rela_isec.elf64_section_link) + in + (match Pmap.lookup symtab_idx all_extracted_symtabs_by_scnidx with + None -> failwith "referenced symtab does not exist" + | Some quads -> + let sym_idx = (get_elf64_relocation_a_sym rela) + in + let maybe_quad = (Ml_bindings.list_index_big_int sym_idx quads) + in + (match maybe_quad with + Some(symname, syment, scnidx, symidx) -> { + ref_symname = symname + ; ref_syment = syment + ; ref_sym_scn = symtab_idx + ; ref_sym_idx = sym_idx + } + | None -> failwith "reloc references symbol that does not exist" (*("reloc at index " ^ (show rel_idx) ^ " references symbol (index " ^ (show sym_idx) ^ + ") that does not exist: symtab (index " ^ (show symtab_idx) ^ ") has " ^ (show (length quads)) ^ " entries")*) + ) + ) + ))) + in + (*let _ = Missing_pervasives.errs ("Extracted " ^ (show (length all_relocs)) ^ " reloc references (rel_scn, rel_idx, src_scn): " + ^ (show (List.map (fun (rel_scn, rel_idx, srcscn, rela) -> (rel_scn, rel_idx, srcscn)) all_relocs)) ^ "\n") + in*) + Lem_list.map (fun (scn, idx1, srcscn, rela) -> { + ref = ( (* NOTE that a reference is not necessarily to an undefined symbol! *)ref_for_relocation_a_in_section_index scn idx1 rela) + ; maybe_reloc = (Some + { ref_relent = rela + ; ref_rel_scn = scn + ; ref_rel_idx = idx1 + ; ref_src_scn = srcscn (* what section does the reference come from? it's the 'info' link of the rel section header *) + }) + ; maybe_def_bound_to = None + }) all_relocs) diff --git a/lib/ocaml_rts/linksem/elf_memory_image_of_elf64_file.ml b/lib/ocaml_rts/linksem/elf_memory_image_of_elf64_file.ml new file mode 100644 index 00000000..66b996df --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_memory_image_of_elf64_file.ml @@ -0,0 +1,563 @@ +(*Generated by Lem from elf_memory_image_of_elf64_file.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_map +(*import Set*) +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show +open Endianness + +open Elf_header +open Elf_file +open Elf_interpreted_section +open Elf_interpreted_segment +open Elf_section_header_table +open Elf_program_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation +open String_table + +open Memory_image +open Memory_image_orderings + +open Elf_memory_image + +(*val section_name_is_unique : string -> elf64_file -> bool*) +let section_name_is_unique name1 f:bool= + ((match mapMaybe (fun sec -> + if name1 = sec.elf64_section_name_as_string then Some sec else None + ) f.elf64_file_interpreted_sections + with + [_] -> true + | _ -> false + )) + +(*val create_unique_name_for_section_from_index : natural -> elf64_interpreted_section -> elf64_file -> string*) +let create_unique_name_for_section_from_index idx1 s f:string= + (let secname1 = (s.elf64_section_name_as_string) + in if section_name_is_unique secname1 f then secname1 else gensym secname1) + +(*val create_unique_name_for_common_symbol_from_linkable_name : string -> elf64_symbol_table_entry -> string -> elf64_file -> string*) +let create_unique_name_for_common_symbol_from_linkable_name fname1 syment symname f:string= +( + (* FIXME: uniqueness? I suppose file names are unique. How to avoid overlapping with + * section names? *)fname1 ^ ("_" ^ symname)) + +(*val get_unique_name_for_common_symbol_from_linkable_name : string -> elf64_symbol_table_entry -> string -> string*) +let get_unique_name_for_common_symbol_from_linkable_name fname1 syment symname:string= +( + (* FIXME: uniqueness? I suppose file names are unique. How to avoid overlapping with + * section names? *)fname1 ^ ("_" ^ symname)) + +(*val elf_memory_image_of_elf64_file : forall 'abifeature. abi 'abifeature -> string -> elf64_file -> elf_memory_image*) +let elf_memory_image_of_elf64_file a fname1 f:(Abis.any_abi_feature)annotated_memory_image= +( + (* Do we have program headers? This decides whether we choose a + * sectionwise or segmentwise view. *)(match f.elf64_file_program_header_table with + [] -> let extracted_symbols = (extract_definitions_from_symtab_of_type sht_symtab f) + in + let interpreted_sections_without_null = ((match f.elf64_file_interpreted_sections with + [] -> failwith "impossible: empty list of interpreted sections" + | null_entry :: more -> more + )) + in + let section_names_and_elements = (mapMaybei (fun i -> (fun isec1 -> + (* In principle, we can have unnamed sections. But + * don't add the dummy initial SHT entry. This is *not* in the + * list of interpreted sections. *) + if elf64_interpreted_section_equal isec1 null_elf64_interpreted_section then + (if Nat_big_num.equal i(Nat_big_num.of_int 0) then None else failwith "internal error: null interpreted section not at index 0") + else + if Nat_big_num.equal i(Nat_big_num.of_int 0) then failwith "internal error: non-null interpreted section at index 0" + else + let created_name = (create_unique_name_for_section_from_index i isec1 f) + in + (*let _ = errln ("In file " ^ fname ^ " created element name " ^ created_name ^ " for section idx " ^ (show i) ^ ", name " ^ + isec.elf64_section_name_as_string) + in*) + Some (created_name, { + startpos = None + ; length1 = (Some isec1.elf64_section_size) + ; contents = (byte_pattern_of_byte_sequence isec1.elf64_section_body) + }) + )) f.elf64_file_interpreted_sections) + in + let common_symbols = (List.filter (fun x -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string (x.def_syment.elf64_st_shndx))) shn_common) extracted_symbols) + in + (*let _ = Missing_pervasives.errln ("Found " ^ (show (length common_symbols)) ^ " common symbols in file " ^ fname) + in*) + let common_symbol_names_and_elements = (mapMaybei (fun i -> (fun isym -> + let symlen = (Ml_bindings.nat_big_num_of_uint64 isym.def_syment.elf64_st_size) + in + Some (get_unique_name_for_common_symbol_from_linkable_name fname1 isym.def_syment isym.def_symname, { + startpos = None + ; length1 = (Some symlen) + ; contents = (Missing_pervasives.replicate0 symlen None) + }) + )) common_symbols) + in + let all_names_and_elements = (List.rev_append (List.rev section_names_and_elements) common_symbol_names_and_elements) + in + (* -- annotations are reloc sites, symbol defs, ELF sections/segments/headers, PLT/GOT/... + * Since we stripped the null SHT entry, mapMaybei would ideally index from one. We add one. *) + let (elf_sections : ( element_range option * elf_range_tag) list) = (mapMaybei (fun secidx_minus_one -> ( + (fun (isec1, (secname1, _)) -> + let (r : element_range option) = (Some(secname1, (Nat_big_num.of_int 0, isec1.elf64_section_size))) + in + Some (r, FileFeature(ElfSection( Nat_big_num.add secidx_minus_one(Nat_big_num.of_int 1), isec1))) + ))) + (list_combine interpreted_sections_without_null section_names_and_elements)) + in + let (symbol_defs : ( element_range option * elf_range_tag) list) = (mapMaybe + (fun x -> + let section_num = (Nat_big_num.of_string (Uint32.to_string x.def_syment.elf64_st_shndx)) + in + let labelled_range = + (if Nat_big_num.equal section_num shn_abs then + (* We have an annotation that doesn't apply to any range. + * That's all right -- that's why the range is a maybe. *) + None + else if Nat_big_num.equal section_num shn_common then + (* Each common symbol becomes its own elemenet (\approx section). + * We label *that element* with a (coextensive) symbol definition. *) + let element_name = (get_unique_name_for_common_symbol_from_linkable_name + fname1 x.def_syment x.def_symname) + in + Some(element_name, (Nat_big_num.of_int 0, Ml_bindings.nat_big_num_of_uint64 x.def_syment.elf64_st_size)) + else + let (section_name, _) = ((match Ml_bindings.list_index_big_int ( Nat_big_num.sub_nat section_num(Nat_big_num.of_int 1)) section_names_and_elements with + Some x -> x + | None -> failwith ("symbol " ^ (x.def_symname ^ " references nonexistent section")) + )) + in + Some(section_name, (Ml_bindings.nat_big_num_of_uint64 x.def_syment.elf64_st_value, Ml_bindings.nat_big_num_of_uint64 x.def_syment.elf64_st_size))) + in + Some (labelled_range, SymbolDef(x)) + ) + (extract_definitions_from_symtab_of_type sht_symtab f)) + in + (* FIXME: should a common symbol be a reference too? + * I prefer to think of common symbols as mergeable sections. + * Under this interpretation, there's no need for a reference. + * BUT the GC behaviour might be different! What happens if + * a common symbol is not referenced? *) + let (symbol_refs : ( element_range option * elf_range_tag) list) = (mapMaybe + (fun (x : symbol_reference) -> + Some (None, SymbolRef({ ref = x; maybe_reloc = None; maybe_def_bound_to = None })) + ) + (extract_references_from_symtab_of_type sht_symtab f)) + in + let (all_reloc_sites : (element_range * elf_range_tag) list) = (Lem_list.map + (fun (x : symbol_reference_and_reloc_site) -> + let rel = ((match x.maybe_reloc with + Some rel -> rel + | None -> failwith "impossible: reloc site has no reloc" + )) + in + let (section_name, _) = ((match Ml_bindings.list_index_big_int ( Nat_big_num.sub_nat rel.ref_src_scn(Nat_big_num.of_int 1)) section_names_and_elements with + Some y -> y + | None -> failwith "relocs came from nonexistent section" + )) + in + let (_, applyfn) = (a.reloc (get_elf64_relocation_a_type rel.ref_relent)) + in + let (width, calcfn) = (applyfn (get_empty_memory_image ())(Nat_big_num.of_int 0) x) + (* GAH. We don't have an image. + If we pass an empty memory image, will we fail? Need to make it work *) + in + (* FIXME: for copy relocs, the size depends on the *definition*. + AHA! a copy reloc always *has* a symbol definition locally; it just gets its *value* + from the shared object's definition. + In other words, a copy reloc always references a defined symbol, and the amount + copied is the minimum of that symbol's size and the overridden (copied-from .so)'s + symbol's size. *) + let (offset : Uint64.uint64) = (rel.ref_relent.elf64_ra_offset) + in + ((section_name, (Ml_bindings.nat_big_num_of_uint64 offset, width)), SymbolRef(x)) + ) + (extract_all_relocs_as_symbol_references fname1 f)) + in + let all_reloc_pairs = (Lem_list.map (fun (el_range, r_tag) -> (Some el_range, r_tag)) all_reloc_sites) + in + let reloc_as_triple = (fun ((_ : bool Memory_image.range_tag), (x : bool Memory_image.range_tag)) -> ((match x with + SymbolRef(r) -> (match r.maybe_reloc with + Some rel -> (rel.ref_rel_scn, rel.ref_rel_idx, rel.ref_src_scn) + | None -> failwith "impossible: " + ) + | _ -> failwith "unexpected tag" + ))) + in + (*let _ = Missing_pervasives.errln ("Extracted " ^ (show (length all_reloc_sites)) ^ " reloc site tags from " + ^ "file " ^ fname ^ ": " ^ (show (List.map reloc_as_triple all_reloc_sites))) + in*) + let retrieved_reloc_sites = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict)) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict)) (Memory_image_orderings.tagEquiv + Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) + (SymbolRef(null_symbol_reference_and_reloc_site)) + (let ((fst : (string * Memory_image.range) list), (snd : ( Abis.any_abi_feature Memory_image.range_tag) list)) = (List.split all_reloc_sites) in (Pset.from_list (pairCompare compare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) (list_combine snd fst)))) + in + (*let _ = Missing_pervasives.errln ("Re-reading: retrieved " ^ (show (length retrieved_reloc_sites)) ^ " reloc site tags from " + ^ "file " ^ fname ^ ": " ^ (show (List.map reloc_as_triple (let (fst, snd) = unzip retrieved_reloc_sites in zip snd fst)))) + in*) + let elf_header = ([(Some("header", (Nat_big_num.of_int 0, Nat_big_num.of_string (Uint32.to_string f.elf64_file_header.elf64_ehsize))), FileFeature(ElfHeader(f.elf64_file_header)))]) + in + (*let _ = Missing_pervasives.errln ("ELF header contributes " ^ (show (List.length elf_header)) ^ " annotations.") + in*) + let all_annotations_list = (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev all_reloc_pairs) symbol_refs)) symbol_defs)) elf_sections)) elf_header) + in + let all_annotations_length = (List.length all_annotations_list) + in + (*let _ = Missing_pervasives.errln ("total annotations: " ^ (show all_annotations_length)) + in*) + let all_annotations = (Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) all_annotations_list) + in + let (apply_content_relocations : string -> byte_pattern -> byte_pattern) = (fun (name1 : string) -> (fun content -> + let this_element_reloc_sites = (List.filter (fun ((n, range1), _) -> name1 = n) all_reloc_sites) + in + let ((this_element_name_and_reloc_ranges : (string * (Nat_big_num.num * Nat_big_num.num)) list), _) = (List.split this_element_reloc_sites) + in + let (this_element_reloc_ranges : (Nat_big_num.num * Nat_big_num.num) list) = (snd (List.split this_element_name_and_reloc_ranges)) + in + let (all_ranges_expanded : bool list) = (expand_unsorted_ranges this_element_reloc_ranges (Missing_pervasives.length content) []) + in + relax_byte_pattern content all_ranges_expanded + )) + in + let new_elements_list = (Lem_list.map (fun (name1, element1) -> + (* We can now mark the relocation sites in the section contents as "subject to change". *) + ( + name1, + { + startpos = (element1.startpos) + ; length1 = (element1.length1) + ; contents = +( + (*let _ = errln ("Reloc-relaxing section " ^ name ^ " in file " ^ fname ^ ": before, first 20 bytes: " ^ + (show (take 20 element.contents))) + in*)let relaxed = (apply_content_relocations name1 element1.contents) + in + (*let _ = errln ("After, first 20 bytes: " ^ (show (take 20 relaxed))) + in*) + relaxed) + + } + ) + ) all_names_and_elements) + in + (* + List.foldr (fun acc -> (fun element.contents this_element_reloc_ranges + let (expand_and_relax : list (maybe byte) -> (natural * natural) -> list (maybe byte)) = fun pat -> (fun r -> ( + relax_byte_pattern pat (expand_ranges r) + )) + in*) + { + elements = (Lem_map.fromList + (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) new_elements_list) + (* : memory_image -- the image elements, without annotation, i.e. + a map from string to (startpos, length, contents) + -- an element is the ELF header, PHT, SHT, section or segment + -- exploit the fact that section names beginning `.' are reserved, and + the reserved ones don't use caps: ".PHT", ".SHT", ".HDR" + -- what about ambiguous section names? use ".GENSYM_<...>" perhaps + *) + ; by_range = all_annotations + ; by_tag = (let (fst, snd) = (List.split all_annotations_list) in (Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) (list_combine snd fst))) + (* : multimap (elf_range_tag 'symdef 'reloc 'filefeature 'abifeature) (string * range) + -- annotations by *) + } + | pht -> let segment_names_and_images = (mapMaybei (fun i -> (fun seg -> + Some((gensym (hex_string_of_natural seg.elf64_segment_base) ^ ("_" ^ (hex_string_of_natural seg.elf64_segment_type))), + { + startpos = (Some seg.elf64_segment_base) + ; length1 = (Some seg.elf64_segment_memsz) + ; contents = ([]) (* FIXME *) + }) + )) f.elf64_file_interpreted_segments) + in + (* let annotations = *) + { + elements = (Lem_map.fromList + (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) segment_names_and_images) (* : memory_image -- the image elements, without annotation, i.e. + a map from string to (startpos, length, contents) + -- an element is the ELF header, PHT, SHT, section or segment + -- exploit the fact that section names beginning `.' are reserved, and + the reserved ones don't use caps: ".PHT", ".SHT", ".HDR" + -- what about ambiguous section names? use ".GENSYM_<...>" perhaps + *) + ; by_range = (Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) []) + (* : map element_range (list (elf_range_tag 'symdef 'reloc 'filefeature 'abifeature)) + -- annotations are reloc sites, symbol defs, ELF sections/segments/headers, PLT/GOT/... *) + ; by_tag = (Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) []) + (* : multimap (elf_range_tag 'symdef 'reloc 'filefeature 'abifeature) (string * range) + -- annotations by *) + } + + )) + +(*val elf_memory_image_header : elf_memory_image -> elf64_header*) +let elf_memory_image_header img2:elf64_header= + ((match unique_tag_matching + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict (FileFeature(ElfHeader(null_elf_header))) img2 with + FileFeature(ElfHeader(x)) -> x + | _ -> failwith "impossible: no header" + )) + +(*val elf_memory_image_sht : elf_memory_image -> maybe elf64_section_header_table*) +let elf_memory_image_sht img2:((elf64_section_header_table_entry)list)option= + ((match unique_tag_matching + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict (FileFeature(null_section_header_table)) img2 with + FileFeature(ElfSectionHeaderTable(x)) -> Some x + | _ -> None + )) + +(*val elf_memory_image_section_ranges : elf_memory_image -> (list elf_range_tag * list element_range)*) +let elf_memory_image_section_ranges img2:((Abis.any_abi_feature)range_tag)list*(element_range)list= +( + (* find all element ranges labelled as ELF sections *)let tagged_ranges = (tagged_ranges_matching_tag + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict (FileFeature(ElfSection(Nat_big_num.of_int 0, null_elf64_interpreted_section))) img2) + in + let (tags, maybe_ranges) = (List.split tagged_ranges) + in + (tags, make_ranges_definite maybe_ranges)) + +(*val elf_memory_image_section_by_index : natural -> elf_memory_image -> maybe elf64_interpreted_section*) +let elf_memory_image_section_by_index idx1 img2:(elf64_interpreted_section)option= +( + (* find all element ranges labelled as ELF sections *)let (allSectionTags, allSectionElementRanges) = (elf_memory_image_section_ranges img2) + in + let matches = (mapMaybei (fun i -> (fun tag -> (match tag with + FileFeature(ElfSection(itsIdx, s)) -> if Nat_big_num.equal itsIdx idx1 then Some s else None + | _ -> failwith "impossible" + ))) allSectionTags) + in + (match matches with + [] -> None + | [x] -> Some x + | x -> failwith ("impossible: more than one ELF section with same index" (*"(" ^ (show idx) ^ ")"*)) + )) + +(*val elf_memory_image_element_coextensive_with_section : natural -> elf_memory_image -> maybe string*) +let elf_memory_image_element_coextensive_with_section idx1 img2:(string)option= +( + (* find all element ranges labelled as ELF sections *)let (allSectionTags, allSectionElementRanges) = (elf_memory_image_section_ranges img2) + in + let matches = (mapMaybei (fun i -> (fun (tag, (elName, (rangeStart, rangeLen))) -> (match tag with + FileFeature(ElfSection(itsIdx, s)) -> + let el_rec = ((match Pmap.lookup elName img2.elements with + Some x -> x + | None -> failwith "impossible: element not found" + )) + in + let size_matches = +( + (* HMM. This is complicated. Generally we like to ignore + * isec fields that are superseded by memory_image fields, + * here the element length. But we want to catch the case + * where there's an inconsistency, and we *might* want to allow the + * case where the element length is still vague (Nothing). *)let range_len_matches_sec = ( Nat_big_num.equal rangeLen s.elf64_section_size) + in + let sec_matches_element_len = ( (Lem.option_equal Nat_big_num.equal(Some(s.elf64_section_size)) el_rec.length1)) + in + let range_len_matches_element_len = ( (Lem.option_equal Nat_big_num.equal(Some(rangeLen)) el_rec.length1)) + in + (* If any pair are unequal, then warn. *) + (*let _ = + if (range_len_matches_sec <> sec_matches_element_len + || sec_matches_element_len <> range_len_matches_element_len + || range_len_matches_sec <> range_len_matches_element_len) + then errln ("Warning: section lengths do not agree: " ^ s.elf64_section_name_as_string) + else () + in*) + range_len_matches_element_len) + in + if Nat_big_num.equal itsIdx idx1 && (Nat_big_num.equal rangeStart(Nat_big_num.of_int 0) + && size_matches) + then + (* *) + (* Sanity check: does the *) + Some elName + else None + | _ -> failwith "impossible" + ))) (list_combine allSectionTags allSectionElementRanges)) + in + (match matches with + [] -> None + | [x] -> Some x + | xs -> failwith ("impossible: more than one ELF section coextensive with section" ^ ((Nat_big_num.to_string idx1) ^ (", names: " + ^ (string_of_list + instance_Show_Show_string_dict xs)))) + )) + + +(*val name_of_elf_interpreted_section : + elf64_interpreted_section -> elf64_interpreted_section -> maybe string*) +let name_of_elf_interpreted_section s shstrtab:(string)option= + ((match get_string_at s.elf64_section_name (string_table_of_byte_sequence shstrtab.elf64_section_body) with + Success(x) -> Some x + | Fail(e) -> None + )) + +(*val elf_memory_image_sections_with_indices : elf_memory_image -> list (elf64_interpreted_section * natural)*) +let elf_memory_image_sections_with_indices img2:(elf64_interpreted_section*Nat_big_num.num)list= +( + (* We have to get all sections and their names, + * because section names need not be unique. *)let ((all_section_tags : elf_range_tag list), (all_section_ranges : element_range list)) + = (elf_memory_image_section_ranges img2) + in + Lem_list.map (fun tag -> + (match tag with + FileFeature(ElfSection(idx1, i)) -> (i, idx1) + | _ -> failwith "impossible: non-section in list of sections" + )) all_section_tags) + +(*val elf_memory_image_sections : elf_memory_image -> list elf64_interpreted_section*) +let elf_memory_image_sections img2:(elf64_interpreted_section)list= + (let (secs, _) = (List.split (elf_memory_image_sections_with_indices img2)) + in secs) + +(*val elf_memory_image_sections_with_name : string -> elf_memory_image -> list elf64_interpreted_section*) +let elf_memory_image_sections_with_name name1 img2:(elf64_interpreted_section)list= + (let all_interpreted_sections = (elf_memory_image_sections img2) + in + let maybe_shstrtab = (elf_memory_image_section_by_index (Nat_big_num.of_string (Uint32.to_string ((elf_memory_image_header img2).elf64_shstrndx))) img2) + in + let shstrtab = ((match maybe_shstrtab with + None -> failwith "no shtstrtab" + | Some x -> x + )) + in + let all_section_names = (Lem_list.map (fun i -> + let (stringtab : string_table) = (string_table_of_byte_sequence (shstrtab.elf64_section_body)) in + (match get_string_at i.elf64_section_name stringtab with + Fail _ -> None + | Success x -> Some x + )) all_interpreted_sections) + in + mapMaybe (fun (n, i) -> if (Lem.option_equal (=) (Some(name1)) n) then Some i else None) (list_combine all_section_names all_interpreted_sections)) +(* +val elf_memory_image_unique_section_with_name : string -> elf_memory_image -> elf64_interpreted_section +let elf_memory_image_unique_section_with_name name img = + match Map.lookup name img.image with + Just el -> match el with + FileFeature(ElfSection(_, x)) -> x + | _ -> failwith "impossible: section name does not name a section" + end + | + | Nothing -> failwith ("no section named '" ^ name ^ "' but asserted unique") + end +*) + +(* FIXME: delete these symbol functions, because Memory_image_orderings + * has generic ones. *) + +(*val elf_memory_image_symbol_def_ranges : elf_memory_image -> (list elf_range_tag * list (maybe element_range))*) +let elf_memory_image_symbol_def_ranges img2:((Abis.any_abi_feature)range_tag)list*((element_range)option)list= +( + (* find all element ranges labelled as ELF symbols *)let (tags, maybe_ranges) = (List.split ( + tagged_ranges_matching_tag + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict (SymbolDef(null_symbol_definition)) img2 + )) + in + (* some symbols, specifically ABS symbols, needn't label a range. *) + (tags, maybe_ranges)) + +(*val name_of_symbol_def : symbol_definition -> string*) +let name_of_symbol_def0 sym:string= (sym.def_symname) + +(*val elf_memory_image_defined_symbols_and_ranges : elf_memory_image -> list ((maybe element_range) * symbol_definition)*) +let elf_memory_image_defined_symbols_and_ranges img2:((element_range)option*symbol_definition)list= + (Memory_image_orderings.defined_symbols_and_ranges + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict img2) + +(*val elf_memory_image_defined_symbols : elf_memory_image -> list symbol_definition*) +let elf_memory_image_defined_symbols img2:(symbol_definition)list= + (let ((all_symbol_tags : elf_range_tag list), (all_symbol_ranges : ( element_range option) list)) + = (elf_memory_image_symbol_def_ranges img2) + in + Lem_list.mapMaybe (fun tag -> + (match tag with + SymbolDef(ent) -> Some ent + | _ -> failwith "impossible: non-symbol def in list of symbol defs" + )) all_symbol_tags) + +(* +val elf_memory_image_symbols_with_name : string -> elf_memory_image -> list symbol_definition +let elf_memory_image_symbols_with_name name img = + let all_interpreted_sections = elf_memory_image_sections img + in + let maybe_shstrtab = elf_memory_image_section_by_index (natural_of_elf64_half ((elf_memory_image_header img).elf64_shstrndx)) img + in + let shstrtab = match maybe_shstrtab with + Nothing -> failwith "no shtstrtab" + | Just x -> x + end + in + let all_section_names = List.map (fun i -> + let (stringtab : string_table) = string_table_of_byte_sequence (shstrtab.elf64_section_body) in + match get_string_at i.elf64_section_name stringtab with + Fail _ -> Nothing + | Success x -> Just x + end) all_interpreted_sections + in + mapMaybe (fun (n, i) -> if Just(name) = n then Just i else Nothing) (zip all_section_names all_interpreted_sections) +*) +(* +val elf_memory_image_unique_symbol_with_name : string -> elf_memory_image -> symbol_def +let elf_memory_image_unique_symbol_with_name name img = + match Map.lookup name img.image with + Just el -> match el with + FileFeature(ElfSection(_, x)) -> x + | _ -> failwith "impossible: section name does not name a section" + end + | + | Nothing -> failwith ("no section named '" ^ name ^ "' but asserted unique") + end +*) + + +(*val name_of_elf_section : elf64_interpreted_section -> elf_memory_image -> maybe string*) +let name_of_elf_section sec img2:(string)option= +( + (* let shstrndx = natural_of_elf64_half ((elf_memory_image_header img).elf64_shstrndx) + in + match elf_memory_image_section_by_index shstrndx img with + Nothing -> Nothing + | Just shstrtab -> name_of_elf_interpreted_section sec shstrtab + end *)Some sec.elf64_section_name_as_string) + +(*val name_of_elf_element : elf_file_feature -> elf_memory_image -> maybe string*) +let name_of_elf_element feature img2:(string)option= + ((match feature with + ElfSection(_, sec) -> name_of_elf_section sec img2 + | _ -> None (* FIXME *) + )) + +(*val get_unique_name_for_section_from_index : natural -> elf64_interpreted_section -> elf_memory_image -> string*) +let get_unique_name_for_section_from_index idx1 isec1 img2:string= +( + (* Don't call gensym just to retrieve the name *)(match elf_memory_image_element_coextensive_with_section idx1 img2 with + Some n -> n + | None -> failwith "section does not have an element name" + )) diff --git a/lib/ocaml_rts/linksem/elf_note.ml b/lib/ocaml_rts/linksem/elf_note.ml new file mode 100644 index 00000000..f9965d68 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_note.ml @@ -0,0 +1,196 @@ +(*Generated by Lem from elf_note.lem.*) +(** [elf_note] contains data types and functions for interpreting the .note + * section/segment of an ELF file, and extracting information from that + * section/segment. + *) + +open Lem_basic_classes +open Lem_list +open Lem_num +open Lem_string + +open Byte_sequence +open Endianness +open Error +open Missing_pervasives +open Show + +open Elf_program_header_table +open Elf_section_header_table +open Elf_types_native_uint + +(** [elf32_note] represents the contents of a .note section or segment. + *) +type elf32_note = + { elf32_note_namesz : Uint32.uint32 (** The size of the name field. *) + ; elf32_note_descsz : Uint32.uint32 (** The size of the description field. *) + ; elf32_note_type : Uint32.uint32 (** The type of the note. *) + ; elf32_note_name : char list (** The list of bytes (of length indicated above) corresponding to the name string. *) + ; elf32_note_desc : char list (** The list of bytes (of length indicated above) corresponding to the desc string. *) + } + +(** [elf64_note] represents the contents of a .note section or segment. + *) +type elf64_note = + { elf64_note_namesz : Uint64.uint64 (** The size of the name field. *) + ; elf64_note_descsz : Uint64.uint64 (** The size of the description field. *) + ; elf64_note_type : Uint64.uint64 (** The type of the note. *) + ; elf64_note_name : char list (** The list of bytes (of length indicated above) corresponding to the name string. *) + ; elf64_note_desc : char list (** The list of bytes (of length indicated above) corresponding to the desc string. *) + } + +(** [read_elf32_note endian bs0] transcribes an ELF note section from byte + * sequence [bs0] assuming endianness [endian]. May fail if transcription fails + * (i.e. if the byte sequence is not sufficiently long). + *) +(*val read_elf32_note : endianness -> byte_sequence -> error (elf32_note * byte_sequence)*) +let read_elf32_note endian bs0:(elf32_note*byte_sequence)error= + (read_elf32_word endian bs0 >>= (fun (namesz, bs0) -> + read_elf32_word endian bs0 >>= (fun (descsz, bs0) -> + read_elf32_word endian bs0 >>= (fun (typ, bs0) -> + repeatM' (Nat_big_num.of_string (Uint32.to_string namesz)) bs0 read_char >>= (fun (name1, bs0) -> + repeatM' (Nat_big_num.of_string (Uint32.to_string descsz)) bs0 read_char >>= (fun (desc, bs0) -> + return ({ elf32_note_namesz = namesz; elf32_note_descsz = descsz; + elf32_note_type = typ; elf32_note_name = name1; elf32_note_desc = desc }, + bs0))))))) + +(** [read_elf64_note endian bs0] transcribes an ELF note section from byte + * sequence [bs0] assuming endianness [endian]. May fail if transcription fails + * (i.e. if the byte sequence is not sufficiently long). + *) +(*val read_elf64_note : endianness -> byte_sequence -> error (elf64_note * byte_sequence)*) +let read_elf64_note endian bs0:(elf64_note*byte_sequence)error= + (read_elf64_xword endian bs0 >>= (fun (namesz, bs0) -> + read_elf64_xword endian bs0 >>= (fun (descsz, bs0) -> + read_elf64_xword endian bs0 >>= (fun (typ, bs0) -> + repeatM' (Ml_bindings.nat_big_num_of_uint64 namesz) bs0 read_char >>= (fun (name1, bs0) -> + repeatM' (Ml_bindings.nat_big_num_of_uint64 descsz) bs0 read_char >>= (fun (desc, bs0) -> + return ({ elf64_note_namesz = namesz; elf64_note_descsz = descsz; + elf64_note_type = typ; elf64_note_name = name1; elf64_note_desc = desc }, + bs0))))))) + +(** [obtain_elf32_note_sections endian sht bs0] returns all note sections present + * in an ELF file, as indicated by the file's section header table [sht], reading + * them from byte sequence [bs0] assuming endianness [endian]. May fail if + * transcription of a note section fails. + *) +(*val obtain_elf32_note_sections : endianness -> elf32_section_header_table -> + byte_sequence -> error (list elf32_note)*) +let obtain_elf32_note_sections endian sht bs0:((elf32_note)list)error= + (let note_sects = +(List.filter (fun x -> + x.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string sht_note) + ) sht) + in + mapM (fun x -> + let offset = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_size)) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun rel -> + read_elf32_note endian rel >>= (fun (note, _) -> + return note)) + ) note_sects) + +(** [obtain_elf64_note_sections endian sht bs0] returns all note sections present + * in an ELF file, as indicated by the file's section header table [sht], reading + * them from byte sequence [bs0] assuming endianness [endian]. May fail if + * transcription of a note section fails. + *) +(*val obtain_elf64_note_sections : endianness -> elf64_section_header_table -> + byte_sequence -> error (list elf64_note)*) +let obtain_elf64_note_sections endian sht bs0:((elf64_note)list)error= + (let note_sects = +(List.filter (fun x -> + x.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string sht_note) + ) sht) + in + mapM (fun x -> + let offset = (Nat_big_num.of_string (Uint64.to_string x.elf64_sh_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 x.elf64_sh_size) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun rel -> + read_elf64_note endian rel >>= (fun (note, _) -> + return note)) + ) note_sects) + +(** [obtain_elf32_note_segments endian pht bs0] returns all note segments present + * in an ELF file, as indicated by the file's program header table [pht], reading + * them from byte sequence [bs0] assuming endianness [endian]. May fail if + * transcription of a note section fails. + *) +(*val obtain_elf32_note_segments : endianness -> elf32_program_header_table -> + byte_sequence -> error (list elf32_note)*) +let obtain_elf32_note_segments endian pht bs0:((elf32_note)list)error= + (let note_segs = +(List.filter (fun x -> + x.elf32_p_type = Uint32.of_string (Nat_big_num.to_string elf_pt_note) + ) pht) + in + mapM (fun x -> + let offset = (Nat_big_num.of_string (Uint32.to_string x.elf32_p_offset)) in + let size2 = (Nat_big_num.of_string (Uint32.to_string x.elf32_p_filesz)) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun rel -> + read_elf32_note endian rel >>= (fun (note, _) -> + return note)) + ) note_segs) + +(** [obtain_elf64_note_segments endian pht bs0] returns all note segments present + * in an ELF file, as indicated by the file's program header table [pht], reading + * them from byte sequence [bs0] assuming endianness [endian]. May fail if + * transcription of a note section fails. + *) +(*val obtain_elf64_note_segments : endianness -> elf64_program_header_table -> + byte_sequence -> error (list elf64_note)*) +let obtain_elf64_note_segments endian pht bs0:((elf64_note)list)error= + (let note_segs = +(List.filter (fun x -> + x.elf64_p_type = Uint32.of_string (Nat_big_num.to_string elf_pt_note) + ) pht) + in + mapM (fun x -> + let offset = (Nat_big_num.of_string (Uint64.to_string x.elf64_p_offset)) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 x.elf64_p_filesz) in + Byte_sequence.offset_and_cut offset size2 bs0 >>= (fun rel -> + read_elf64_note endian rel >>= (fun (note, _) -> + return note)) + ) note_segs) + +(** [obtain_elf32_note_section_and_segments endian pht sht bs0] returns all note + * sections and segments present in an ELF file, as indicated by the file's + * program header table [pht] and section header table [sht], reading + * them from byte sequence [bs0] assuming endianness [endian]. May fail if + * transcription of a note section or segment fails. + *) +(*val obtain_elf32_note_section_and_segments : endianness -> elf32_program_header_table -> + elf32_section_header_table -> byte_sequence -> error (list elf32_note)*) +let obtain_elf32_note_section_and_segments endian pht sht bs0:((elf32_note)list)error= + (obtain_elf32_note_segments endian pht bs0 >>= (fun pht_notes -> + obtain_elf32_note_sections endian sht bs0 >>= (fun sht_notes -> + return ( List.rev_append (List.rev pht_notes) sht_notes)))) + +(** [obtain_elf64_note_section_and_segments endian pht sht bs0] returns all note + * sections and segments present in an ELF file, as indicated by the file's + * program header table [pht] and section header table [sht], reading + * them from byte sequence [bs0] assuming endianness [endian]. May fail if + * transcription of a note section or segment fails. + *) +(*val obtain_elf64_note_section_and_segments : endianness -> elf64_program_header_table -> + elf64_section_header_table -> byte_sequence -> error (list elf64_note)*) +let obtain_elf64_note_section_and_segments endian pht sht bs0:((elf64_note)list)error= + (obtain_elf64_note_segments endian pht bs0 >>= (fun pht_notes -> + obtain_elf64_note_sections endian sht bs0 >>= (fun sht_notes -> + return ( List.rev_append (List.rev pht_notes) sht_notes)))) + +(** [name_string_of_elf32_note note] extracts the name string of an ELF note + * section, interpreting the section's uninterpreted name field as a string. + *) +(*val name_string_of_elf32_note : elf32_note -> string*) +let name_string_of_elf32_note note:string= + (let bs0 = (Byte_sequence.from_byte_lists [note.elf32_note_name]) in + Byte_sequence.string_of_byte_sequence bs0) + +(** [name_string_of_elf64_note note] extracts the name string of an ELF note + * section, interpreting the section's uninterpreted name field as a string. + *) +(*val name_string_of_elf64_note : elf64_note -> string*) +let name_string_of_elf64_note note:string= + (let bs0 = (Byte_sequence.from_byte_lists [note.elf64_note_name]) in + Byte_sequence.string_of_byte_sequence bs0) diff --git a/lib/ocaml_rts/linksem/elf_program_header_table.ml b/lib/ocaml_rts/linksem/elf_program_header_table.ml new file mode 100644 index 00000000..6afe4d53 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_program_header_table.ml @@ -0,0 +1,605 @@ +(*Generated by Lem from elf_program_header_table.lem.*) +(** [elf_program_header_table] contains type, functions and other definitions + * for working with program header tables and their entries and ELF segments. + * Related files are [elf_interpreted_segments] which extracts information + * derived from PHTs presented in this file and converts it into a more usable + * format for processing. + * + * FIXME: + * Bug in Lem as Lem codebase uses [int] type throughout where [BigInt.t] + * is really needed, hence chokes on huge constants below, which is why they are + * written in the way that they are. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_function +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +(*import Set*) + +open Elf_types_native_uint +open Endianness + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +(** Segment types *) + +(** Unused array element. All other members of the structure are undefined. *) +let elf_pt_null : Nat_big_num.num= (Nat_big_num.of_int 0) +(** A loadable segment. *) +let elf_pt_load : Nat_big_num.num= (Nat_big_num.of_int 1) +(** Dynamic linking information. *) +let elf_pt_dynamic : Nat_big_num.num= (Nat_big_num.of_int 2) +(** Specifies the location and size of a null-terminated path name to be used to + * invoke an interpreter. + *) +let elf_pt_interp : Nat_big_num.num= (Nat_big_num.of_int 3) +(** Specifies location and size of auxiliary information. *) +let elf_pt_note : Nat_big_num.num= (Nat_big_num.of_int 4) +(** Reserved but with unspecified semantics. If the file contains a segment of + * this type then it is to be regarded as non-conformant with the ABI. + *) +let elf_pt_shlib : Nat_big_num.num= (Nat_big_num.of_int 5) +(** Specifies the location and size of the program header table. *) +let elf_pt_phdr : Nat_big_num.num= (Nat_big_num.of_int 6) +(** Specifies the thread local storage (TLS) template. Need not be supported. *) +let elf_pt_tls : Nat_big_num.num= (Nat_big_num.of_int 7) +(** Start of reserved indices for operating system specific semantics. *) +let elf_pt_loos : Nat_big_num.num= (Nat_big_num.mul (Nat_big_num.mul (Nat_big_num.mul (Nat_big_num.mul(Nat_big_num.of_int 128)(Nat_big_num.of_int 128))(Nat_big_num.of_int 128))(Nat_big_num.of_int 256))(Nat_big_num.of_int 3)) (* 1610612736 (* 0x60000000 *) *) +(** End of reserved indices for operating system specific semantics. *) +let elf_pt_hios : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 469762047)(Nat_big_num.of_int 4))(Nat_big_num.of_int 3)) (* 1879048191 (* 0x6fffffff *) *) +(** Start of reserved indices for processor specific semantics. *) +let elf_pt_loproc : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 469762048)(Nat_big_num.of_int 4)) (* 1879048192 (* 0x70000000 *) *) +(** End of reserved indices for processor specific semantics. *) +let elf_pt_hiproc : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 536870911)(Nat_big_num.of_int 4))(Nat_big_num.of_int 3)) (* 2147483647 (* 0x7fffffff *) *) + +(** [string_of_elf_segment_type os proc st] produces a string representation of + * the coding of an ELF segment type [st] using [os] and [proc] to render OS- + * and processor-specific codings. + *) +(* XXX: is GNU stuff supposed to be hardcoded here? *) +(*val string_of_segment_type : (natural -> string) -> (natural -> string) -> natural -> string*) +let string_of_segment_type os proc pt:string= + (if Nat_big_num.equal pt elf_pt_null then + "NULL" + else if Nat_big_num.equal pt elf_pt_load then + "LOAD" + else if Nat_big_num.equal pt elf_pt_dynamic then + "DYNAMIC" + else if Nat_big_num.equal pt elf_pt_interp then + "INTERP" + else if Nat_big_num.equal pt elf_pt_note then + "NOTE" + else if Nat_big_num.equal pt elf_pt_shlib then + "SHLIB" + else if Nat_big_num.equal pt elf_pt_phdr then + "PHDR" + else if Nat_big_num.equal pt elf_pt_tls then + "TLS" + else if Nat_big_num.greater_equal pt elf_pt_loos && Nat_big_num.less_equal pt elf_pt_hios then + os pt + else if Nat_big_num.greater_equal pt elf_pt_loproc && Nat_big_num.less_equal pt elf_pt_hiproc then + proc pt + else + "Undefined or invalid segment type") + +(** Segments permission flags *) + +(** Execute bit *) +let elf_pf_x : Nat_big_num.num= (Nat_big_num.of_int 1) +(** Write bit *) +let elf_pf_w : Nat_big_num.num= (Nat_big_num.of_int 2) +(** Read bit *) +let elf_pf_r : Nat_big_num.num= (Nat_big_num.of_int 4) +(** The following two bit ranges are reserved for OS- and processor-specific + * flags respectively. + *) +let elf_pf_maskos : Nat_big_num.num= (Nat_big_num.of_int 267386880) (* 0x0ff00000 *) +let elf_pf_maskproc : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 1006632960)) (* 0xf0000000 *) + +(** [exact_permission_of_permission m]: ELF has two interpretations of a RWX-style + * permission bit [m], an exact permission and an allowable permission. These + * permissions allow us to interpret a flag as an upper bound for behaviour and + * an ABI-compliant implementation can choose to interpret the flag [m] as either. + * + * In the exact interpretation, the upper bound is exactly the natural interpretation + * of the flag. This is encoded in [exact_permission_of_permission], which is + * a glorified identity function, though included for completeness. + *) +(*val exact_permissions_of_permission : natural -> error natural*) +let exact_permissions_of_permission m:(Nat_big_num.num)error= + (if Nat_big_num.equal m(Nat_big_num.of_int 0) then + return(Nat_big_num.of_int 0) + else if Nat_big_num.equal m elf_pf_x then + return(Nat_big_num.of_int 1) + else if Nat_big_num.equal m elf_pf_w then + return(Nat_big_num.of_int 2) + else if Nat_big_num.equal m elf_pf_r then + return(Nat_big_num.of_int 4) + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_x elf_pf_w) then + return(Nat_big_num.of_int 3) + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_x elf_pf_r) then + return(Nat_big_num.of_int 5) + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_w elf_pf_r) then + return(Nat_big_num.of_int 6) + else if Nat_big_num.equal m (Nat_big_num.add (Nat_big_num.add elf_pf_x elf_pf_r) elf_pf_w) then + return(Nat_big_num.of_int 7) + else + fail "exact_permission_of_permission: invalid permission flag") + +(** [allowable_permission_of_permission m]: ELF has two interpretations of a RWX-style + * permission bit [m], an exact permission and an allowable permission. These + * permissions allow us to interpret a flag as an upper bound for behaviour and + * an ABI-compliant implementation can choose to interpret the flag [m] as either. + * + * In the allowable interpretation, the upper bound is more lax than the natural + * interpretation of the flag. + *) +(*val allowable_permissions_of_permission : natural -> error natural*) +let allowable_permissions_of_permission m:(Nat_big_num.num)error= + (if Nat_big_num.equal m(Nat_big_num.of_int 0) then + return(Nat_big_num.of_int 0) + else if Nat_big_num.equal m elf_pf_x then + return(Nat_big_num.of_int 5) + else if Nat_big_num.equal m elf_pf_w then + return(Nat_big_num.of_int 7) + else if Nat_big_num.equal m elf_pf_r then + return(Nat_big_num.of_int 5) + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_x elf_pf_w) then + return(Nat_big_num.of_int 7) + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_x elf_pf_r) then + return(Nat_big_num.of_int 5) + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_w elf_pf_r) then + return(Nat_big_num.of_int 7) + else if Nat_big_num.equal m (Nat_big_num.add (Nat_big_num.add elf_pf_x elf_pf_r) elf_pf_w) then + return(Nat_big_num.of_int 7) + else + fail "exact_permission_of_permission: invalid permission flag") + +(** [string_of_elf_segment_permissions m] produces a string-based representation + * of an ELF segment's permission field. + * TODO: expand this as is needed by the validation tests. + *) +(*val string_of_elf_segment_permissions : natural -> string*) +let string_of_elf_segment_permissions m:string= + (if Nat_big_num.equal m(Nat_big_num.of_int 0) then + " " + else if Nat_big_num.equal m elf_pf_x then + " E" + else if Nat_big_num.equal m elf_pf_w then + " W " + else if Nat_big_num.equal m elf_pf_r then + "R " + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_x elf_pf_w) then + " WE" + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_x elf_pf_r) then + "R E" + else if Nat_big_num.equal m (Nat_big_num.add elf_pf_w elf_pf_r) then + "RW " + else if Nat_big_num.equal m (Nat_big_num.add (Nat_big_num.add elf_pf_x elf_pf_r) elf_pf_w) then + "RWE" + else + "Invalid permisssion flag") + +(** Program header table entry type *) + +(** Type [elf32_program_header_table_entry] encodes a program header table entry + * for 32-bit platforms. Each entry describes a segment in an executable or + * shared object file. + *) +type elf32_program_header_table_entry = + { elf32_p_type : Uint32.uint32 (** Type of the segment *) + ; elf32_p_offset : Uint32.uint32 (** Offset from beginning of file for segment *) + ; elf32_p_vaddr : Uint32.uint32 (** Virtual address for segment in memory *) + ; elf32_p_paddr : Uint32.uint32 (** Physical address for segment *) + ; elf32_p_filesz : Uint32.uint32 (** Size of segment in file, in bytes *) + ; elf32_p_memsz : Uint32.uint32 (** Size of segment in memory image, in bytes *) + ; elf32_p_flags : Uint32.uint32 (** Segment flags *) + ; elf32_p_align : Uint32.uint32 (** Segment alignment memory for memory and file *) + } + +(** [compare_elf32_program_header_table_entry ent1 ent2] is an ordering-comparison + * function on program header table entries suitable for constructing sets, + * finite maps, and other ordered data types with. + *) +(*val compare_elf32_program_header_table_entry : elf32_program_header_table_entry -> + elf32_program_header_table_entry -> ordering*) +let compare_elf32_program_header_table_entry h1 h2:int= + (lexicographic_compare Nat_big_num.compare [Nat_big_num.of_string (Uint32.to_string h1.elf32_p_type); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_offset); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_vaddr); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_paddr); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_filesz); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_memsz); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_flags); + Nat_big_num.of_string (Uint32.to_string h1.elf32_p_align)] + [Nat_big_num.of_string (Uint32.to_string h2.elf32_p_type); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_offset); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_vaddr); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_paddr); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_filesz); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_memsz); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_flags); + Nat_big_num.of_string (Uint32.to_string h2.elf32_p_align)]) + +let instance_Basic_classes_Ord_Elf_program_header_table_elf32_program_header_table_entry_dict:(elf32_program_header_table_entry)ord_class= ({ + + compare_method = compare_elf32_program_header_table_entry; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf32_program_header_table_entry f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf32_program_header_table_entry f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf32_program_header_table_entry f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf32_program_header_table_entry f1 f2)(Pset.from_list compare [1; 0])))}) + +(** Type [elf64_program_header_table_entry] encodes a program header table entry + * for 64-bit platforms. Each entry describes a segment in an executable or + * shared object file. + *) +type elf64_program_header_table_entry = + { elf64_p_type : Uint32.uint32 (** Type of the segment *) + ; elf64_p_flags : Uint32.uint32 (** Segment flags *) + ; elf64_p_offset : Uint64.uint64 (** Offset from beginning of file for segment *) + ; elf64_p_vaddr : Uint64.uint64 (** Virtual address for segment in memory *) + ; elf64_p_paddr : Uint64.uint64 (** Physical address for segment *) + ; elf64_p_filesz : Uint64.uint64 (** Size of segment in file, in bytes *) + ; elf64_p_memsz : Uint64.uint64 (** Size of segment in memory image, in bytes *) + ; elf64_p_align : Uint64.uint64 (** Segment alignment memory for memory and file *) + } + +(** [compare_elf64_program_header_table_entry ent1 ent2] is an ordering-comparison + * function on program header table entries suitable for constructing sets, + * finite maps, and other ordered data types with. + *) +(*val compare_elf64_program_header_table_entry : elf64_program_header_table_entry -> + elf64_program_header_table_entry -> ordering*) +let compare_elf64_program_header_table_entry h1 h2:int= + (lexicographic_compare Nat_big_num.compare [Nat_big_num.of_string (Uint32.to_string h1.elf64_p_type); + Nat_big_num.of_string (Uint64.to_string h1.elf64_p_offset); + Ml_bindings.nat_big_num_of_uint64 h1.elf64_p_vaddr; + Ml_bindings.nat_big_num_of_uint64 h1.elf64_p_paddr; + Ml_bindings.nat_big_num_of_uint64 h1.elf64_p_filesz; + Ml_bindings.nat_big_num_of_uint64 h1.elf64_p_memsz; + Nat_big_num.of_string (Uint32.to_string h1.elf64_p_flags); + Ml_bindings.nat_big_num_of_uint64 h1.elf64_p_align] + [Nat_big_num.of_string (Uint32.to_string h2.elf64_p_type); + Nat_big_num.of_string (Uint64.to_string h2.elf64_p_offset); + Ml_bindings.nat_big_num_of_uint64 h2.elf64_p_vaddr; + Ml_bindings.nat_big_num_of_uint64 h2.elf64_p_paddr; + Ml_bindings.nat_big_num_of_uint64 h2.elf64_p_filesz; + Ml_bindings.nat_big_num_of_uint64 h2.elf64_p_memsz; + Nat_big_num.of_string (Uint32.to_string h2.elf64_p_flags); + Ml_bindings.nat_big_num_of_uint64 h2.elf64_p_align]) + +let instance_Basic_classes_Ord_Elf_program_header_table_elf64_program_header_table_entry_dict:(elf64_program_header_table_entry)ord_class= ({ + + compare_method = compare_elf64_program_header_table_entry; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_program_header_table_entry f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf64_program_header_table_entry f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_program_header_table_entry f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf64_program_header_table_entry f1 f2)(Pset.from_list compare [1; 0])))}) + + +(** [string_of_elf32_program_header_table_entry os proc et] produces a string + * representation of a 32-bit program header table entry using [os] and [proc] + * to render OS- and processor-specific entries. + *) +(*val string_of_elf32_program_header_table_entry : (natural -> string) -> (natural -> string) -> elf32_program_header_table_entry -> string*) +let string_of_elf32_program_header_table_entry os proc entry:string= + (unlines [ +("\t" ^ ("Segment type: " ^ string_of_segment_type os proc (Nat_big_num.of_string (Uint32.to_string entry.elf32_p_type)))) + ; ("\t" ^ ("Offset: " ^ Uint32.to_string entry.elf32_p_offset)) + ; ("\t" ^ ("Virtual address: " ^ Uint32.to_string entry.elf32_p_vaddr)) + ; ("\t" ^ ("Physical address: " ^ Uint32.to_string entry.elf32_p_paddr)) + ; ("\t" ^ ("Segment size (bytes): " ^ Uint32.to_string entry.elf32_p_filesz)) + ; ("\t" ^ ("Segment size in memory image (bytes): " ^ Uint32.to_string entry.elf32_p_memsz)) + ; ("\t" ^ ("Flags: " ^ Uint32.to_string entry.elf32_p_flags)) + ; ("\t" ^ ("Alignment: " ^ Uint32.to_string entry.elf32_p_align)) + ]) + +(** [string_of_elf64_program_header_table_entry os proc et] produces a string + * representation of a 64-bit program header table entry using [os] and [proc] + * to render OS- and processor-specific entries. + *) +(*val string_of_elf64_program_header_table_entry : (natural -> string) -> (natural -> string) -> elf64_program_header_table_entry -> string*) +let string_of_elf64_program_header_table_entry os proc entry:string= + (unlines [ +("\t" ^ ("Segment type: " ^ string_of_segment_type os proc (Nat_big_num.of_string (Uint32.to_string entry.elf64_p_type)))) + ; ("\t" ^ ("Offset: " ^ Uint64.to_string entry.elf64_p_offset)) + ; ("\t" ^ ("Virtual address: " ^ Uint64.to_string entry.elf64_p_vaddr)) + ; ("\t" ^ ("Physical address: " ^ Uint64.to_string entry.elf64_p_paddr)) + ; ("\t" ^ ("Segment size (bytes): " ^ Uint64.to_string entry.elf64_p_filesz)) + ; ("\t" ^ ("Segment size in memory image (bytes): " ^ Uint64.to_string entry.elf64_p_memsz)) + ; ("\t" ^ ("Flags: " ^ Uint32.to_string entry.elf64_p_flags)) + ; ("\t" ^ ("Alignment: " ^ Uint64.to_string entry.elf64_p_align)) + ]) + +(** [string_of_elf32_program_header_table_entry_default et] produces a string representation + * of table entry [et] where OS- and processor-specific entries are replaced with + * default strings. + *) +(*val string_of_elf32_program_header_table_entry_default : elf32_program_header_table_entry -> string*) +let string_of_elf32_program_header_table_entry_default:elf32_program_header_table_entry ->string= + (string_of_elf32_program_header_table_entry + ((fun y->"*Default OS specific print*")) + ((fun y->"*Default processor specific print*"))) + +(** [string_of_elf64_program_header_table_entry_default et] produces a string representation + * of table entry [et] where OS- and processor-specific entries are replaced with + * default strings. + *) +(*val string_of_elf64_program_header_table_entry_default : elf64_program_header_table_entry -> string*) +let string_of_elf64_program_header_table_entry_default:elf64_program_header_table_entry ->string= + (string_of_elf64_program_header_table_entry + ((fun y->"*Default OS specific print*")) + ((fun y->"*Default processor specific print*"))) + +let instance_Show_Show_Elf_program_header_table_elf32_program_header_table_entry_dict:(elf32_program_header_table_entry)show_class= ({ + + show_method = string_of_elf32_program_header_table_entry_default}) + +let instance_Show_Show_Elf_program_header_table_elf64_program_header_table_entry_dict:(elf64_program_header_table_entry)show_class= ({ + + show_method = string_of_elf64_program_header_table_entry_default}) + +(** Parsing and blitting *) + +(** [bytes_of_elf32_program_header_table_entry ed ent] blits a 32-bit program + * header table entry [ent] into a byte sequence assuming endianness [ed]. + *) +(*val bytes_of_elf32_program_header_table_entry : endianness -> elf32_program_header_table_entry -> byte_sequence*) +let bytes_of_elf32_program_header_table_entry endian entry:byte_sequence= + (Byte_sequence.from_byte_lists [ + bytes_of_elf32_word endian entry.elf32_p_type + ; bytes_of_elf32_off endian entry.elf32_p_offset + ; bytes_of_elf32_addr endian entry.elf32_p_vaddr + ; bytes_of_elf32_addr endian entry.elf32_p_paddr + ; bytes_of_elf32_word endian entry.elf32_p_filesz + ; bytes_of_elf32_word endian entry.elf32_p_memsz + ; bytes_of_elf32_word endian entry.elf32_p_flags + ; bytes_of_elf32_word endian entry.elf32_p_align + ]) + +(** [bytes_of_elf64_program_header_table_entry ed ent] blits a 64-bit program + * header table entry [ent] into a byte sequence assuming endianness [ed]. + *) +(*val bytes_of_elf64_program_header_table_entry : endianness -> elf64_program_header_table_entry -> byte_sequence*) +let bytes_of_elf64_program_header_table_entry endian entry:byte_sequence= + (Byte_sequence.from_byte_lists [ + bytes_of_elf64_word endian entry.elf64_p_type + ; bytes_of_elf64_word endian entry.elf64_p_flags + ; bytes_of_elf64_off endian entry.elf64_p_offset + ; bytes_of_elf64_addr endian entry.elf64_p_vaddr + ; bytes_of_elf64_addr endian entry.elf64_p_paddr + ; bytes_of_elf64_xword endian entry.elf64_p_filesz + ; bytes_of_elf64_xword endian entry.elf64_p_memsz + ; bytes_of_elf64_xword endian entry.elf64_p_align + ]) + +(** [read_elf32_program_header_table_entry endian bs0] reads an ELF32 program header table + * entry from byte sequence [bs0] assuming endianness [endian]. If [bs0] is larger + * than necessary, the excess is returned from the function, too. + * Fails if the entry cannot be read. + *) +(*val read_elf32_program_header_table_entry : endianness -> byte_sequence -> + error (elf32_program_header_table_entry * byte_sequence)*) +let read_elf32_program_header_table_entry endian bs:(elf32_program_header_table_entry*byte_sequence)error= + (read_elf32_word endian bs >>= (fun (typ, bs) -> + read_elf32_off endian bs >>= (fun (offset, bs) -> + read_elf32_addr endian bs >>= (fun (vaddr, bs) -> + read_elf32_addr endian bs >>= (fun (paddr, bs) -> + read_elf32_word endian bs >>= (fun (filesz, bs) -> + read_elf32_word endian bs >>= (fun (memsz, bs) -> + read_elf32_word endian bs >>= (fun (flags, bs) -> + read_elf32_word endian bs >>= (fun (align, bs) -> + return ({ elf32_p_type = typ; elf32_p_offset = offset; + elf32_p_vaddr = vaddr; elf32_p_paddr = paddr; + elf32_p_filesz = filesz; elf32_p_memsz = memsz; + elf32_p_flags = flags; elf32_p_align = align }, bs)))))))))) + +(** [read_elf64_program_header_table_entry endian bs0] reads an ELF64 program header table + * entry from byte sequence [bs0] assuming endianness [endian]. If [bs0] is larger + * than necessary, the excess is returned from the function, too. + * Fails if the entry cannot be read. + *) +(*val read_elf64_program_header_table_entry : endianness -> byte_sequence -> + error (elf64_program_header_table_entry * byte_sequence)*) +let read_elf64_program_header_table_entry endian bs:(elf64_program_header_table_entry*byte_sequence)error= + (read_elf64_word endian bs >>= (fun (typ, bs) -> + read_elf64_word endian bs >>= (fun (flags, bs) -> + read_elf64_off endian bs >>= (fun (offset, bs) -> + read_elf64_addr endian bs >>= (fun (vaddr, bs) -> + read_elf64_addr endian bs >>= (fun (paddr, bs) -> + read_elf64_xword endian bs >>= (fun (filesz, bs) -> + read_elf64_xword endian bs >>= (fun (memsz, bs) -> + read_elf64_xword endian bs >>= (fun (align, bs) -> + return ({ elf64_p_type = typ; elf64_p_offset = offset; + elf64_p_vaddr = vaddr; elf64_p_paddr = paddr; + elf64_p_filesz = filesz; elf64_p_memsz = memsz; + elf64_p_flags = flags; elf64_p_align = align }, bs)))))))))) + +(** Program header table type *) + +(** Type [elf32_program_header_table] represents a program header table for 32-bit + * ELF files. A program header table is an array (implemented as a list, here) + * of program header table entries. + *) +type elf32_program_header_table = elf32_program_header_table_entry + list + +(** Type [elf64_program_header_table] represents a program header table for 64-bit + * ELF files. A program header table is an array (implemented as a list, here) + * of program header table entries. + *) +type elf64_program_header_table = elf64_program_header_table_entry + list + +(** [bytes_of_elf32_program_header_table ed tbl] blits an ELF32 program header + * table into a byte sequence assuming endianness [ed]. + *) +let bytes_of_elf32_program_header_table endian tbl:byte_sequence= + (Byte_sequence.concat0 (Lem_list.map (bytes_of_elf32_program_header_table_entry endian) tbl)) + +(** [bytes_of_elf64_program_header_table ed tbl] blits an ELF64 program header + * table into a byte sequence assuming endianness [ed]. + *) +let bytes_of_elf64_program_header_table endian tbl:byte_sequence= + (Byte_sequence.concat0 (Lem_list.map (bytes_of_elf64_program_header_table_entry endian) tbl)) + +(** [read_elf32_program_header_table' endian bs0] reads an ELF32 program header table from + * byte_sequence [bs0] assuming endianness [endian]. The byte_sequence [bs0] is assumed + * to have exactly the correct size for the table. For internal use, only. Use + * [read_elf32_program_header_table] below instead. + *) +let rec read_elf32_program_header_table' endian bs0:((elf32_program_header_table_entry)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf32_program_header_table_entry endian bs0 >>= (fun (entry, bs1) -> + read_elf32_program_header_table' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf64_program_header_table' endian bs0] reads an ELF64 program header table from + * byte_sequence [bs0] assuming endianness [endian]. The byte_sequence [bs0] is assumed + * to have exactly the correct size for the table. For internal use, only. Use + * [read_elf32_program_header_table] below instead. + *) +let rec read_elf64_program_header_table' endian bs0:((elf64_program_header_table_entry)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf64_program_header_table_entry endian bs0 >>= (fun (entry, bs1) -> + read_elf64_program_header_table' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf32_program_header_table table_size endian bs0] reads an ELF32 program header + * table from byte_sequence [bs0] assuming endianness [endian] based on the size (in bytes) passed in via [table_size]. + * This [table_size] argument should be equal to the number of entries in the + * table multiplied by the fixed entry size. Bitstring [bs0] may be larger than + * necessary, in which case the excess is returned. + *) +(*val read_elf32_program_header_table : natural -> endianness -> byte_sequence -> + error (elf32_program_header_table * byte_sequence)*) +let read_elf32_program_header_table table_size endian bs0:((elf32_program_header_table_entry)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf32_program_header_table' endian eat >>= (fun table -> + return (table, rest)))) + +(** [read_elf64_program_header_table table_size endian bs0] reads an ELF64 program header + * table from byte_sequence [bs0] assuming endianness [endian] based on the size (in bytes) passed in via [table_size]. + * This [table_size] argument should be equal to the number of entries in the + * table multiplied by the fixed entry size. Bitstring [bs0] may be larger than + * necessary, in which case the excess is returned. + *) +(*val read_elf64_program_header_table : natural -> endianness -> byte_sequence -> + error (elf64_program_header_table * byte_sequence)*) +let read_elf64_program_header_table table_size endian bs0:((elf64_program_header_table_entry)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf64_program_header_table' endian eat >>= (fun table -> + return (table, rest)))) + +(** The [pht_print_bundle] type is used to tidy up other type signatures. Some of the + * top-level string_of_ functions require six or more functions passed to them, + * which quickly gets out of hand. This type is used to reduce that complexity. + * The first component of the type is an OS specific print function, the second is + * a processor specific print function. + *) +type pht_print_bundle = (Nat_big_num.num -> string) * (Nat_big_num.num -> string) + +(** [string_of_elf32_program_header_table os proc tbl] produces a string representation + * of program header table [tbl] using [os] and [proc] to render OS- and processor- + * specific entries. + *) +(*val string_of_elf32_program_header_table : pht_print_bundle -> elf32_program_header_table -> string*) +let string_of_elf32_program_header_table (os, proc) tbl:string= + (unlines (Lem_list.map (string_of_elf32_program_header_table_entry os proc) tbl)) + +(** [string_of_elf64_program_header_table os proc tbl] produces a string representation + * of program header table [tbl] using [os] and [proc] to render OS- and processor- + * specific entries. + *) +(*val string_of_elf64_program_header_table : pht_print_bundle -> elf64_program_header_table -> string*) +let string_of_elf64_program_header_table (os, proc) tbl:string= + (unlines (Lem_list.map (string_of_elf64_program_header_table_entry os proc) tbl)) + +(** Static/dynamic linkage *) + +(** [get_elf32_dynamic_linked pht] tests whether an ELF32 file is a dynamically + * linked object by traversing the program header table and attempting to find + * a header describing a segment with the name of an associated interpreter. + * Returns [true] if any such header is found, [false] --- indicating static + * linkage --- otherwise. + *) +(*val get_elf32_dynamic_linked : elf32_program_header_table -> bool*) +let get_elf32_dynamic_linked pht:bool= + (List.exists (fun p -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string p.elf32_p_type)) elf_pt_interp) pht) + +(** [get_elf64_dynamic_linked pht] tests whether an ELF64 file is a dynamically + * linked object by traversing the program header table and attempting to find + * a header describing a segment with the name of an associated interpreter. + * Returns [true] if any such header is found, [false] --- indicating static + * linkage --- otherwise. + *) +(*val get_elf64_dynamic_linked : elf64_program_header_table -> bool*) +let get_elf64_dynamic_linked pht:bool= + (List.exists (fun p -> Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string p.elf64_p_type)) elf_pt_interp) pht) + +(** [get_elf32_static_linked] is a utility function defined as the inverse + * of [get_elf32_dynamic_linked]. + *) +(*val get_elf32_static_linked : elf32_program_header_table -> bool*) +let get_elf32_static_linked pht:bool= + (not (get_elf32_dynamic_linked pht)) + +(** [get_elf64_static_linked] is a utility function defined as the inverse + * of [get_elf64_dynamic_linked]. + *) +(*val get_elf64_static_linked : elf64_program_header_table -> bool*) +let get_elf64_static_linked pht:bool= + (not (get_elf64_dynamic_linked pht)) + +(** [get_elf32_requested_interpreter ent bs0] extracts the requested interpreter + * of a dynamically linkable ELF file from that file's program header table + * entry of type PT_INTERP, [ent]. Interpreter string is extracted from byte + * sequence [bs0]. + * Fails if [ent] is not of type PT_INTERP, or if transcription otherwise fails. + *) +(*val get_elf32_requested_interpreter : elf32_program_header_table_entry -> + byte_sequence -> error string*) +let get_elf32_requested_interpreter pent bs0:(string)error= + (if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_type)) elf_pt_interp then + let off = (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string pent.elf32_p_filesz)) in + Byte_sequence.offset_and_cut off ( Nat_big_num.sub_nat siz(Nat_big_num.of_int 1)) bs0 >>= (fun cut -> + return (Byte_sequence.string_of_byte_sequence cut)) + else + fail "get_elf32_requested_interpreter: not an INTERP segment header") + +(** [get_elf64_requested_interpreter ent bs0] extracts the requested interpreter + * of a dynamically linkable ELF file from that file's program header table + * entry of type PT_INTERP, [ent]. Interpreter string is extracted from byte + * sequence [bs0]. + * Fails if [ent] is not of type PT_INTERP, or if transcription otherwise fails. + *) +(*val get_elf64_requested_interpreter : elf64_program_header_table_entry -> + byte_sequence -> error string*) +let get_elf64_requested_interpreter pent bs0:(string)error= + (if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string pent.elf64_p_type)) elf_pt_interp then + let off = (Nat_big_num.of_string (Uint64.to_string pent.elf64_p_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 pent.elf64_p_filesz) in + Byte_sequence.offset_and_cut off ( Nat_big_num.sub_nat siz(Nat_big_num.of_int 1)) bs0 >>= (fun cut -> + return (Byte_sequence.string_of_byte_sequence cut)) + else + fail "get_elf64_requested_interpreter: not an INTERP segment header") diff --git a/lib/ocaml_rts/linksem/elf_relocation.ml b/lib/ocaml_rts/linksem/elf_relocation.ml new file mode 100644 index 00000000..65a77ef8 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_relocation.ml @@ -0,0 +1,312 @@ +(*Generated by Lem from elf_relocation.lem.*) +(** [elf_relocation] formalises types, functions and other definitions for working + * with ELF relocation and relocation with addend entries. + *) + +open Lem_basic_classes +open Lem_num +open Lem_list +(*import Set*) + +open Endianness +open Byte_sequence +open Error + +open Lem_string +open Show +open Missing_pervasives + +open Elf_types_native_uint + +(** ELF relocation records *) + +(** [elf32_relocation] is a simple relocation record (without addend). + *) +type elf32_relocation = + { elf32_r_offset : Uint32.uint32 (** Address at which to relocate *) + ; elf32_r_info : Uint32.uint32 (** Symbol table index/type of relocation to apply *) + } + +(** [elf32_relocation_a] is a relocation record with addend. + *) +type elf32_relocation_a = + { elf32_ra_offset : Uint32.uint32 (** Address at which to relocate *) + ; elf32_ra_info : Uint32.uint32 (** Symbol table index/type of relocation to apply *) + ; elf32_ra_addend : Int32.t (** Addend used to compute value to be stored *) + } + +(** [elf64_relocation] is a simple relocation record (without addend). + *) +type elf64_relocation = + { elf64_r_offset : Uint64.uint64 (** Address at which to relocate *) + ; elf64_r_info : Uint64.uint64 (** Symbol table index/type of relocation to apply *) + } + +(** [elf64_relocation_a] is a relocation record with addend. + *) +type elf64_relocation_a = + { elf64_ra_offset : Uint64.uint64 (** Address at which to relocate *) + ; elf64_ra_info : Uint64.uint64 (** Symbol table index/type of relocation to apply *) + ; elf64_ra_addend : Int64.t (** Addend used to compute value to be stored *) + } + +(** [elf64_relocation_a_compare r1 r2] is an ordering comparison function for + * relocation with addend records suitable for constructing sets, finite map + * and other ordered data structures. + * NB: we exclusively use elf64_relocation_a in range tags, regardless of what + * file/reloc the info came from, so only this one needs an Ord instance. + *) +(*val elf64_relocation_a_compare : elf64_relocation_a -> elf64_relocation_a -> + ordering*) +let elf64_relocation_a_compare ent1 ent2:int= + (tripleCompare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare (Ml_bindings.nat_big_num_of_uint64 ent1.elf64_ra_offset, Ml_bindings.nat_big_num_of_uint64 ent1.elf64_ra_info, + Nat_big_num.of_int64 ent1.elf64_ra_addend) + (Ml_bindings.nat_big_num_of_uint64 ent2.elf64_ra_offset, Ml_bindings.nat_big_num_of_uint64 ent2.elf64_ra_info, + Nat_big_num.of_int64 ent2.elf64_ra_addend)) + +let instance_Basic_classes_Ord_Elf_relocation_elf64_relocation_a_dict:(elf64_relocation_a)ord_class= ({ + + compare_method = elf64_relocation_a_compare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf64_relocation_a_compare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf64_relocation_a_compare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf64_relocation_a_compare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf64_relocation_a_compare f1 f2)(Pset.from_list compare [1; 0])))}) + +(** Extracting useful information *) + +(** [extract_elf32_relocation_r_sym w] computes the symbol table index associated with + * an ELF32 relocation(a) entry. + * [w] here is the [r_info] member of the [elf32_relocation(a)] type. + *) +(*val extract_elf32_relocation_r_sym : elf32_word -> natural*) +let extract_elf32_relocation_r_sym w:Nat_big_num.num= + (Nat_big_num.of_string (Uint32.to_string (Uint32.shift_right w( 8)))) + +(** [extract_elf64_relocation_r_sym w] computes the symbol table index associated with + * an ELF64 relocation(a) entry. + * [w] here is the [r_info] member of the [elf64_relocation(a)] type. + *) +(*val extract_elf64_relocation_r_sym : elf64_xword -> natural*) +let extract_elf64_relocation_r_sym w:Nat_big_num.num= + (Ml_bindings.nat_big_num_of_uint64 (Uint64.shift_right w( 32))) + +(** [extract_elf32_relocation_r_type w] computes the symbol type associated with an ELF32 + * relocation(a) entry. + * [w] here is the [r_info] member of the [elf32_relocation(a)] type. + *) +(*val extract_elf32_relocation_r_type : elf32_word -> natural*) +let extract_elf32_relocation_r_type w:Nat_big_num.num= (Nat_big_num.modulus + (Nat_big_num.of_string (Uint32.to_string w))(Nat_big_num.of_int 256)) + +(** [extract_elf64_relocation_r_type w] computes the symbol type associated with an ELF64 + * relocation(a) entry. + * [w] here is the [r_info] member of the [elf64_relocation(a)] type. + *) +(*val extract_elf64_relocation_r_type : elf64_xword -> natural*) +let extract_elf64_relocation_r_type w:Nat_big_num.num= + (let magic = (Nat_big_num.sub_nat ( Nat_big_num.mul(Nat_big_num.of_int 65536)(Nat_big_num.of_int 65536))(Nat_big_num.of_int 1)) in (* 0xffffffffL *) + Ml_bindings.nat_big_num_of_uint64 (Uint64.logand w (Uint64.of_string (Nat_big_num.to_string magic)))) + +(* Accessors *) + +(*val get_elf32_relocation_r_sym : elf32_relocation -> natural*) +let get_elf32_relocation_r_sym r:Nat_big_num.num= + (extract_elf32_relocation_r_sym r.elf32_r_info) + +(*val get_elf32_relocation_a_sym : elf32_relocation_a -> natural*) +let get_elf32_relocation_a_sym r:Nat_big_num.num= + (extract_elf32_relocation_r_sym r.elf32_ra_info) + +(*val get_elf64_relocation_sym : elf64_relocation -> natural*) +let get_elf64_relocation_sym r:Nat_big_num.num= + (extract_elf64_relocation_r_sym r.elf64_r_info) + +(*val get_elf64_relocation_a_sym : elf64_relocation_a -> natural*) +let get_elf64_relocation_a_sym r:Nat_big_num.num= + (extract_elf64_relocation_r_sym r.elf64_ra_info) + +(*val get_elf32_relocation_type : elf32_relocation -> natural*) +let get_elf32_relocation_type r:Nat_big_num.num= + (extract_elf32_relocation_r_type r.elf32_r_info) + +(*val get_elf32_relocation_a_type : elf32_relocation_a -> natural*) +let get_elf32_relocation_a_type r:Nat_big_num.num= + (extract_elf32_relocation_r_type r.elf32_ra_info) + +(*val get_elf64_relocation_type : elf64_relocation -> natural*) +let get_elf64_relocation_type r:Nat_big_num.num= + (extract_elf64_relocation_r_type r.elf64_r_info) + +(*val get_elf64_relocation_a_type : elf64_relocation_a -> natural*) +let get_elf64_relocation_a_type r:Nat_big_num.num= + (extract_elf64_relocation_r_type r.elf64_ra_info) + + +(** Reading relocation entries *) + +(** [read_elf32_relocation ed bs0] parses an [elf32_relocation] record from + * byte sequence [bs0] assuming endianness [ed]. The suffix of [bs0] remaining + * after parsing is also returned. + * Fails if the relocation record cannot be parsed. + *) +(*val read_elf32_relocation : endianness -> byte_sequence -> + error (elf32_relocation * byte_sequence)*) +let read_elf32_relocation endian bs:(elf32_relocation*byte_sequence)error= + (read_elf32_addr endian bs >>= (fun (r_offset, bs) -> + read_elf32_word endian bs >>= (fun (r_info, bs) -> + return ({ elf32_r_offset = r_offset; elf32_r_info = r_info }, bs)))) + +(** [read_elf64_relocation ed bs0] parses an [elf64_relocation] record from + * byte sequence [bs0] assuming endianness [ed]. The suffix of [bs0] remaining + * after parsing is also returned. + * Fails if the relocation record cannot be parsed. + *) +(*val read_elf64_relocation : endianness -> byte_sequence -> + error (elf64_relocation * byte_sequence)*) +let read_elf64_relocation endian bs:(elf64_relocation*byte_sequence)error= + (read_elf64_addr endian bs >>= (fun (r_offset, bs) -> + read_elf64_xword endian bs >>= (fun (r_info, bs) -> + return ({ elf64_r_offset = r_offset; elf64_r_info = r_info }, bs)))) + +(** [read_elf32_relocation_a ed bs0] parses an [elf32_relocation_a] record from + * byte sequence [bs0] assuming endianness [ed]. The suffix of [bs0] remaining + * after parsing is also returned. + * Fails if the relocation record cannot be parsed. + *) +(*val read_elf32_relocation_a : endianness -> byte_sequence -> + error (elf32_relocation_a * byte_sequence)*) +let read_elf32_relocation_a endian bs:(elf32_relocation_a*byte_sequence)error= + (read_elf32_addr endian bs >>= (fun (r_offset, bs) -> + read_elf32_word endian bs >>= (fun (r_info, bs) -> + read_elf32_sword endian bs >>= (fun (r_addend, bs) -> + return ({ elf32_ra_offset = r_offset; elf32_ra_info = r_info; + elf32_ra_addend = r_addend }, bs))))) + +(** [read_elf64_relocation_a ed bs0] parses an [elf64_relocation_a] record from + * byte sequence [bs0] assuming endianness [ed]. The suffix of [bs0] remaining + * after parsing is also returned. + * Fails if the relocation record cannot be parsed. + *) +(*val read_elf64_relocation_a : endianness -> byte_sequence -> error (elf64_relocation_a * byte_sequence)*) +let read_elf64_relocation_a endian bs:(elf64_relocation_a*byte_sequence)error= + (read_elf64_addr endian bs >>= (fun (r_offset, bs) -> + read_elf64_xword endian bs >>= (fun (r_info, bs) -> + read_elf64_sxword endian bs >>= (fun (r_addend, bs) -> + return ({ elf64_ra_offset = r_offset; elf64_ra_info = r_info; + elf64_ra_addend = r_addend }, bs))))) + +(** [read_elf32_relocation_section' ed bs0] parses a list of [elf32_relocation] + * records from byte sequence [bs0], which is assumed to have the exact size + * required, assuming endianness [ed]. + * Fails if any of the records cannot be parsed. + *) +(*val read_elf32_relocation_section' : endianness -> byte_sequence -> + error (list elf32_relocation)*) +let rec read_elf32_relocation_section' endian bs0:((elf32_relocation)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf32_relocation endian bs0 >>= (fun (entry, bs1) -> + read_elf32_relocation_section' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf64_relocation_section' ed bs0] parses a list of [elf64_relocation] + * records from byte sequence [bs0], which is assumed to have the exact size + * required, assuming endianness [ed]. + * Fails if any of the records cannot be parsed. + *) +(*val read_elf64_relocation_section' : endianness -> byte_sequence -> + error (list elf64_relocation)*) +let rec read_elf64_relocation_section' endian bs0:((elf64_relocation)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf64_relocation endian bs0 >>= (fun (entry, bs1) -> + read_elf64_relocation_section' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf32_relocation_a_section' ed bs0] parses a list of [elf32_relocation_a] + * records from byte sequence [bs0], which is assumed to have the exact size + * required, assuming endianness [ed]. + * Fails if any of the records cannot be parsed. + *) +(*val read_elf32_relocation_a_section' : endianness -> byte_sequence -> + error (list elf32_relocation_a)*) +let rec read_elf32_relocation_a_section' endian bs0:((elf32_relocation_a)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf32_relocation_a endian bs0 >>= (fun (entry, bs1) -> + read_elf32_relocation_a_section' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf64_relocation_a_section' ed bs0] parses a list of [elf64_relocation_a] + * records from byte sequence [bs0], which is assumed to have the exact size + * required, assuming endianness [ed]. + * Fails if any of the records cannot be parsed. + *) +(*val read_elf64_relocation_a_section' : endianness -> byte_sequence -> + error (list elf64_relocation_a)*) +let rec read_elf64_relocation_a_section' endian bs0:((elf64_relocation_a)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf64_relocation_a endian bs0 >>= (fun (entry, bs1) -> + read_elf64_relocation_a_section' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf32_relocation_section sz ed bs0] reads in a list of [elf32_relocation] + * records from a prefix of [bs0] of size [sz] assuming endianness [ed]. The + * suffix of [bs0] remaining after parsing is also returned. + * Fails if any of the records cannot be parsed or if the length of [bs0] is + * less than [sz]. + *) +(*val read_elf32_relocation_section : natural -> endianness -> byte_sequence + -> error (list elf32_relocation * byte_sequence)*) +let read_elf32_relocation_section table_size endian bs0:((elf32_relocation)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf32_relocation_section' endian eat >>= (fun entries -> + return (entries, rest)))) + +(** [read_elf64_relocation_section sz ed bs0] reads in a list of [elf64_relocation] + * records from a prefix of [bs0] of size [sz] assuming endianness [ed]. The + * suffix of [bs0] remaining after parsing is also returned. + * Fails if any of the records cannot be parsed or if the length of [bs0] is + * less than [sz]. + *) +(*val read_elf64_relocation_section : natural -> endianness -> byte_sequence + -> error (list elf64_relocation * byte_sequence)*) +let read_elf64_relocation_section table_size endian bs0:((elf64_relocation)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf64_relocation_section' endian eat >>= (fun entries -> + return (entries, rest)))) + +(** [read_elf32_relocation_a_section sz ed bs0] reads in a list of [elf32_relocation_a] + * records from a prefix of [bs0] of size [sz] assuming endianness [ed]. The + * suffix of [bs0] remaining after parsing is also returned. + * Fails if any of the records cannot be parsed or if the length of [bs0] is + * less than [sz]. + *) +(*val read_elf32_relocation_a_section : natural -> endianness -> byte_sequence -> + error (list elf32_relocation_a * byte_sequence)*) +let read_elf32_relocation_a_section table_size endian bs0:((elf32_relocation_a)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf32_relocation_a_section' endian eat >>= (fun entries -> + return (entries, rest)))) + +(** [read_elf64_relocation_a_section sz ed bs0] reads in a list of [elf64_relocation_a] + * records from a prefix of [bs0] of size [sz] assuming endianness [ed]. The + * suffix of [bs0] remaining after parsing is also returned. + * Fails if any of the records cannot be parsed or if the length of [bs0] is + * less than [sz]. + *) +(*val read_elf64_relocation_a_section : natural -> endianness -> byte_sequence -> + error (list elf64_relocation_a * byte_sequence)*) +let read_elf64_relocation_a_section table_size endian bs0:((elf64_relocation_a)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf64_relocation_a_section' endian eat >>= (fun entries -> + return (entries, rest)))) diff --git a/lib/ocaml_rts/linksem/elf_section_header_table.ml b/lib/ocaml_rts/linksem/elf_section_header_table.ml new file mode 100644 index 00000000..b750c103 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_section_header_table.ml @@ -0,0 +1,1187 @@ +(*Generated by Lem from elf_section_header_table.lem.*) +(** [elf_section_header_table] provides types, functions and other definitions + * for working with section header tables and their entries. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_function +open Lem_list +open Lem_map +open Lem_maybe +open Lem_num +open Lem_string + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +open Endianness +open String_table + +open Elf_header +open Elf_types_native_uint +open Elf_program_header_table + +(** Special section indices. *) + +(** See elf_header.lem for shn_undef *) + +(** [shn_loreserve]: this specifies the lower bound of the range of reserved + * indices. + *) +let shn_loreserve : Nat_big_num.num= (Nat_big_num.of_int 65280) (* 0xff00 *) +(** [shn_loproc]: start of the range reserved for processor-specific semantics. + *) +let shn_loproc : Nat_big_num.num= (Nat_big_num.of_int 65280) (* 0xff00 *) +(** [shn_hiproc]: end of the range reserved for processor-specific semantics. + *) +let shn_hiproc : Nat_big_num.num= (Nat_big_num.of_int 65311) (* 0xff1f *) +(** [shn_loos]: start of the range reserved for operating system-specific + * semantics. + *) +let shn_loos : Nat_big_num.num= (Nat_big_num.of_int 65312) (* 0xff20 *) +(** [shn_hios]: end of the range reserved for operating system-specific + * semantics. + *) +let shn_hios : Nat_big_num.num= (Nat_big_num.of_int 65343) (* 0xff3f *) +(** [shn_abs]: specifies the absolute values for the corresponding reference. + * Symbols defined relative to section number [shn_abs] have absolute values + * and are not affected by relocation. + *) +let shn_abs : Nat_big_num.num= (Nat_big_num.of_int 65521) (* 0xfff1 *) +(** [shn_common]: symbols defined relative to this index are common symbols, + * such as unallocated C external variables. + *) +let shn_common : Nat_big_num.num= (Nat_big_num.of_int 65522) (* 0xfff2 *) + +(** See elf_header.lem for shn_xindex. *) + +(** [shn_hireserve]: specifies the upper-bound of reserved values. + *) +let shn_hireserve : Nat_big_num.num= (Nat_big_num.of_int 65535) (* 0xffff *) + +(** [string_of_special_section_index m] produces a string-based representation + * of a section header entry's special section index, [m]. + *) +(*val string_of_special_section_index : natural -> string*) +let string_of_special_section_index i:string= + (if Nat_big_num.equal i shn_undef then + "SHN_UNDEF" + else if Nat_big_num.equal i shn_loreserve then + "SHN_LORESERVE" + else if Nat_big_num.greater_equal i shn_loproc && Nat_big_num.less_equal i shn_hiproc then + "SHN_PROCESSOR_SPECIFIC" + else if Nat_big_num.greater_equal i shn_loos && Nat_big_num.less_equal i shn_hios then + "SHN_OS_SPECIFIC" + else if Nat_big_num.equal i shn_abs then + "SHN_ABS" + else if Nat_big_num.equal i shn_common then + "SHN_COMMON" + else if Nat_big_num.equal i shn_xindex then + "SHN_XINDEX" + else if Nat_big_num.equal i shn_hireserve then + "SHN_HIRESERVE" + else + "SHN UNDEFINED") + +(** Section types. *) + +(** Marks the section header as being inactive. *) +let sht_null : Nat_big_num.num= (Nat_big_num.of_int 0) +(** Section holds information defined by the program. *) +let sht_progbits : Nat_big_num.num= (Nat_big_num.of_int 1) +(** The following two section types hold a symbol table. An object file may only + * have one symbol table of each of the respective types. The symtab provides + * a place for link editing, whereas the dynsym section holds a minimal set of + * dynamic linking symbols + *) +let sht_symtab : Nat_big_num.num= (Nat_big_num.of_int 2) +let sht_dynsym : Nat_big_num.num= (Nat_big_num.of_int 11) +(** Section holds a string table *) +let sht_strtab : Nat_big_num.num= (Nat_big_num.of_int 3) +(** Section holds relocation entries with explicit addends. An object file may + * have multiple section of this type. + *) +let sht_rela : Nat_big_num.num= (Nat_big_num.of_int 4) +(** Section holds a symbol hash table. An object file may only have a single + * hash table. + *) +let sht_hash : Nat_big_num.num= (Nat_big_num.of_int 5) +(** Section holds information for dynamic linking. An object file may only have + * a single dynamic section. + *) +let sht_dynamic : Nat_big_num.num= (Nat_big_num.of_int 6) +(** Section holds information that marks the file in some way. *) +let sht_note : Nat_big_num.num= (Nat_big_num.of_int 7) +(** Section occupies no space in the file but otherwise resembles a progbits + * section. + *) +let sht_nobits : Nat_big_num.num= (Nat_big_num.of_int 8) +(** Section holds relocation entries without explicit addends. An object file + * may have multiple section of this type. + *) +let sht_rel : Nat_big_num.num= (Nat_big_num.of_int 9) +(** Section type is reserved but has an unspecified meaning. *) +let sht_shlib : Nat_big_num.num= (Nat_big_num.of_int 10) +(** Section contains an array of pointers to initialisation functions. Each + * pointer is taken as a parameterless function with a void return type. + *) +let sht_init_array : Nat_big_num.num= (Nat_big_num.of_int 14) +(** Section contains an array of pointers to termination functions. Each + * pointer is taken as a parameterless function with a void return type. + *) +let sht_fini_array : Nat_big_num.num= (Nat_big_num.of_int 15) +(** Section contains an array of pointers to initialisation functions that are + * invoked before all other initialisation functions. Each + * pointer is taken as a parameterless function with a void return type. + *) +let sht_preinit_array : Nat_big_num.num= (Nat_big_num.of_int 16) +(** Section defines a section group, i.e. a set of sections that are related and + * must be treated especially by the linker. May only appear in relocatable + * objects. + *) +let sht_group : Nat_big_num.num= (Nat_big_num.of_int 17) +(** Section is associated with sections of type SHT_SYMTAB and is required if + * any of the section header indices referenced by that symbol table contains + * the escape value SHN_XINDEX. + * + * FIXME: Lem bug as [int] type used throughout Lem codebase, rather than + * [BigInt.t], so Lem chokes on these large constants below, hence the weird + * way in which they are written. + *) +let sht_symtab_shndx : Nat_big_num.num= (Nat_big_num.of_int 18) + +(** The following ranges are reserved solely for OS-, processor- and user- + * specific semantics, respectively. + *) +let sht_loos : Nat_big_num.num= (Nat_big_num.mul (Nat_big_num.mul (Nat_big_num.mul(Nat_big_num.of_int 3)(Nat_big_num.of_int 1024))(Nat_big_num.of_int 1024))(Nat_big_num.of_int 512)) (* 1610612736 (* 0x60000000 *) *) +let sht_hios : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 469762047)(Nat_big_num.of_int 4))(Nat_big_num.of_int 3)) (* 1879048191 (* 0x6fffffff *) *) +let sht_loproc : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 469762048)(Nat_big_num.of_int 4)) (* 1879048192 (* 0x70000000 *) *) +let sht_hiproc : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 536870911)(Nat_big_num.of_int 4))(Nat_big_num.of_int 3)) (* 2147483647 (* 0x7fffffff *) *) +let sht_louser : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 536870912)(Nat_big_num.of_int 4)) (* 2147483648 (* 0x80000000 *) *) +let sht_hiuser : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 603979775)(Nat_big_num.of_int 4))(Nat_big_num.of_int 3)) (* 2415919103 (* 0x8fffffff *) *) + +(** [string_of_section_type os proc user i] produces a string-based representation + * of section type [i]. Some section types are defined by ABI-specific supplements + * in reserved ranges, in which case the functions [os], [proc] and [user] are + * used to produce the string. + *) +(*val string_of_section_type : (natural -> string) -> (natural -> string) -> + (natural -> string) -> natural -> string*) +let string_of_section_type os proc user i:string= + (if Nat_big_num.equal i sht_null then + "NULL" + else if Nat_big_num.equal i sht_progbits then + "PROGBITS" + else if Nat_big_num.equal i sht_symtab then + "SYMTAB" + else if Nat_big_num.equal i sht_strtab then + "STRTAB" + else if Nat_big_num.equal i sht_rela then + "RELA" + else if Nat_big_num.equal i sht_hash then + "HASH" + else if Nat_big_num.equal i sht_dynamic then + "DYNAMIC" + else if Nat_big_num.equal i sht_note then + "NOTE" + else if Nat_big_num.equal i sht_nobits then + "NOBITS" + else if Nat_big_num.equal i sht_rel then + "REL" + else if Nat_big_num.equal i sht_shlib then + "SHLIB" + else if Nat_big_num.equal i sht_dynsym then + "DYNSYM" + else if Nat_big_num.equal i sht_init_array then + "INIT_ARRAY" + else if Nat_big_num.equal i sht_fini_array then + "FINI_ARRAY" + else if Nat_big_num.equal i sht_preinit_array then + "PREINIT_ARRAY" + else if Nat_big_num.equal i sht_group then + "GROUP" + else if Nat_big_num.equal i sht_symtab_shndx then + "SYMTAB_SHNDX" + else if Nat_big_num.greater_equal i sht_loos && Nat_big_num.less_equal i sht_hios then + os i + else if Nat_big_num.greater_equal i sht_loproc && Nat_big_num.less_equal i sht_hiproc then + proc i + else if Nat_big_num.greater_equal i sht_louser && Nat_big_num.less_equal i sht_hiuser then + user i + else + "Undefined or invalid section type") + +(** Section flag numeric values. *) + +(** The section contains data that should be writable during program execution. + *) +let shf_write : Nat_big_num.num= (Nat_big_num.of_int 1) +(** The section occupies memory during program execution. + *) +let shf_alloc : Nat_big_num.num= (Nat_big_num.of_int 2) +(** The section contains executable instructions. + *) +let shf_execinstr : Nat_big_num.num= (Nat_big_num.of_int 4) +(** The data in the section may be merged to reduce duplication. Each section + * is compared based on name, type and flags set with sections with identical + * values at run time being mergeable. + *) +let shf_merge : Nat_big_num.num= (Nat_big_num.of_int 16) +(** The section contains null-terminated character strings. + *) +let shf_strings : Nat_big_num.num= (Nat_big_num.of_int 32) +(** The [info] field of this section header contains a section header table + * index. + *) +let shf_info_link : Nat_big_num.num= (Nat_big_num.of_int 64) +(** Adds special link ordering for link editors. + *) +let shf_link_order : Nat_big_num.num= (Nat_big_num.of_int 128) +(** This section requires special OS-specific processing beyond the standard + * link rules. + *) +let shf_os_nonconforming : Nat_big_num.num= (Nat_big_num.of_int 256) +(** This section is a member (potentially the only member) of a link group. + *) +let shf_group : Nat_big_num.num= (Nat_big_num.of_int 512) +(** This section contains Thread Local Storage (TLS) meaning that each thread of + * execution has its own instance of this data. + *) +let shf_tls : Nat_big_num.num= (Nat_big_num.of_int 1024) +(** This section contains compressed data. Compressed data may not be marked as + * allocatable. + *) +let shf_compressed : Nat_big_num.num= (Nat_big_num.of_int 2048) +(** All bits included in these masks are reserved for OS and processor specific + * semantics respectively. + *) +let shf_mask_os : Nat_big_num.num= (Nat_big_num.of_int 267386880) (* 0x0ff00000 *) +let shf_mask_proc : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 1006632960)) (* 0xf0000000 *) + +(** [string_of_section_flags os proc f] produces a string based representation + * of section flag [f]. Some section flags are defined by the ABI and are in + * reserved ranges, in which case the flag string is produced by functions + * [os] and [proc]. + * TODO: add more as validation tests require them. + *) +(*val string_of_section_flags : (natural -> string) -> (natural -> string) -> + natural -> string*) +let string_of_section_flags os proc f:string= + (if Nat_big_num.equal f shf_write then + "W" + else if Nat_big_num.equal f shf_alloc then + " A" + else if Nat_big_num.equal f shf_execinstr then + " X" + else if Nat_big_num.equal f (Nat_big_num.add shf_alloc shf_execinstr) then + " AX" + else if Nat_big_num.equal f (Nat_big_num.add shf_write shf_alloc) then + " WA" + else if Nat_big_num.equal f shf_merge then + " M " + else if Nat_big_num.equal f (Nat_big_num.add shf_merge shf_alloc) then + " AM" + else if Nat_big_num.equal f (Nat_big_num.add (Nat_big_num.add shf_merge shf_alloc) shf_strings) then + "AMS" + else if Nat_big_num.equal f (Nat_big_num.add (Nat_big_num.add shf_alloc shf_execinstr) shf_group) then + "AXG" + else if Nat_big_num.equal f shf_strings then + " S" + else if Nat_big_num.equal f (Nat_big_num.add shf_merge shf_strings) then + " MS" + else if Nat_big_num.equal f shf_tls then + " T" + else if Nat_big_num.equal f (Nat_big_num.add shf_tls shf_alloc) then + " AT" + else if Nat_big_num.equal f (Nat_big_num.add (Nat_big_num.add shf_write shf_alloc) shf_tls) then + "WAT" + else if Nat_big_num.equal f shf_info_link then + " I" + else if Nat_big_num.equal f (Nat_big_num.add shf_alloc shf_info_link) then + " AI" + else + " ") + +(** Section compression. *) + +(** Type [elf32_compression_header] provides information about the compression and + * decompression of compressed sections. All compressed sections on ELF32 begin + * with an [elf32_compression_header] entry. + *) +type elf32_compression_header = + { elf32_chdr_type : Uint32.uint32 (** Specifies the compression algorithm *) + ; elf32_chdr_size : Uint32.uint32 (** Size in bytes of the uncompressed data *) + ; elf32_chdr_addralign : Uint32.uint32 (** Specifies the required alignment of the uncompressed data *) + } + +(** Type [elf64_compression_header] provides information about the compression and + * decompression of compressed sections. All compressed sections on ELF64 begin + * with an [elf64_compression_header] entry. + *) +type elf64_compression_header = + { elf64_chdr_type : Uint32.uint32 (** Specified the compression algorithm *) + ; elf64_chdr_reserved : Uint32.uint32 (** Reserved. *) + ; elf64_chdr_size : Uint64.uint64 (** Size in bytes of the uncompressed data *) + ; elf64_chdr_addralign : Uint64.uint64 (** Specifies the required alignment of the uncompressed data *) + } + +(** This section is compressed with the ZLIB algorithm. The compressed data begins + * at the first byte immediately following the end of the compression header. + *) +let elfcompress_zlib : Nat_big_num.num= (Nat_big_num.of_int 1) + +(** Values in these ranges are reserved for OS-specific semantics. + *) +let elfcompress_loos : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 402653184)) (* 0x60000000 *) +let elfcompress_hios : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524095))(Nat_big_num.of_int 1)) (* 0x6fffffff *) + +(** Values in these ranges are reserved for processor-specific semantics. + *) +let elfcompress_loproc : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 469762048)) (* 0x70000000 *) +let elfcompress_hiproc : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 1073741823))(Nat_big_num.of_int 1)) (* 0x7fffffff *) + +(** [read_elf32_compression_header ed bs0] reads an [elf32_compression_header] + * entry from byte sequence [bs0], interpreting [bs0] with endianness [ed]. + * Also returns the suffix of [bs0] after reading in the compression header. + * Fails if the header cannot be read. + *) +(*val read_elf32_compression_header : endianness -> byte_sequence -> + error (elf32_compression_header * byte_sequence)*) +let read_elf32_compression_header ed bs0:(elf32_compression_header*byte_sequence)error= + (read_elf32_word ed bs0 >>= (fun (typ, bs1) -> + read_elf32_word ed bs1 >>= (fun (siz, bs2) -> + read_elf32_word ed bs2 >>= (fun (ali, bs3) -> + return ({ elf32_chdr_type = typ; elf32_chdr_size = siz; + elf32_chdr_addralign = ali }, bs3))))) + +(** [read_elf64_compression_header ed bs0] reads an [elf64_compression_header] + * entry from byte sequence [bs0], interpreting [bs0] with endianness [ed]. + * Also returns the suffix of [bs0] after reading in the compression header. + * Fails if the header cannot be read. + *) +(*val read_elf64_compression_header : endianness -> byte_sequence -> + error (elf64_compression_header * byte_sequence)*) +let read_elf64_compression_header ed bs0:(elf64_compression_header*byte_sequence)error= + (read_elf64_word ed bs0 >>= (fun (typ, bs1) -> + read_elf64_word ed bs1 >>= (fun (res, bs2) -> + read_elf64_xword ed bs2 >>= (fun (siz, bs3) -> + read_elf64_xword ed bs3 >>= (fun (ali, bs4) -> + return ({ elf64_chdr_type = typ; elf64_chdr_reserved = res; + elf64_chdr_size = siz; elf64_chdr_addralign = ali }, bs4)))))) + +(** Section header table entry type. *) + +(** [elf32_section_header_table_entry] is the type of entries in the section + * header table in 32-bit ELF files. Each entry in the table details a section + * in the body of the ELF file. + *) +type elf32_section_header_table_entry = + { elf32_sh_name : Uint32.uint32 (** Name of the section *) + ; elf32_sh_type : Uint32.uint32 (** Type of the section and its semantics *) + ; elf32_sh_flags : Uint32.uint32 (** Flags associated with the section *) + ; elf32_sh_addr : Uint32.uint32 (** Address of first byte of section in memory image *) + ; elf32_sh_offset : Uint32.uint32 (** Offset from beginning of file of first byte of section *) + ; elf32_sh_size : Uint32.uint32 (** Section size in bytes *) + ; elf32_sh_link : Uint32.uint32 (** Section header table index link *) + ; elf32_sh_info : Uint32.uint32 (** Extra information, contents depends on type of section *) + ; elf32_sh_addralign : Uint32.uint32 (** Alignment constraints for section *) + ; elf32_sh_entsize : Uint32.uint32 (** Size of each entry in table, if section is one *) + } + +let elf32_null_section_header:elf32_section_header_table_entry= + ({ elf32_sh_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_type = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_flags = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_addr = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_offset = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_size = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_link = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_info = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_addralign = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf32_sh_entsize = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + +(** [compare_elf32_section_header_table_entry ent1 ent2] is an ordering comparison + * function on section header table entries suitable for use in constructing + * sets, finite maps and other ordered data types. + *) +(*val compare_elf32_section_header_table_entry : elf32_section_header_table_entry -> + elf32_section_header_table_entry -> ordering*) +let compare_elf32_section_header_table_entry h1 h2:int= + (lexicographic_compare Nat_big_num.compare + [Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_name); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_type); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_flags); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_addr); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_offset); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_size); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_link); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_info); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_addralign); + Nat_big_num.of_string (Uint32.to_string h1.elf32_sh_entsize)] + [Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_name); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_type); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_flags); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_addr); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_offset); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_size); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_link); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_info); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_addralign); + Nat_big_num.of_string (Uint32.to_string h2.elf32_sh_entsize)]) + +let instance_Basic_classes_Ord_Elf_section_header_table_elf32_section_header_table_entry_dict:(elf32_section_header_table_entry)ord_class= ({ + + compare_method = compare_elf32_section_header_table_entry; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf32_section_header_table_entry f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf32_section_header_table_entry f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf32_section_header_table_entry f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf32_section_header_table_entry f1 f2)(Pset.from_list compare [1; 0])))}) + +(** [elf64_section_header_table_entry] is the type of entries in the section + * header table in 64-bit ELF files. Each entry in the table details a section + * in the body of the ELF file. + *) +type elf64_section_header_table_entry = + { elf64_sh_name : Uint32.uint32 (** Name of the section *) + ; elf64_sh_type : Uint32.uint32 (** Type of the section and its semantics *) + ; elf64_sh_flags : Uint64.uint64 (** Flags associated with the section *) + ; elf64_sh_addr : Uint64.uint64 (** Address of first byte of section in memory image *) + ; elf64_sh_offset : Uint64.uint64 (** Offset from beginning of file of first byte of section *) + ; elf64_sh_size : Uint64.uint64 (** Section size in bytes *) + ; elf64_sh_link : Uint32.uint32 (** Section header table index link *) + ; elf64_sh_info : Uint32.uint32 (** Extra information, contents depends on type of section *) + ; elf64_sh_addralign : Uint64.uint64 (** Alignment constraints for section *) + ; elf64_sh_entsize : Uint64.uint64 (** Size of each entry in table, if section is one *) + } + +let elf64_null_section_header:elf64_section_header_table_entry= + ({ elf64_sh_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_type = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_flags = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_addr = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_offset = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_size = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_link = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_info = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_addralign = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_sh_entsize = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + +(** [compare_elf64_section_header_table_entry ent1 ent2] is an ordering comparison + * function on section header table entries suitable for use in constructing + * sets, finite maps and other ordered data types. + *) +(*val compare_elf64_section_header_table_entry : elf64_section_header_table_entry -> + elf64_section_header_table_entry -> ordering*) +let compare_elf64_section_header_table_entry h1 h2:int= + (lexicographic_compare Nat_big_num.compare + [Nat_big_num.of_string (Uint32.to_string h1.elf64_sh_name); + Nat_big_num.of_string (Uint32.to_string h1.elf64_sh_type); + Ml_bindings.nat_big_num_of_uint64 h1.elf64_sh_flags; + Ml_bindings.nat_big_num_of_uint64 h1.elf64_sh_addr; + Nat_big_num.of_string (Uint64.to_string h1.elf64_sh_offset); + Ml_bindings.nat_big_num_of_uint64 h1.elf64_sh_size; + Nat_big_num.of_string (Uint32.to_string h1.elf64_sh_link); + Nat_big_num.of_string (Uint32.to_string h1.elf64_sh_info); + Ml_bindings.nat_big_num_of_uint64 h1.elf64_sh_addralign; + Ml_bindings.nat_big_num_of_uint64 h1.elf64_sh_entsize] + [Nat_big_num.of_string (Uint32.to_string h2.elf64_sh_name); + Nat_big_num.of_string (Uint32.to_string h2.elf64_sh_type); + Ml_bindings.nat_big_num_of_uint64 h2.elf64_sh_flags; + Ml_bindings.nat_big_num_of_uint64 h2.elf64_sh_addr; + Nat_big_num.of_string (Uint64.to_string h2.elf64_sh_offset); + Ml_bindings.nat_big_num_of_uint64 h2.elf64_sh_size; + Nat_big_num.of_string (Uint32.to_string h2.elf64_sh_link); + Nat_big_num.of_string (Uint32.to_string h2.elf64_sh_info); + Ml_bindings.nat_big_num_of_uint64 h2.elf64_sh_addralign; + Ml_bindings.nat_big_num_of_uint64 h2.elf64_sh_entsize]) + +let instance_Basic_classes_Ord_Elf_section_header_table_elf64_section_header_table_entry_dict:(elf64_section_header_table_entry)ord_class= ({ + + compare_method = compare_elf64_section_header_table_entry; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_section_header_table_entry f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf64_section_header_table_entry f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_elf64_section_header_table_entry f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (compare_elf64_section_header_table_entry f1 f2)(Pset.from_list compare [1; 0])))}) + +(** Section header table type *) + +(** Type [elf32_section_header_table] represents a section header table for 32-bit + * ELF files. A section header table is an array (implemented as a list, here) + * of section header table entries. + *) +type elf32_section_header_table = elf32_section_header_table_entry + list + +(** Type [elf64_section_header_table] represents a section header table for 64-bit + * ELF files. A section header table is an array (implemented as a list, here) + * of section header table entries. + *) +type elf64_section_header_table = elf64_section_header_table_entry + list + +(** Parsing and blitting *) + +(** [bytes_of_elf32_section_header_table_entry ed ent] blits [ent] to a byte sequence + * assuming endianness [ed]. + *) +(*val bytes_of_elf32_section_header_table_entry : endianness -> + elf32_section_header_table_entry -> byte_sequence*) +let bytes_of_elf32_section_header_table_entry endian entry:byte_sequence= + (Byte_sequence.from_byte_lists [ + bytes_of_elf32_word endian entry.elf32_sh_name + ; bytes_of_elf32_word endian entry.elf32_sh_type + ; bytes_of_elf32_word endian entry.elf32_sh_flags + ; bytes_of_elf32_addr endian entry.elf32_sh_addr + ; bytes_of_elf32_off endian entry.elf32_sh_offset + ; bytes_of_elf32_word endian entry.elf32_sh_size + ; bytes_of_elf32_word endian entry.elf32_sh_link + ; bytes_of_elf32_word endian entry.elf32_sh_info + ; bytes_of_elf32_word endian entry.elf32_sh_addralign + ; bytes_of_elf32_word endian entry.elf32_sh_entsize + ]) + +(** [read_elf32_section_header_table_entry ed bs0] reads a section header table + * entry from [bs0] assuming endianness [ed]. Also returns the suffix of [bs0] + * after parsing. Fails if the entry cannot be read. + *) +(*val read_elf32_section_header_table_entry : endianness -> byte_sequence -> + error (elf32_section_header_table_entry * byte_sequence)*) +let read_elf32_section_header_table_entry endian bs:(elf32_section_header_table_entry*byte_sequence)error= + (read_elf32_word endian bs >>= (fun (sh_name, bs) -> + read_elf32_word endian bs >>= (fun (sh_type, bs) -> + read_elf32_word endian bs >>= (fun (sh_flags, bs) -> + read_elf32_addr endian bs >>= (fun (sh_addr, bs) -> + read_elf32_off endian bs >>= (fun (sh_offset, bs) -> + read_elf32_word endian bs >>= (fun (sh_size, bs) -> + read_elf32_word endian bs >>= (fun (sh_link, bs) -> + read_elf32_word endian bs >>= (fun (sh_info, bs) -> + read_elf32_word endian bs >>= (fun (sh_addralign, bs) -> + read_elf32_word endian bs >>= (fun (sh_entsize, bs) -> + return ({ elf32_sh_name = sh_name; elf32_sh_type = sh_type; + elf32_sh_flags = sh_flags; elf32_sh_addr = sh_addr; + elf32_sh_offset = sh_offset; elf32_sh_size = sh_size; + elf32_sh_link = sh_link; elf32_sh_info = sh_info; + elf32_sh_addralign = sh_addralign; elf32_sh_entsize = sh_entsize }, bs)))))))))))) + +(** [bytes_of_elf64_section_header_table_entry ed ent] blits [ent] to a byte sequence + * assuming endianness [ed]. + *) +(*val bytes_of_elf64_section_header_table_entry : endianness -> + elf64_section_header_table_entry -> byte_sequence*) +let bytes_of_elf64_section_header_table_entry endian entry:byte_sequence= + (Byte_sequence.from_byte_lists [ + bytes_of_elf64_word endian entry.elf64_sh_name + ; bytes_of_elf64_word endian entry.elf64_sh_type + ; bytes_of_elf64_xword endian entry.elf64_sh_flags + ; bytes_of_elf64_addr endian entry.elf64_sh_addr + ; bytes_of_elf64_off endian entry.elf64_sh_offset + ; bytes_of_elf64_xword endian entry.elf64_sh_size + ; bytes_of_elf64_word endian entry.elf64_sh_link + ; bytes_of_elf64_word endian entry.elf64_sh_info + ; bytes_of_elf64_xword endian entry.elf64_sh_addralign + ; bytes_of_elf64_xword endian entry.elf64_sh_entsize + ]) + +(** [read_elf64_section_header_table_entry ed bs0] reads a section header table + * entry from [bs0] assuming endianness [ed]. Also returns the suffix of [bs0] + * after parsing. Fails if the entry cannot be read. + *) +(*val read_elf64_section_header_table_entry : endianness -> byte_sequence -> + error (elf64_section_header_table_entry * byte_sequence)*) +let read_elf64_section_header_table_entry endian bs:(elf64_section_header_table_entry*byte_sequence)error= + (read_elf64_word endian bs >>= (fun (sh_name, bs) -> + read_elf64_word endian bs >>= (fun (sh_type, bs) -> + read_elf64_xword endian bs >>= (fun (sh_flags, bs) -> + read_elf64_addr endian bs >>= (fun (sh_addr, bs) -> + read_elf64_off endian bs >>= (fun (sh_offset, bs) -> + read_elf64_xword endian bs >>= (fun (sh_size, bs) -> + read_elf64_word endian bs >>= (fun (sh_link, bs) -> + read_elf64_word endian bs >>= (fun (sh_info, bs) -> + read_elf64_xword endian bs >>= (fun (sh_addralign, bs) -> + read_elf64_xword endian bs >>= (fun (sh_entsize, bs) -> + return ({ elf64_sh_name = sh_name; elf64_sh_type = sh_type; + elf64_sh_flags = sh_flags; elf64_sh_addr = sh_addr; + elf64_sh_offset = sh_offset; elf64_sh_size = sh_size; + elf64_sh_link = sh_link; elf64_sh_info = sh_info; + elf64_sh_addralign = sh_addralign; elf64_sh_entsize = sh_entsize }, bs)))))))))))) + +(** [bytes_of_elf32_section_header_table ed tbl] blits section header table [tbl] + * to a byte sequence assuming endianness [ed]. + *) +(*val bytes_of_elf32_section_header_table : endianness -> + elf32_section_header_table -> byte_sequence*) +let bytes_of_elf32_section_header_table endian tbl:byte_sequence= + (Byte_sequence.concat0 (Lem_list.map (bytes_of_elf32_section_header_table_entry endian) tbl)) + +(** [bytes_of_elf64_section_header_table ed tbl] blits section header table [tbl] + * to a byte sequence assuming endianness [ed]. + *) +(*val bytes_of_elf64_section_header_table : endianness -> + elf64_section_header_table -> byte_sequence*) +let bytes_of_elf64_section_header_table endian tbl:byte_sequence= + (Byte_sequence.concat0 (Lem_list.map (bytes_of_elf64_section_header_table_entry endian) tbl)) + +(** [read_elf32_section_header_table' ed bs0] parses an ELF32 section header table + * from byte sequence [bs0] assuming endianness [ed]. Assumes [bs0] is of the + * exact length required to parse the entire table. + * Fails if any of the section header table entries cannot be parsed. + *) +(*val read_elf32_section_header_table' : endianness -> byte_sequence -> + error elf32_section_header_table*) +let rec read_elf32_section_header_table' endian bs0:((elf32_section_header_table_entry)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf32_section_header_table_entry endian bs0 >>= (fun (entry, bs1) -> + read_elf32_section_header_table' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf64_section_header_table' ed bs0] parses an ELF64 section header table + * from byte sequence [bs0] assuming endianness [ed]. Assumes [bs0] is of the + * exact length required to parse the entire table. + * Fails if any of the section header table entries cannot be parsed. + *) +(*val read_elf64_section_header_table' : endianness -> byte_sequence -> + error elf64_section_header_table*) +let rec read_elf64_section_header_table' endian bs0:((elf64_section_header_table_entry)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf64_section_header_table_entry endian bs0 >>= (fun (entry, bs1) -> + read_elf64_section_header_table' endian bs1 >>= (fun tail -> + return (entry::tail)))) + +(** [read_elf32_section_header_table sz ed bs0] parses an ELF32 section header + * table from a [sz] sized prefix of byte sequence [bs0] assuming endianness + * [ed]. The suffix of [bs0] remaining after parsing is also returned. + * Fails if any of the section header entries cannot be parsed or if [sz] is + * greater than the length of [bs0]. + *) +(*val read_elf32_section_header_table : natural -> endianness -> byte_sequence -> + error (elf32_section_header_table * byte_sequence)*) +let read_elf32_section_header_table table_size endian bs0:((elf32_section_header_table_entry)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf32_section_header_table' endian eat >>= (fun entries -> + return (entries, rest)))) + + +(** [read_elf64_section_header_table sz ed bs0] parses an ELF64 section header + * table from a [sz] sized prefix of byte sequence [bs0] assuming endianness + * [ed]. The suffix of [bs0] remaining after parsing is also returned. + * Fails if any of the section header entries cannot be parsed or if [sz] is + * greater than the length of [bs0]. + *) +(*val read_elf64_section_header_table : natural -> endianness -> byte_sequence -> + error (elf64_section_header_table * byte_sequence)*) +let read_elf64_section_header_table table_size endian bs0:((elf64_section_header_table_entry)list*byte_sequence)error= + (partition0 table_size bs0 >>= (fun (eat, rest) -> + read_elf64_section_header_table' endian eat >>= (fun entries -> + return (entries, rest)))) + + +(** Correctness criteria *) + +(** TODO: what is going on here? *) +(*val elf32_size_correct : elf32_section_header_table_entry -> + elf32_section_header_table -> bool*) +let elf32_size_correct hdr tbl:bool= + (let m = (Nat_big_num.of_string (Uint32.to_string hdr.elf32_sh_size)) in + if Nat_big_num.equal m(Nat_big_num.of_int 0) then + true + else Nat_big_num.equal + m (Nat_big_num.of_int (List.length tbl))) + + +(** TODO: what is going on here? *) +(*val elf64_size_correct : elf64_section_header_table_entry -> + elf64_section_header_table -> bool*) +let elf64_size_correct hdr tbl:bool= + (let m = (Ml_bindings.nat_big_num_of_uint64 hdr.elf64_sh_size) in + if Nat_big_num.equal m(Nat_big_num.of_int 0) then + true + else Nat_big_num.equal + m (Nat_big_num.of_int (List.length tbl))) + + +(** [is_elf32_addr_addralign_correct ent] checks whether an internal address + * alignment constraint is met on section header table [ent]. + * TODO: needs tweaking to add in power-of-two constraint, too. + *) +(*val is_elf32_addr_addralign_correct : elf32_section_header_table_entry -> bool*) +let is_elf32_addr_addralign_correct ent:bool= + (let align = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_addralign)) in + let addr = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_addr)) in + if Nat_big_num.equal (Nat_big_num.modulus addr align)(Nat_big_num.of_int 0) then Nat_big_num.equal + align(Nat_big_num.of_int 0) || Nat_big_num.equal align(Nat_big_num.of_int 1) (* TODO: or a power of two *) + else + false) + +(** [is_elf64_addr_addralign_correct ent] checks whether an internal address + * alignment constraint is met on section header table [ent]. + * TODO: needs tweaking to add in power-of-two constraint, too. + *) +(*val is_elf64_addr_addralign_correct : elf64_section_header_table_entry -> bool*) +let is_elf64_addr_addralign_correct ent:bool= + (let align = (Ml_bindings.nat_big_num_of_uint64 ent.elf64_sh_addralign) in + let addr = (Ml_bindings.nat_big_num_of_uint64 ent.elf64_sh_addr) in + if Nat_big_num.equal (Nat_big_num.modulus addr align)(Nat_big_num.of_int 0) then Nat_big_num.equal + align(Nat_big_num.of_int 0) || Nat_big_num.equal align(Nat_big_num.of_int 1) (* TODO: or a power of two *) + else + false) + +(** [is_valid_elf32_section_header_table sht] checks whether all entries of + * section header table [sht] are valid. + *) +(*val is_valid_elf32_section_header_table : elf32_section_header_table -> bool*) +let is_valid_elf32_section_header_table tbl:bool= + ((match tbl with + | [] -> true + | x::xs -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_name))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_type)) sht_null && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_flags))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_addr))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_offset))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_info))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_addralign))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf32_sh_entsize))(Nat_big_num.of_int 0) && + elf32_size_correct x tbl))))))) + (* XXX: more correctness criteria in time *) + )) + +(** [is_valid_elf64_section_header_table sht] checks whether all entries of + * section header table [sht] are valid. + *) +(*val is_valid_elf64_section_header_table : elf64_section_header_table -> bool*) +let is_valid_elf64_section_header_table tbl:bool= + ((match tbl with + | [] -> true + | x::xs -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf64_sh_name))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf64_sh_type)) sht_null && (Nat_big_num.equal +(Ml_bindings.nat_big_num_of_uint64 x.elf64_sh_flags)(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Ml_bindings.nat_big_num_of_uint64 x.elf64_sh_addr)(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint64.to_string x.elf64_sh_offset))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string x.elf64_sh_info))(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Ml_bindings.nat_big_num_of_uint64 x.elf64_sh_addralign)(Nat_big_num.of_int 0) && (Nat_big_num.equal +(Ml_bindings.nat_big_num_of_uint64 x.elf64_sh_entsize)(Nat_big_num.of_int 0) && + elf64_size_correct x tbl))))))) + (* XXX: more correctness criteria in time *) + )) + +(** Pretty printing *) + +(** The [sht_print_bundle] type is used to tidy up other type signatures. Some of the + * top-level string_of_ functions require six or more functions passed to them, + * which quickly gets out of hand. This type is used to reduce that complexity. + * The first component of the type is an OS specific print function, the second is + * a processor specific print function. + *) +type sht_print_bundle = + (Nat_big_num.num -> string) * (Nat_big_num.num -> string) * (Nat_big_num.num -> string) + +(** [string_of_elf32_section_header_table_entry sht ent] produces a string + * representation of section header table entry [ent] using [sht], a + * [sht_print_bundle]. + * OCaml specific definition. + *) +(*val string_of_elf32_section_header_table_entry : sht_print_bundle -> + elf32_section_header_table_entry -> string*) +let string_of_elf32_section_header_table_entry (os, proc, user) entry:string= + (unlines [ +("\t" ^ ("Name: " ^ Uint32.to_string entry.elf32_sh_name)) + ; ("\t" ^ ("Type: " ^ string_of_section_type os proc user (Nat_big_num.of_string (Uint32.to_string entry.elf32_sh_type)))) + ; ("\t" ^ ("Flags: " ^ Uint32.to_string entry.elf32_sh_flags)) + ; ("\t" ^ ("Address: " ^ Uint32.to_string entry.elf32_sh_addr)) + ; ("\t" ^ ("Size: " ^ Uint32.to_string entry.elf32_sh_size)) + ]) + +(** [string_of_elf64_section_header_table_entry sht ent] produces a string + * representation of section header table entry [ent] using [sht], a + * [sht_print_bundle]. + * OCaml specific definition. + *) +(*val string_of_elf64_section_header_table_entry : sht_print_bundle -> + elf64_section_header_table_entry -> string*) +let string_of_elf64_section_header_table_entry (os, proc, user) entry:string= + (unlines [ +("\t" ^ ("Name: " ^ Uint32.to_string entry.elf64_sh_name)) + ; ("\t" ^ ("Type: " ^ string_of_section_type os proc user (Nat_big_num.of_string (Uint32.to_string entry.elf64_sh_type)))) + ; ("\t" ^ ("Flags: " ^ Uint64.to_string entry.elf64_sh_flags)) + ; ("\t" ^ ("Address: " ^ Uint64.to_string entry.elf64_sh_addr)) + ; ("\t" ^ ("Size: " ^ Uint64.to_string entry.elf64_sh_size)) + ]) + +(** [string_of_elf32_section_header_table_entry' sht stab ent] produces a string + * representation of section header table entry [ent] using [sht] and section + * header string table [stab] to print the name of the section header entry + * correctly. + * OCaml specific definition. + *) +(*val string_of_elf32_section_header_table_entry' : sht_print_bundle -> + string_table -> elf32_section_header_table_entry -> string*) +let string_of_elf32_section_header_table_entry' (os, proc, user) stbl entry:string= + (let name1 = +((match get_string_at (Nat_big_num.of_string (Uint32.to_string entry.elf32_sh_name)) stbl with + | Fail _ -> "Invalid index into string table" + | Success i -> i + )) + in + unlines [ +("\t" ^ ("Name: " ^ name1)) + ; ("\t" ^ ("Type: " ^ string_of_section_type os proc user (Nat_big_num.of_string (Uint32.to_string entry.elf32_sh_type)))) + ; ("\t" ^ ("Flags: " ^ Uint32.to_string entry.elf32_sh_flags)) + ; ("\t" ^ ("Address: " ^ Uint32.to_string entry.elf32_sh_addr)) + ; ("\t" ^ ("Size: " ^ Uint32.to_string entry.elf32_sh_size)) + ]) + +(** [string_of_elf64_section_header_table_entry' sht stab ent] produces a string + * representation of section header table entry [ent] using [sht] and section + * header string table [stab] to print the name of the section header entry + * correctly. + * OCaml specific definition. + *) +(*val string_of_elf64_section_header_table_entry' : sht_print_bundle -> + string_table -> elf64_section_header_table_entry -> string*) +let string_of_elf64_section_header_table_entry' (os, proc, user) stbl entry:string= + (let name1 = +((match get_string_at (Nat_big_num.of_string (Uint32.to_string entry.elf64_sh_name)) stbl with + | Fail _ -> "Invalid index into string table" + | Success i -> i + )) + in + unlines [ +("\t" ^ ("Name: " ^ name1)) + ; ("\t" ^ ("Type: " ^ string_of_section_type os proc user (Nat_big_num.of_string (Uint32.to_string entry.elf64_sh_type)))) + ; ("\t" ^ ("Flags: " ^ Uint64.to_string entry.elf64_sh_flags)) + ; ("\t" ^ ("Address: " ^ Uint64.to_string entry.elf64_sh_addr)) + ; ("\t" ^ ("Size: " ^ Uint64.to_string entry.elf64_sh_size)) + ]) + +(** The following defintions are default printing functions, with no ABI-specific + * functionality, in order to produce a [Show] instance for section header + * table entries. + *) + +(*val string_of_elf32_section_header_table_entry_default : elf32_section_header_table_entry -> string*) +let string_of_elf32_section_header_table_entry_default:elf32_section_header_table_entry ->string= + (string_of_elf32_section_header_table_entry + (((fun y->"*Default OS specific print*")), + ((fun y->"*Default processor specific print*")), + ((fun y->"*Default user specific print*")))) + +let instance_Show_Show_Elf_section_header_table_elf32_section_header_table_entry_dict:(elf32_section_header_table_entry)show_class= ({ + + show_method = string_of_elf32_section_header_table_entry_default}) + +(*val string_of_elf64_section_header_table_entry_default : elf64_section_header_table_entry -> string*) +let string_of_elf64_section_header_table_entry_default:elf64_section_header_table_entry ->string= + (string_of_elf64_section_header_table_entry + (((fun y->"*Default OS specific print*")), + ((fun y->"*Default processor specific print*")), + ((fun y->"*Default user specific print*")))) + +let instance_Show_Show_Elf_section_header_table_elf64_section_header_table_entry_dict:(elf64_section_header_table_entry)show_class= ({ + + show_method = string_of_elf64_section_header_table_entry_default}) + +(*val string_of_elf32_section_header_table : sht_print_bundle -> + elf32_section_header_table -> string*) +let string_of_elf32_section_header_table sht_bdl tbl:string= + (unlines (Lem_list.map (string_of_elf32_section_header_table_entry sht_bdl) tbl)) + +(*val string_of_elf32_section_header_table_default : elf32_section_header_table -> + string*) +let string_of_elf32_section_header_table_default:elf32_section_header_table ->string= + (string_of_elf32_section_header_table + (((fun y->"*Default OS specific print*")), + ((fun y->"*Default processor specific print*")), + ((fun y->"*Default user specific print*")))) + +(*val string_of_elf64_section_header_table : sht_print_bundle -> + elf64_section_header_table -> string*) +let string_of_elf64_section_header_table sht_bdl tbl:string= + (unlines (Lem_list.map (string_of_elf64_section_header_table_entry sht_bdl) tbl)) + +(*val string_of_elf64_section_header_table_default : elf64_section_header_table -> + string*) +let string_of_elf64_section_header_table_default:elf64_section_header_table ->string= + (string_of_elf64_section_header_table + (((fun y->"*Default OS specific print*")), + ((fun y->"*Default processor specific print*")), + ((fun y->"*Default user specific print*")))) + +(*val string_of_elf32_section_header_table' : sht_print_bundle -> string_table -> + elf32_section_header_table -> string*) +let string_of_elf32_section_header_table' sht_bdl stbl tbl:string= + (unlines (Lem_list.map (string_of_elf32_section_header_table_entry' sht_bdl stbl) tbl)) + +(*val string_of_elf64_section_header_table' : sht_print_bundle -> string_table -> + elf64_section_header_table -> string*) +let string_of_elf64_section_header_table' sht_bdl stbl tbl:string= + (unlines (Lem_list.map (string_of_elf64_section_header_table_entry' sht_bdl stbl) tbl)) + +(** Section to segment mappings *) + +(** [elf32_tbss_special shdr seg] implements the ELF_TBSS_SPECIAL macro from readelf: + * + * #define ELF_TBSS_SPECIAL(sec_hdr, segment) \ + * (((sec_hdr)->sh_flags & SHF_TLS) != 0 \ + * && (sec_hdr)->sh_type == SHT_NOBITS \ + * && (segment)->p_type != PT_TLS) + * + * From readelf source code, file [internal.h]. + * + *) +(*val is_elf32_tbss_special : elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let is_elf32_tbss_special sec_hdr segment:bool= (not ((Uint32.logand sec_hdr.elf32_sh_flags (Uint32.of_string (Nat_big_num.to_string shf_tls))) = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)))) && +(( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string sec_hdr.elf32_sh_type)) sht_nobits) && + ( not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string segment.elf32_p_type)) elf_pt_tls)))) + +(** [elf64_tbss_special shdr seg] implements the ELF_TBSS_SPECIAL macro from readelf: + * + * #define ELF_TBSS_SPECIAL(sec_hdr, segment) \ + * (((sec_hdr)->sh_flags & SHF_TLS) != 0 \ + * && (sec_hdr)->sh_type == SHT_NOBITS \ + * && (segment)->p_type != PT_TLS) + * + * From readelf source code, file [internal.h]. + * + *) +(*val is_elf64_tbss_special : elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let is_elf64_tbss_special sec_hdr segment:bool= (not ((Uint64.logand sec_hdr.elf64_sh_flags (Uint64.of_string (Nat_big_num.to_string shf_tls))) = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)))) && +(( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string sec_hdr.elf64_sh_type)) sht_nobits) && + ( not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string segment.elf64_p_type)) elf_pt_tls)))) + +(** [get_elf32_section_to_segment_mapping hdr sht pht isin stbl] computes the + * section to segment mapping for an ELF file using information in the section + * header table [sht], program header table [pht] and file header [hdr]. A + * string table [stbl] is taken to produce the string output. The test whether + * a section lies withing a segment is ABI specific, so [isin] is used to perform + * the test. + *) +(*val get_elf32_section_to_segment_mapping : elf32_header -> elf32_section_header_table -> elf32_program_header_table_entry -> + (elf32_header -> elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool) -> + string_table -> error (list string)*) +let rec get_elf32_section_to_segment_mapping hdr sects pent isin stbl:((string)list)error= + ((match sects with + | [] -> return [] + | x::xs -> + if is_elf32_tbss_special x pent then + get_elf32_section_to_segment_mapping hdr xs pent isin stbl + else if not (isin hdr x pent) then + get_elf32_section_to_segment_mapping hdr xs pent isin stbl + else + let nm = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_name)) in + get_string_at nm stbl >>= (fun str -> + get_elf32_section_to_segment_mapping hdr xs pent isin stbl >>= (fun tl -> + return (str :: tl))) + )) + +(** [get_elf64_section_to_segment_mapping hdr sht pht isin stbl] computes the + * section to segment mapping for an ELF file using information in the section + * header table [sht], program header table [pht] and file header [hdr]. A + * string table [stbl] is taken to produce the string output. The test whether + * a section lies withing a segment is ABI specific, so [isin] is used to perform + * the test. + *) +(*val get_elf64_section_to_segment_mapping : elf64_header -> elf64_section_header_table -> elf64_program_header_table_entry -> + (elf64_header -> elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool) -> + string_table -> error (list string)*) +let rec get_elf64_section_to_segment_mapping hdr sects pent isin stbl:((string)list)error= + ((match sects with + | [] -> return [] + | x::xs -> + if not (isin hdr x pent) then + get_elf64_section_to_segment_mapping hdr xs pent isin stbl + else if is_elf64_tbss_special x pent then + get_elf64_section_to_segment_mapping hdr xs pent isin stbl + else + let nm = (Nat_big_num.of_string (Uint32.to_string x.elf64_sh_name)) in + get_string_at nm stbl >>= (fun str -> + get_elf64_section_to_segment_mapping hdr xs pent isin stbl >>= (fun tl -> + return (str :: tl))) + )) + +(** Section groups *) + +(** This is a COMDAT group and may duplicate other COMDAT groups in other object + * files. + *) +let grp_comdat : Nat_big_num.num= (Nat_big_num.of_int 1) + +(** Any bits in the following mask ranges are reserved exclusively for OS and + * processor specific semantics, respectively. + *) +let grp_maskos : Nat_big_num.num= (Nat_big_num.of_int 267386880) (* 0x0ff00000 *) +let grp_maskproc : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 1006632960)) (* 0xf0000000 *) + +(** [obtain_elf32_section_group_indices endian sht bs0] extracts all section header + * table indices of sections that are marked as being part of a section group. + *) +(*val obtain_elf32_section_group_indices : endianness -> elf32_section_header_table -> byte_sequence + -> error (list (natural * list elf32_word))*) +let obtain_elf32_section_group_indices endian sht bs0:((Nat_big_num.num*(Uint32.uint32)list)list)error= + (let filtered = (List.filter (fun ent -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_type)) sht_group) sht) + in + mapM (fun grp -> + let off = (Nat_big_num.of_string (Uint32.to_string grp.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string grp.elf32_sh_size)) in + let cnt = (Nat_big_num.div siz(Nat_big_num.of_int 4)) (* size of elf32_word in bytes *) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + Error.repeatM' cnt rel (read_elf32_word endian) >>= (fun (mems, _) -> + (match mems with + | [] -> fail "obtain_elf32_section_group_indices: section group sections must consist of at least one elf32_word" + | x::xs -> + let flag = (Nat_big_num.of_string (Uint32.to_string x)) in + return (flag, xs) + ))) + ) filtered) + +(** [obtain_elf64_section_group_indices endian sht bs0] extracts all section header + * table indices of sections that are marked as being part of a section group. + *) +(*val obtain_elf64_section_group_indices : endianness -> elf64_section_header_table -> byte_sequence + -> error (list (natural * list elf64_word))*) +let obtain_elf64_section_group_indices endian sht bs0:((Nat_big_num.num*(Uint32.uint32)list)list)error= + (let filtered = (List.filter (fun ent -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_type)) sht_group) sht) + in + mapM (fun grp -> + let off = (Nat_big_num.of_string (Uint64.to_string grp.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 grp.elf64_sh_size) in + let cnt = (Nat_big_num.div siz(Nat_big_num.of_int 4)) (* size of elf64_word in bytes *) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + Error.repeatM' cnt rel (read_elf64_word endian) >>= (fun (mems, _) -> + (match mems with + | [] -> fail "obtain_elf64_section_group_indices: section group sections must consist of at least one elf64_word" + | x::xs -> + let flag = (Nat_big_num.of_string (Uint32.to_string x)) in + return (flag, xs) + ))) + ) filtered) + +(** [obtain_elf32_tls_template sht] extracts the TLS template (i.e. all sections + * in section header table [sht] that have their TLS flag bit set). + *) +(*val obtain_elf32_tls_template : elf32_section_header_table -> elf32_section_header_table*) +let obtain_elf32_tls_template sht:(elf32_section_header_table_entry)list= + (List.filter (fun ent -> + let flags = (Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_flags)) in not (Nat_big_num.equal (Nat_big_num.bitwise_and flags shf_tls)(Nat_big_num.of_int 0))) sht) + +(** [obtain_elf64_tls_template sht] extracts the TLS template (i.e. all sections + * in section header table [sht] that have their TLS flag bit set). + *) +(*val obtain_elf64_tls_template : elf64_section_header_table -> elf64_section_header_table*) +let obtain_elf64_tls_template sht:(elf64_section_header_table_entry)list= + (List.filter (fun ent -> + let flags = (Ml_bindings.nat_big_num_of_uint64 ent.elf64_sh_flags) in not (Nat_big_num.equal (Nat_big_num.bitwise_and flags shf_tls)(Nat_big_num.of_int 0))) sht) + +(** [obtain_elf32_hash_table endian sht bs0] extracts a hash table from an ELF file + * providing a section of type SHT_HASH exists in section header table [sht]. + * Extraction is from byte sequence [bs0] assuming endianness [endian]. The + * return type represents the number of buckets, the number of chains, the buckets + * and finally the chains. + *) +(*val obtain_elf32_hash_table : endianness -> elf32_section_header_table -> byte_sequence -> + error (elf32_word * elf32_word * list elf32_word * list elf32_word)*) +let obtain_elf32_hash_table endian sht bs0:(Uint32.uint32*Uint32.uint32*(Uint32.uint32)list*(Uint32.uint32)list)error= + (let filtered = (List.filter (fun ent -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string ent.elf32_sh_type)) sht_hash) sht) + in + (match filtered with + | [] -> fail "obtain_elf32_hash_table: no section header table entry of type sht_hash" + | [x] -> + let siz = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_size)) in + let off = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_offset)) in + Byte_sequence.offset_and_cut siz off bs0 >>= (fun rel -> + read_elf32_word endian rel >>= (fun (nbucket, rel) -> + read_elf32_word endian rel >>= (fun (nchain, rel) -> + Error.repeatM' (Nat_big_num.of_string (Uint32.to_string nbucket)) rel (read_elf32_word endian) >>= (fun (buckets, rel) -> + Error.repeatM' (Nat_big_num.of_string (Uint32.to_string nchain)) rel (read_elf32_word endian) >>= (fun (chain, _) -> + return (nbucket, nchain, buckets, chain)))))) + | _ -> fail "obtain_elf32_hash_table: multiple section header table entries of type sht_hash" + )) + +(** [obtain_elf64_hash_table endian sht bs0] extracts a hash table from an ELF file + * providing a section of type SHT_HASH exists in section header table [sht]. + * Extraction is from byte sequence [bs0] assuming endianness [endian]. The + * return type represents the number of buckets, the number of chains, the buckets + * and finally the chains. + *) +(*val obtain_elf64_hash_table : endianness -> elf64_section_header_table -> byte_sequence -> + error (elf64_word * elf64_word * list elf64_word * list elf64_word)*) +let obtain_elf64_hash_table endian sht bs0:(Uint32.uint32*Uint32.uint32*(Uint32.uint32)list*(Uint32.uint32)list)error= + (let filtered = (List.filter (fun ent -> Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string ent.elf64_sh_type)) sht_hash) sht) + in + (match filtered with + | [] -> fail "obtain_elf64_hash_table: no section header table entry of type sht_hash" + | [x] -> + let siz = (Ml_bindings.nat_big_num_of_uint64 x.elf64_sh_size) in + let off = (Nat_big_num.of_string (Uint64.to_string x.elf64_sh_offset)) in + Byte_sequence.offset_and_cut siz off bs0 >>= (fun rel -> + read_elf64_word endian rel >>= (fun (nbucket, rel) -> + read_elf64_word endian rel >>= (fun (nchain, rel) -> + Error.repeatM' (Nat_big_num.of_string (Uint32.to_string nbucket)) rel (read_elf64_word endian) >>= (fun (buckets, rel) -> + Error.repeatM' (Nat_big_num.of_string (Uint32.to_string nchain)) rel (read_elf64_word endian) >>= (fun (chain, _) -> + return (nbucket, nchain, buckets, chain)))))) + | _ -> fail "obtain_elf64_hash_table: multiple section header table entries of type sht_hash" + )) + +(** Special sections *) + +(** [construct_special_sections] contains a finite map from section name (as + * a string) to the expected attributes and flags expected of that section, + * as specified in the ELF specification. + * NOTE: some of these are overriden by the ABI. + *) +(*val elf_special_sections : Map.map string (natural * natural)*) +let elf_special_sections:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + (".bss", (sht_nobits, Nat_big_num.add shf_alloc shf_write)) + ; (".comment", (sht_progbits,Nat_big_num.of_int 0)) + ; (".data", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".data1", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".debug", (sht_progbits,Nat_big_num.of_int 0)) + (* ; (".dynamic", (sht_dynamic, ?)) *) + ; (".dynstr", (sht_strtab, shf_alloc)) + ; (".dynsym", (sht_dynsym, shf_alloc)) + ; (".fini", (sht_progbits, Nat_big_num.add shf_alloc shf_execinstr)) + ; (".fini_array", (sht_fini_array, Nat_big_num.add shf_alloc shf_write)) + (* ; (".got", (sht_progbits, ?)) *) + ; (".hash", (sht_hash, shf_alloc)) + ; (".init", (sht_progbits, Nat_big_num.add shf_alloc shf_execinstr)) + ; (".init_array", (sht_init_array, Nat_big_num.add shf_alloc shf_write)) + (* ; (".interp", (sht_progbits, ?)) *) + ; (".line", (sht_progbits,Nat_big_num.of_int 0)) + ; (".note", (sht_note,Nat_big_num.of_int 0)) + (* ; (".plt", (sht_progbits, ?)) *) + ; (".preinit_array", (sht_preinit_array, Nat_big_num.add shf_alloc shf_write)) + (* ; (".relname", (sht_rel, ?)) *) + (* ; (".relaname", (sht_rela, ?)) *) + ; (".rodata", (sht_progbits, shf_alloc)) + ; (".rodata1", (sht_progbits, shf_alloc)) + ; (".shstrtab", (sht_strtab,Nat_big_num.of_int 0)) + (* ; (".strtab", (sht_strtab, ?)) *) + (* ; (".symtab", (sht_symtab, ?)) *) + (* ; (".symtab_shndx", (sht_symtab_shndx, ?)) *) + ; (".tbss", (sht_nobits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_tls)) + ; (".tdata", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_tls)) + ; (".tdata1", (sht_progbits, Nat_big_num.add (Nat_big_num.add shf_alloc shf_write) shf_tls)) + ; (".text", (sht_progbits, Nat_big_num.add shf_alloc shf_execinstr)) + ]) diff --git a/lib/ocaml_rts/linksem/elf_symbol_table.ml b/lib/ocaml_rts/linksem/elf_symbol_table.ml new file mode 100644 index 00000000..fc8dc068 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_symbol_table.ml @@ -0,0 +1,563 @@ +(*Generated by Lem from elf_symbol_table.lem.*) +(** [elf_symbol_table] provides types, functions and other definitions for + * working with ELF symbol tables. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +open Lem_tuple +(*import Set*) + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +open Elf_header +open Elf_types_native_uint +open Endianness +open String_table + +(** Undefined symbol index *) + +let stn_undef : Nat_big_num.num= (Nat_big_num.of_int 0) + +(** Symbol binding *) + +(** Local symbols are not visible outside of the object file containing their + * definition. + *) +let stb_local : Nat_big_num.num= (Nat_big_num.of_int 0) + +(** Global symbols are visible to all object files being combined. + *) +let stb_global : Nat_big_num.num= (Nat_big_num.of_int 1) + +(** Weak symbols resemble global symbols but their definitions have lower + * precedence. + *) +let stb_weak : Nat_big_num.num= (Nat_big_num.of_int 2) + +(** Values in the following range have reserved OS specific semantics. + *) +let stb_loos : Nat_big_num.num= (Nat_big_num.of_int 10) +let stb_hios : Nat_big_num.num= (Nat_big_num.of_int 12) + +(** Values in the following range have reserved processor specific semantics. + *) +let stb_loproc : Nat_big_num.num= (Nat_big_num.of_int 13) +let stb_hiproc : Nat_big_num.num= (Nat_big_num.of_int 15) + +(** string_of_symbol_binding b os proc] produces a string representation of + * binding [m] using printing functions [os] and [proc] for OS- and processor- + * specific values respectively. + * OCaml specific definition. + *) +(*val string_of_symbol_binding : natural -> (natural -> string) -> (natural -> string) -> string*) +let string_of_symbol_binding m os proc:string= + (if Nat_big_num.equal m stb_local then + "LOCAL" + else if Nat_big_num.equal m stb_global then + "GLOBAL" + else if Nat_big_num.equal m stb_weak then + "WEAK" + else if Nat_big_num.greater_equal m stb_loos && Nat_big_num.less_equal m stb_hios then + os m + else if Nat_big_num.greater_equal m stb_loproc && Nat_big_num.less_equal m stb_hiproc then + proc m + else + "Invalid symbol binding") + +(** Symbol types *) + +(** The symbol's type is not specified. + *) +let stt_notype : Nat_big_num.num= (Nat_big_num.of_int 0) + +(** The symbol is associated with a data object such as a variable. + *) +let stt_object : Nat_big_num.num= (Nat_big_num.of_int 1) + +(** The symbol is associated with a function or other executable code. + *) +let stt_func : Nat_big_num.num= (Nat_big_num.of_int 2) + +(** The symbol is associated with a section. + *) +let stt_section : Nat_big_num.num= (Nat_big_num.of_int 3) + +(** Conventionally the symbol's value gives the name of the source file associated + * with the object file. + *) +let stt_file : Nat_big_num.num= (Nat_big_num.of_int 4) + +(** The symbol is an uninitialised common block. + *) +let stt_common : Nat_big_num.num= (Nat_big_num.of_int 5) + +(** The symbol specified a Thread Local Storage (TLS) entity. + *) +let stt_tls : Nat_big_num.num= (Nat_big_num.of_int 6) + +(** Values in the following range are reserved solely for OS-specific semantics. + *) +let stt_loos : Nat_big_num.num= (Nat_big_num.of_int 10) +let stt_hios : Nat_big_num.num= (Nat_big_num.of_int 12) + +(** Values in the following range are reserved solely for processor-specific + * semantics. + *) +let stt_loproc : Nat_big_num.num= (Nat_big_num.of_int 13) +let stt_hiproc : Nat_big_num.num= (Nat_big_num.of_int 15) + +(** [string_of_symbol_type sym os proc] produces a string representation of + * symbol type [m] using [os] and [proc] to pretty-print values reserved for + * OS- and processor-specific functionality. + *) +(*val string_of_symbol_type : natural -> (natural -> string) -> (natural -> string) -> string*) +let string_of_symbol_type m os proc:string= + (if Nat_big_num.equal m stt_notype then + "NOTYPE" + else if Nat_big_num.equal m stt_object then + "OBJECT" + else if Nat_big_num.equal m stt_func then + "FUNC" + else if Nat_big_num.equal m stt_section then + "SECTION" + else if Nat_big_num.equal m stt_file then + "FILE" + else if Nat_big_num.equal m stt_common then + "COMMON" + else if Nat_big_num.equal m stt_tls then + "TLS" + else if Nat_big_num.greater_equal m stt_loos && Nat_big_num.less_equal m stt_hios then + os m + else if Nat_big_num.greater_equal m stt_loproc && Nat_big_num.less_equal m stt_hiproc then + proc m + else + "Invalid symbol type") + +(** Symbol visibility *) + +(** The visibility of the symbol is as specified by the symbol's binding type. + *) +let stv_default : Nat_big_num.num= (Nat_big_num.of_int 0) + +(** The meaning of this visibility may be defined by processor supplements to + * further constrain hidden symbols. + *) +let stv_internal : Nat_big_num.num= (Nat_big_num.of_int 1) + +(** The symbol's name is not visible in other components. + *) +let stv_hidden : Nat_big_num.num= (Nat_big_num.of_int 2) + +(** The symbol is visible in other components but not pre-emptable. That is, + * references to the symbol in the same component resolve to this symbol even + * if other symbols of the same name in other components would normally be + * resolved to instead if we followed the normal rules of symbol resolution. + *) +let stv_protected : Nat_big_num.num= (Nat_big_num.of_int 3) + +(** [string_of_symbol_visibility m] produces a string representation of symbol + * visibility [m]. + *) +(*val string_of_symbol_visibility : natural -> string*) +let string_of_symbol_visibility m:string= + (if Nat_big_num.equal m stv_default then + "DEFAULT" + else if Nat_big_num.equal m stv_internal then + "INTERNAL" + else if Nat_big_num.equal m stv_hidden then + "HIDDEN" + else if Nat_big_num.equal m stv_protected then + "PROTECTED" + else + "Invalid symbol visibility") + +(** Symbol table entry type *) + +(** [elf32_symbol_table_entry] is an entry in a symbol table. + *) +type elf32_symbol_table_entry = + { elf32_st_name : Uint32.uint32 (** Index into the object file's string table *) + ; elf32_st_value : Uint32.uint32 (** Gives the value of the associated symbol *) + ; elf32_st_size : Uint32.uint32 (** Size of the associated symbol *) + ; elf32_st_info : Uint32.uint32 (** Specifies the symbol's type and binding attributes *) + ; elf32_st_other : Uint32.uint32 (** Currently specifies the symbol's visibility *) + ; elf32_st_shndx : Uint32.uint32 (** Section header index symbol is defined with respect to *) + } + +(** [elf32_symbol_table_entry_compare ent1 ent2] is an ordering-comparison function + * for symbol table entries suitable for constructing sets, finite maps and other + * ordered data structures from. + *) +(*val elf32_symbol_table_entry_compare : elf32_symbol_table_entry -> + elf32_symbol_table_entry -> ordering*) +let elf32_symbol_table_entry_compare ent1 ent2:int= + (sextupleCompare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare (Nat_big_num.of_string (Uint32.to_string ent1.elf32_st_name), Nat_big_num.of_string (Uint32.to_string ent1.elf32_st_value), + Nat_big_num.of_string (Uint32.to_string ent1.elf32_st_size), Nat_big_num.of_string (Uint32.to_string ent1.elf32_st_info), + Nat_big_num.of_string (Uint32.to_string ent1.elf32_st_other), Nat_big_num.of_string (Uint32.to_string ent1.elf32_st_shndx)) + (Nat_big_num.of_string (Uint32.to_string ent2.elf32_st_name), Nat_big_num.of_string (Uint32.to_string ent2.elf32_st_value), + Nat_big_num.of_string (Uint32.to_string ent2.elf32_st_size), Nat_big_num.of_string (Uint32.to_string ent2.elf32_st_info), + Nat_big_num.of_string (Uint32.to_string ent2.elf32_st_other), Nat_big_num.of_string (Uint32.to_string ent2.elf32_st_shndx))) + +let instance_Basic_classes_Ord_Elf_symbol_table_elf32_symbol_table_entry_dict:(elf32_symbol_table_entry)ord_class= ({ + + compare_method = elf32_symbol_table_entry_compare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf32_symbol_table_entry_compare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf32_symbol_table_entry_compare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf32_symbol_table_entry_compare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf32_symbol_table_entry_compare f1 f2)(Pset.from_list compare [1; 0])))}) + +(** [elf64_symbol_table_entry] is an entry in a symbol table. + *) +type elf64_symbol_table_entry = + { elf64_st_name : Uint32.uint32 (** Index into the object file's string table *) + ; elf64_st_info : Uint32.uint32 (** Specifies the symbol's type and binding attributes *) + ; elf64_st_other : Uint32.uint32 (** Currently specifies the symbol's visibility *) + ; elf64_st_shndx : Uint32.uint32 (** Section header index symbol is defined with respect to *) + ; elf64_st_value : Uint64.uint64 (** Gives the value of the associated symbol *) + ; elf64_st_size : Uint64.uint64 (** Size of the associated symbol *) + } + +(** [elf64_symbol_table_entry_compare ent1 ent2] is an ordering-comparison function + * for symbol table entries suitable for constructing sets, finite maps and other + * ordered data structures from. + *) +(*val elf64_symbol_table_entry_compare : elf64_symbol_table_entry -> elf64_symbol_table_entry -> + ordering*) +let elf64_symbol_table_entry_compare ent1 ent2:int= + (sextupleCompare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare (Nat_big_num.of_string (Uint32.to_string ent1.elf64_st_name), Ml_bindings.nat_big_num_of_uint64 ent1.elf64_st_value, + Ml_bindings.nat_big_num_of_uint64 ent1.elf64_st_size, Nat_big_num.of_string (Uint32.to_string ent1.elf64_st_info), + Nat_big_num.of_string (Uint32.to_string ent1.elf64_st_other), Nat_big_num.of_string (Uint32.to_string ent1.elf64_st_shndx)) + (Nat_big_num.of_string (Uint32.to_string ent2.elf64_st_name), Ml_bindings.nat_big_num_of_uint64 ent2.elf64_st_value, + Ml_bindings.nat_big_num_of_uint64 ent2.elf64_st_size, Nat_big_num.of_string (Uint32.to_string ent2.elf64_st_info), + Nat_big_num.of_string (Uint32.to_string ent2.elf64_st_other), Nat_big_num.of_string (Uint32.to_string ent2.elf64_st_shndx))) + +let instance_Basic_classes_Ord_Elf_symbol_table_elf64_symbol_table_entry_dict:(elf64_symbol_table_entry)ord_class= ({ + + compare_method = elf64_symbol_table_entry_compare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf64_symbol_table_entry_compare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf64_symbol_table_entry_compare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elf64_symbol_table_entry_compare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elf64_symbol_table_entry_compare f1 f2)(Pset.from_list compare [1; 0])))}) + +type elf32_symbol_table = elf32_symbol_table_entry + list + +type elf64_symbol_table = elf64_symbol_table_entry + list + +(** Extraction of symbol table data *) + +(* Functions below common to 32- and 64-bit! *) + +(** [extract_symbol_binding u] extracts a symbol table entry's symbol binding. [u] + * in this case is the [elfXX_st_info] field from a symbol table entry. + *) +(*val extract_symbol_binding : unsigned_char -> natural*) +let extract_symbol_binding entry:Nat_big_num.num= + (Nat_big_num.of_string (Uint32.to_string (Uint32.shift_right entry( 4)))) + +(** [extract_symbol_type u] extracts a symbol table entry's symbol type. [u] + * in this case is the [elfXX_st_info] field from a symbol table entry. + *) +(*val extract_symbol_type : unsigned_char -> natural*) +let extract_symbol_type entry:Nat_big_num.num= + (Nat_big_num.of_string (Uint32.to_string (Uint32.logand entry (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 15)))))) (* 0xf *) + +(** [get_symbol_info u] extracts a symbol table entry's symbol info. [u] + * in this case is the [elfXX_st_info] field from a symbol table entry. + *) +(*val make_symbol_info : natural -> natural -> unsigned_char*) +let make_symbol_info binding1 symtype:Uint32.uint32= + (Uint32.add + (Uint32.shift_left (Uint32.of_string (Nat_big_num.to_string binding1))( 4)) + (Uint32.logand (Uint32.of_string (Nat_big_num.to_string symtype)) + (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 15))))) (*0xf*) + +(** [get_symbol_visibility u] extracts a symbol table entry's symbol visibility. [u] + * in this case is the [elfXX_st_other] field from a symbol table entry. + *) +(*val get_symbol_visibility : unsigned_char -> natural*) +let get_symbol_visibility info:Nat_big_num.num= + (Nat_big_num.of_string (Uint32.to_string (Uint32.logand info (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 3)))))) (* 0x3*) + +(** [make_symbol_other m] converts a natural [m] to an unsigned char suitable + * for use in a symbol table entry's "other" field. + * XXX: WHY? + *) +(*val make_symbol_other : natural -> unsigned_char*) +let make_symbol_other visibility:Uint32.uint32= + (Uint32.of_string (Nat_big_num.to_string visibility)) + +(** [is_elf32_shndx_too_large ent] tests whether the symbol table entry's + * [shndx] field is equal to SHN_XINDEX, in which case the real value is stored + * elsewhere. + *) +(*val is_elf32_shndx_too_large : elf32_symbol_table_entry -> bool*) +let is_elf32_shndx_too_large syment:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string syment.elf32_st_shndx)) shn_xindex) + +(** [is_elf64_shndx_too_large ent] tests whether the symbol table entry's + * [shndx] field is equal to SHN_XINDEX, in which case the real value is stored + * elsewhere. + *) +(*val is_elf64_shndx_too_large : elf64_symbol_table_entry -> bool*) +let is_elf64_shndx_too_large syment:bool= (Nat_big_num.equal +(Nat_big_num.of_string (Uint32.to_string syment.elf64_st_shndx)) shn_xindex) + +(** NULL tests *) + +(** [is_elf32_null_entry ent] tests whether [ent] is a null symbol table entry, + * i.e. all fields set to [0]. + *) +(*val is_elf32_null_entry : elf32_symbol_table_entry -> bool*) +let is_elf32_null_entry ent:bool= (Nat_big_num.equal + (Nat_big_num.of_string (Uint32.to_string ent.elf32_st_name))(Nat_big_num.of_int 0) + && (( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf32_st_value))(Nat_big_num.of_int 0)) + && (( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf32_st_size))(Nat_big_num.of_int 0)) + && (( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf32_st_info))(Nat_big_num.of_int 0)) + && (( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf32_st_other))(Nat_big_num.of_int 0)) + && ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf32_st_shndx))(Nat_big_num.of_int 0))))))) + +(** [is_elf64_null_entry ent] tests whether [ent] is a null symbol table entry, + * i.e. all fields set to [0]. + *) +(*val is_elf64_null_entry : elf64_symbol_table_entry -> bool*) +let is_elf64_null_entry ent:bool= (Nat_big_num.equal + (Nat_big_num.of_string (Uint32.to_string ent.elf64_st_name))(Nat_big_num.of_int 0) + && (( Nat_big_num.equal(Ml_bindings.nat_big_num_of_uint64 ent.elf64_st_value)(Nat_big_num.of_int 0)) + && (( Nat_big_num.equal(Ml_bindings.nat_big_num_of_uint64 ent.elf64_st_size)(Nat_big_num.of_int 0)) + && (( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf64_st_info))(Nat_big_num.of_int 0)) + && (( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf64_st_other))(Nat_big_num.of_int 0)) + && ( Nat_big_num.equal(Nat_big_num.of_string (Uint32.to_string ent.elf64_st_shndx))(Nat_big_num.of_int 0))))))) + +(** Printing symbol table entries *) + +type symtab_print_bundle = + (Nat_big_num.num -> string) * (Nat_big_num.num -> string) + +(** [string_of_elf32_symbol_table_entry ent] produces a string based representation + * of symbol table entry [ent]. + *) +(*val string_of_elf32_symbol_table_entry : elf32_symbol_table_entry -> string*) +let string_of_elf32_symbol_table_entry entry:string= + (unlines [ +("\t" ^ ("Name: " ^ Uint32.to_string entry.elf32_st_name)) + ; ("\t" ^ ("Value: " ^ Uint32.to_string entry.elf32_st_value)) + ; ("\t" ^ ("Size: " ^ Uint32.to_string entry.elf32_st_size)) + ; ("\t" ^ ("Info: " ^ Uint32.to_string entry.elf32_st_info)) + ; ("\t" ^ ("Other: " ^ Uint32.to_string entry.elf32_st_other)) + ; ("\t" ^ ("Shndx: " ^ Uint32.to_string entry.elf32_st_shndx)) + ]) + +(** [string_of_elf64_symbol_table_entry ent] produces a string based representation + * of symbol table entry [ent]. + *) +(*val string_of_elf64_symbol_table_entry : elf64_symbol_table_entry -> string*) +let string_of_elf64_symbol_table_entry entry:string= + (unlines [ +("\t" ^ ("Name: " ^ Uint32.to_string entry.elf64_st_name)) + ; ("\t" ^ ("Info: " ^ Uint32.to_string entry.elf64_st_info)) + ; ("\t" ^ ("Other: " ^ Uint32.to_string entry.elf64_st_other)) + ; ("\t" ^ ("Shndx: " ^ Uint32.to_string entry.elf64_st_shndx)) + ; ("\t" ^ ("Value: " ^ Uint64.to_string entry.elf64_st_value)) + ; ("\t" ^ ("Size: " ^ Uint64.to_string entry.elf64_st_size)) + ]) + +(** [string_of_elf32_symbol_table stbl] produces a string based representation + * of symbol table [stbl]. + *) +(*val string_of_elf32_symbol_table : elf32_symbol_table -> string*) +let string_of_elf32_symbol_table symtab:string= + (unlines (Lem_list.map string_of_elf32_symbol_table_entry symtab)) + +(** [elf64_null_symbol_table_entry] is the null symbol table entry, with all + * fields set to zero. + *) +(*val elf64_null_symbol_table_entry : elf64_symbol_table_entry*) +let elf64_null_symbol_table_entry:elf64_symbol_table_entry= + ({ elf64_st_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_info = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_other = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_shndx = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_value = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_size = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + +(*val string_of_elf64_symbol_table : elf64_symbol_table -> string*) +let string_of_elf64_symbol_table symtab:string= + (unlines (Lem_list.map string_of_elf64_symbol_table_entry symtab)) + +let instance_Show_Show_Elf_symbol_table_elf32_symbol_table_entry_dict:(elf32_symbol_table_entry)show_class= ({ + + show_method = string_of_elf32_symbol_table_entry}) + +let instance_Show_Show_Elf_symbol_table_elf64_symbol_table_entry_dict:(elf64_symbol_table_entry)show_class= ({ + + show_method = string_of_elf64_symbol_table_entry}) + +(** Reading in symbol table (entries) *) + +(** [read_elf32_symbol_table_entry endian bs0] reads an ELF symbol table entry + * record from byte sequence [bs0] assuming endianness [endian], returning the + * remainder of the byte sequence. Fails if the byte sequence is not long enough. + *) +(*val read_elf32_symbol_table_entry : endianness -> byte_sequence -> + error (elf32_symbol_table_entry * byte_sequence)*) +let read_elf32_symbol_table_entry endian bs0:(elf32_symbol_table_entry*byte_sequence)error= + (read_elf32_word endian bs0 >>= (fun (st_name, bs0) -> + read_elf32_addr endian bs0 >>= (fun (st_value, bs0) -> + read_elf32_word endian bs0 >>= (fun (st_size, bs0) -> + read_unsigned_char endian bs0 >>= (fun (st_info, bs0) -> + read_unsigned_char endian bs0 >>= (fun (st_other, bs0) -> + read_elf32_half endian bs0 >>= (fun (st_shndx, bs0) -> + return ({ elf32_st_name = st_name; elf32_st_value = st_value; + elf32_st_size = st_size; elf32_st_info = st_info; + elf32_st_other = st_other; elf32_st_shndx = st_shndx }, bs0)))))))) + +(*val bytes_of_elf32_symbol_table_entry : endianness -> + elf32_symbol_table_entry -> byte_sequence*) +let bytes_of_elf32_symbol_table_entry endian entry:byte_sequence= + (Byte_sequence.from_byte_lists [ + bytes_of_elf32_word endian entry.elf32_st_name + ; bytes_of_elf32_addr endian entry.elf32_st_value + ; bytes_of_elf32_word endian entry.elf32_st_size + ; bytes_of_unsigned_char entry.elf32_st_info + ; bytes_of_unsigned_char entry.elf32_st_other + ; bytes_of_elf32_half endian entry.elf32_st_shndx + ]) + +(** [read_elf64_symbol_table_entry endian bs0] reads an ELF symbol table entry + * record from byte sequence [bs0] assuming endianness [endian], returning the + * remainder of the byte sequence. Fails if the byte sequence is not long enough. + *) +(*val read_elf64_symbol_table_entry : endianness -> byte_sequence -> + error (elf64_symbol_table_entry * byte_sequence)*) +let read_elf64_symbol_table_entry endian bs0:(elf64_symbol_table_entry*byte_sequence)error= + (read_elf64_word endian bs0 >>= (fun (st_name, bs0) -> + read_unsigned_char endian bs0 >>= (fun (st_info, bs0) -> + read_unsigned_char endian bs0 >>= (fun (st_other, bs0) -> + read_elf64_half endian bs0 >>= (fun (st_shndx, bs0) -> + read_elf64_addr endian bs0 >>= (fun (st_value, bs0) -> + read_elf64_xword endian bs0 >>= (fun (st_size, bs0) -> + return ({ elf64_st_name = st_name; elf64_st_info = st_info; + elf64_st_other = st_other; elf64_st_shndx = st_shndx; + elf64_st_value = st_value; elf64_st_size = st_size }, bs0)))))))) + +(*val bytes_of_elf64_symbol_table_entry : endianness -> + elf64_symbol_table_entry -> byte_sequence*) +let bytes_of_elf64_symbol_table_entry endian entry:byte_sequence= + (Byte_sequence.from_byte_lists [ + bytes_of_elf64_word endian entry.elf64_st_name + ; bytes_of_unsigned_char entry.elf64_st_info + ; bytes_of_unsigned_char entry.elf64_st_other + ; bytes_of_elf64_half endian entry.elf64_st_shndx + ; bytes_of_elf64_addr endian entry.elf64_st_value + ; bytes_of_elf64_xword endian entry.elf64_st_size + ]) + +(** [read_elf32_symbol_table endian bs0] reads a symbol table from byte sequence + * [bs0] assuming endianness [endian]. Assumes [bs0]'s length modulo the size + * of a symbol table entry is 0. Fails otherwise. + *) +(*val read_elf32_symbol_table : endianness -> byte_sequence -> error elf32_symbol_table*) +let rec read_elf32_symbol_table endian bs0:((elf32_symbol_table_entry)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf32_symbol_table_entry endian bs0 >>= (fun (head, bs0) -> + read_elf32_symbol_table endian bs0 >>= (fun tail -> + return (head::tail)))) + +(** [read_elf64_symbol_table endian bs0] reads a symbol table from byte sequence + * [bs0] assuming endianness [endian]. Assumes [bs0]'s length modulo the size + * of a symbol table entry is 0. Fails otherwise. + *) +(*val read_elf64_symbol_table : endianness -> byte_sequence -> error elf64_symbol_table*) +let rec read_elf64_symbol_table endian bs0:((elf64_symbol_table_entry)list)error= + (if Nat_big_num.equal (Byte_sequence.length0 bs0)(Nat_big_num.of_int 0) then + return [] + else + read_elf64_symbol_table_entry endian bs0 >>= (fun (head, bs0) -> + read_elf64_symbol_table endian bs0 >>= (fun tail -> + return (head::tail)))) + +(** Association map of symbol name, symbol type, symbol size, symbol address + * and symbol binding. + * A PPCMemism. + *) +type symbol_address_map + = (string * (Nat_big_num.num * Nat_big_num.num * Nat_big_num.num * Nat_big_num.num)) list + +(** [get_elf32_symbol_image_address symtab stbl] extracts the symbol address map + * from the symbol table [symtab] using the string table [stbl]. + * A PPCMemism. + *) +(*val get_elf32_symbol_image_address : elf32_symbol_table -> string_table -> + error symbol_address_map*) +let get_elf32_symbol_image_address symtab strtab:((string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*Nat_big_num.num))list)error= + (mapM (fun entry -> + let name1 = (Nat_big_num.of_string (Uint32.to_string entry.elf32_st_name)) in + let addr = (Nat_big_num.of_string (Uint32.to_string entry.elf32_st_value)) in + let size2 = (Nat_big_num.mul (Nat_big_num.of_string (Uint32.to_string entry.elf32_st_size))(Nat_big_num.of_int 8)) in + let typ = (extract_symbol_type entry.elf32_st_info) in + let bnd = (extract_symbol_binding entry.elf32_st_info) in + String_table.get_string_at name1 strtab >>= (fun str -> + return (str, (typ, size2, addr, bnd))) + ) symtab) + +(** [get_elf64_symbol_image_address symtab stbl] extracts the symbol address map + * from the symbol table [symtab] using the string table [stbl]. + * A PPCMemism. + *) +(*val get_elf64_symbol_image_address : elf64_symbol_table -> string_table -> + error symbol_address_map*) +let get_elf64_symbol_image_address symtab strtab:((string*(Nat_big_num.num*Nat_big_num.num*Nat_big_num.num*Nat_big_num.num))list)error= + (mapM (fun entry -> + let name1 = (Nat_big_num.of_string (Uint32.to_string entry.elf64_st_name)) in + let addr = (Ml_bindings.nat_big_num_of_uint64 entry.elf64_st_value) in + let size2 = (Ml_bindings.nat_big_num_of_uint64 entry.elf64_st_size) in + let typ = (extract_symbol_type entry.elf64_st_info) in + let bnd = (extract_symbol_binding entry.elf64_st_info) in + String_table.get_string_at name1 strtab >>= (fun str -> + return (str, (typ, size2, addr, bnd))) + ) symtab) + +(** [get_el32_symbol_type ent] extracts the symbol type from symbol table entry + * [ent]. + *) +(*val get_elf32_symbol_type : elf32_symbol_table_entry -> natural*) +let get_elf32_symbol_type syment:Nat_big_num.num= (extract_symbol_type syment.elf32_st_info) + +(** [get_el64_symbol_type ent] extracts the symbol type from symbol table entry + * [ent]. + *) +(*val get_elf64_symbol_type : elf64_symbol_table_entry -> natural*) +let get_elf64_symbol_type syment:Nat_big_num.num= (extract_symbol_type syment.elf64_st_info) + +(** [get_el32_symbol_binding ent] extracts the symbol binding from symbol table entry + * [ent]. + *) +(*val get_elf32_symbol_binding : elf32_symbol_table_entry -> natural*) +let get_elf32_symbol_binding syment:Nat_big_num.num= (extract_symbol_binding syment.elf32_st_info) + +(** [get_el64_symbol_binding ent] extracts the symbol binding from symbol table entry + * [ent]. + *) +(*val get_elf64_symbol_binding : elf64_symbol_table_entry -> natural*) +let get_elf64_symbol_binding syment:Nat_big_num.num= (extract_symbol_binding syment.elf64_st_info) diff --git a/lib/ocaml_rts/linksem/elf_types_native_uint.ml b/lib/ocaml_rts/linksem/elf_types_native_uint.ml new file mode 100644 index 00000000..d6874fd4 --- /dev/null +++ b/lib/ocaml_rts/linksem/elf_types_native_uint.ml @@ -0,0 +1,706 @@ +(*Generated by Lem from elf_types_native_uint.lem.*) +open Lem_basic_classes +open Lem_bool +open Lem_num +open Lem_string +open Lem_assert_extra + +open Endianness + +open Byte_sequence +open Error +open Missing_pervasives +open Show + +(** unsigned char type and bindings *) + +(*type unsigned_char*) + +(** [string_of_unsigned_char uc] provides a string representation of unsigned + * char [uc] (in base 10). + *) +(*val string_of_unsigned_char : unsigned_char -> string*) + +(** [natural_of_unsigned_char uc] converts an unsigned char [uc] into a natural. + *) +(*val natural_of_unsigned_char : unsigned_char -> natural*) + +(** [unsigned_char_of_natural i] converts a [natural] into an unsigned char, wrapping + * around if the size of the nat exceeds the storage capacity of an unsigned + * char. + *) +(*val unsigned_char_of_natural : natural -> unsigned_char*) + +(** [unsigned_char_land uc0 uc1] bitwise ANDs two unsigned chars, [uc0] and [uc1] + * together. + *) +(*val unsigned_char_land : unsigned_char -> unsigned_char -> unsigned_char*) + +(** [unsigned_char_lor uc0 uc1] bitwise OR two unsigned chars, [uc0] and [uc1] + * together. + *) +(*val unsigned_char_lor : unsigned_char -> unsigned_char -> unsigned_char*) + +(** [unsigned_char_lshift uc n] performs a left bitshift of [n] places on unsigned + * char [uc]. + *) +(*val unsigned_char_lshift : unsigned_char -> nat -> unsigned_char*) + +(** [unsigned_char_rshift uc n] performs a right bitshift of [n] places on unsigned + * char [uc]. + *) +(*val unsigned_char_rshift : unsigned_char -> nat -> unsigned_char*) + +(** [unsigned_char_plus uc0 uc1] adds two unsigned chars, [uc0] and [uc1]. + *) +(*val unsigned_char_plus : unsigned_char -> unsigned_char -> unsigned_char*) + +(*val unsigned_char_of_byte : byte -> unsigned_char*) + +let natural_of_byte b:Nat_big_num.num= +(Nat_big_num.of_string (Uint32.to_string (Uint32.of_int (Char.code b)))) + +(** [read_unsigned_char end bs0] reads an unsigned char from byte_sequence [bs0] + * assuming endianness [end]. Returns the unsigned char and the remainder of + * the byte_sequence. Fails if an unsigned char cannot be read from the byte_sequence, + * e.g. if [bs0] is too small. + *) +(*val read_unsigned_char : endianness -> byte_sequence -> error (unsigned_char * byte_sequence)*) +let read_unsigned_char endian bs0:(Uint32.uint32*byte_sequence)error= + (Byte_sequence.read_char bs0 >>= (fun (u1, bs1) -> + return (Uint32.of_int (Char.code u1), bs1))) + +(*val byte_of_unsigned_char : unsigned_char -> byte*) + +(*val bytes_of_unsigned_char : unsigned_char -> list byte*) +let bytes_of_unsigned_char u:(char)list= ([Char.chr (Uint32.to_int u)]) + +(*val equal_unsigned_char : unsigned_char -> unsigned_char -> bool*) + +let instance_Basic_classes_Eq_Elf_types_native_uint_unsigned_char_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_unsigned_char_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(** ELF address type: + * 4 byte unsigned type on 32-bit architectures. + * 8 byte unsigned type on 64-bit architectures. + *) + +(*type elf32_addr*) + +(*val string_of_elf32_addr : elf32_addr -> string*) + +(*val natural_of_elf32_addr : elf32_addr -> natural*) + +(*val elf32_addr_of_natural : natural -> elf32_addr*) + +(*val elf32_addr_of_quad : byte -> byte -> byte -> byte -> elf32_addr*) + +(*val read_elf32_addr : endianness -> byte_sequence -> error (elf32_addr * byte_sequence)*) +let read_elf32_addr endian bs0:(Uint32.uint32*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_4_bytes_le bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_4_bytes_be bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + )) + +(*val equal_elf32_addr : elf32_addr -> elf32_addr -> bool*) + +(*val quad_of_elf32_addr : elf32_addr -> (byte * byte * byte * byte)*) + +(*val bytes_of_elf32_addr : endianness -> elf32_addr -> list byte*) +let bytes_of_elf32_addr endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b0; b1; b2; b3] + | Big -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b3; b2; b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf32_addr_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf32_addr_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(** elf64_addr type and bindings *) + +(*type elf64_addr*) + +(*val string_of_elf64_addr : elf64_addr -> string*) + +(*val natural_of_elf64_addr : elf64_addr -> natural*) + +(*val elf64_addr_of_natural : natural -> elf64_addr*) + +(*val elf64_addr_of_oct : byte -> byte -> byte -> byte -> byte -> byte -> byte -> byte -> elf64_addr*) + +(*val read_elf64_addr : endianness -> byte_sequence -> error (elf64_addr * byte_sequence)*) +let read_elf64_addr endian bs0:(Uint64.uint64*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_8_bytes_le bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Uint64_wrapper.of_oct_native b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_8_bytes_be bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Uint64_wrapper.of_oct_native b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + )) + +(*val equal_elf64_addr : elf64_addr -> elf64_addr -> bool*) + +(*val oct_of_elf64_addr : elf64_addr -> (byte * byte * byte * byte * byte * byte * byte * byte)*) + +(*val bytes_of_elf64_addr : endianness -> elf64_addr -> list byte*) +let bytes_of_elf64_addr endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Uint64_wrapper.to_bytes_native w) in + [b0; b1; b2; b3; b4; b5; b6; b7] + | Big -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Uint64_wrapper.to_bytes_native w) in + [b7; b6; b5; b4; b3; b2; b1; b0] + )) + +(*val elf64_addr_minus : elf64_addr -> elf64_addr -> elf64_addr*) + +(*val elf64_addr_rshift : elf64_addr -> nat -> elf64_addr*) + +(*val elf64_addr_lshift : elf64_addr -> nat -> elf64_addr*) + +(*val elf64_addr_land : elf64_addr -> elf64_addr -> elf64_addr*) + +(*val elf64_addr_lor : elf64_addr -> elf64_addr -> elf64_addr*) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf64_addr_dict:(Uint64.uint64)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf64_addr_dict:(Uint64.uint64)show_class= ({ + + show_method = Uint64.to_string}) + +(** ELF half word type: + * 2 byte unsigned type on 32-bit architectures. + * 2 byte unsigned type on 64-bit architectures. + *) + +(*type elf32_half*) + +(*val string_of_elf32_half : elf32_half -> string*) + +(*val elf32_half_of_dual : byte -> byte -> elf32_half*) + +(*val read_elf32_half : endianness -> byte_sequence -> error (elf32_half * byte_sequence)*) +let read_elf32_half endian bs0:(Uint32.uint32*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_2_bytes_le bs0 >>= (fun ((b1, b2), bs1) -> + return (Uint32_wrapper.of_dual_native b2 b1, bs1)) + | Big -> + Byte_sequence.read_2_bytes_be bs0 >>= (fun ((b1, b2), bs1) -> + return (Uint32_wrapper.of_dual_native b2 b1, bs1)) + )) + +(*val natural_of_elf32_half : elf32_half -> natural*) + +(*val equal_elf32_half : elf32_half -> elf32_half -> bool*) + +(*val dual_of_elf32_half : elf32_half -> (byte * byte)*) + +(*val bytes_of_elf32_half : endianness -> elf32_half -> list byte*) +let bytes_of_elf32_half endian h:(char)list= + ((match endian with + | Little -> + let (b0, b1) = (Uint32_wrapper.to_dual_bytes_native h) in + [b0; b1] + | Big -> + let (b0, b1) = (Uint32_wrapper.to_dual_bytes_native h) in + [b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf32_half_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf32_half_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(** elf64_half type and bindings *) + +(*type elf64_half*) + +(*val string_of_elf64_half : elf64_half -> string*) + +(*val elf64_half_of_dual : byte -> byte -> elf64_half*) + +(*val read_elf64_half : endianness -> byte_sequence -> error (elf64_half * byte_sequence)*) +let read_elf64_half endian bs0:(Uint32.uint32*byte_sequence)error= + ((match endian with + | Big -> + Byte_sequence.read_2_bytes_be bs0 >>= (fun ((b1, b2), bs1) -> + return (Uint32_wrapper.of_dual_native b2 b1, bs1)) + | Little -> + Byte_sequence.read_2_bytes_le bs0 >>= (fun ((b1, b2), bs1) -> + return (Uint32_wrapper.of_dual_native b2 b1, bs1)) + )) + +(*val natural_of_elf64_half : elf64_half -> natural*) + +(*val elf64_half_of_natural : natural -> elf64_half*) + +(*val equal_elf64_half : elf64_half -> elf64_half -> bool*) + +(*val dual_of_elf64_half : elf64_half -> (byte * byte)*) + +(*val bytes_of_elf64_half : endianness -> elf64_half -> list byte*) +let bytes_of_elf64_half endian w:(char)list= + ((match endian with + | Big -> + let (b0, b1) = (Uint32_wrapper.to_dual_bytes_native w) in + [b1; b0] + | Little -> + let (b0, b1) = (Uint32_wrapper.to_dual_bytes_native w) in + [b0; b1] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf64_half_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf64_half_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(* +instance (Ord elf64_half) + let compare = + let (<) = + let (<=) = + let (>) = + let (>=) = +end +*) + +(** ELF offset type: + * 4 byte unsigned type on 32-bit architectures. + * 8 byte unsigned type on 64-bit architectures. + *) + +(*type elf32_off*) + +(*val string_of_elf32_off : elf32_off -> string*) + +(*val natural_of_elf32_off : elf32_off -> natural*) + +(*val elf32_off_of_natural : natural -> elf32_off*) + +(*val elf32_off_of_quad : byte -> byte -> byte -> byte -> elf32_off*) + +(*val read_elf32_off : endianness -> byte_sequence -> error (elf32_off * byte_sequence)*) +let read_elf32_off endian bs0:(Uint32.uint32*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_4_bytes_le bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_4_bytes_be bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + )) + +(*val equal_elf32_off : elf32_off -> elf32_off -> bool*) + +(*val quad_of_elf32_off : elf32_off -> (byte * byte * byte * byte)*) + +(*val bytes_of_elf32_off : endianness -> elf32_off -> list byte*) +let bytes_of_elf32_off endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b0; b1; b2; b3] + | Big -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b3; b2; b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf32_off_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf32_off_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(** elf64_off type and bindings *) + +(*type elf64_off*) + +(*val string_of_elf64_off : elf64_off -> string*) + +(*val natural_of_elf64_off : elf64_off -> natural*) + +(*val elf64_off_of_natural : natural -> elf64_off*) + +(*val elf64_off_of_oct : byte -> byte -> byte -> byte -> byte -> byte -> byte -> byte -> elf64_off*) + +(*val read_elf64_off : endianness -> byte_sequence -> error (elf64_off * byte_sequence)*) +let read_elf64_off endian bs0:(Uint64.uint64*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_8_bytes_le bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Uint64_wrapper.of_oct_native b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_8_bytes_be bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Uint64_wrapper.of_oct_native b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + )) + +(*val equal_elf64_off : elf64_off -> elf64_off -> bool*) + +(*val oct_of_elf64_off : elf64_off -> (byte * byte * byte * byte * byte * byte * byte * byte)*) + +(*val bytes_of_elf64_off : endianness -> elf64_off -> list byte*) +let bytes_of_elf64_off endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Uint64_wrapper.to_bytes_native w) in + [b0; b1; b2; b3; b4; b5; b6; b7] + | Big -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Uint64_wrapper.to_bytes_native w) in + [b7; b6; b5; b4; b3; b2; b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf64_off_dict:(Uint64.uint64)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf64_off_dict:(Uint64.uint64)show_class= ({ + + show_method = Uint64.to_string}) + +(** ELF word type: + * 4 byte unsigned type on 32-bit architectures. + * 4 byte unsigned type on 64-bit architectures. + *) + +(*type elf32_word*) + +(*val string_of_elf32_word : elf32_word -> string*) + +(*val natural_of_elf32_word : elf32_word -> natural*) + +(*val elf32_word_of_natural : natural -> elf32_word*) + +(*val elf32_word_land : elf32_word -> elf32_word -> elf32_word*) + +(*val elf32_word_rshift : elf32_word -> nat -> elf32_word*) + +(*val elf32_word_of_quad : byte -> byte -> byte -> byte -> elf32_word*) + +(*val read_elf32_word : endianness -> byte_sequence -> error (elf32_word * byte_sequence)*) +let read_elf32_word endian bs0:(Uint32.uint32*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_4_bytes_le bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_4_bytes_be bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + )) + +(*val unsigned_char_of_elf32_word : elf32_word -> unsigned_char*) + +(*val equal_elf32_word : elf32_word -> elf32_word -> bool*) + +(*val quad_of_elf32_word : elf32_word -> (byte * byte * byte * byte)*) + +(*val bytes_of_elf32_word : endianness -> elf32_word -> list byte*) +let bytes_of_elf32_word endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b0; b1; b2; b3] + | Big -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b3; b2; b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf32_word_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf32_word_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(** elf64_word type and bindings *) + +(*type elf64_word*) + +(*val string_of_elf64_word : elf64_word -> string*) + +(*val natural_of_elf64_word : elf64_word -> natural*) + +(*val elf64_word_of_natural : natural -> elf64_word*) + +(*val elf64_word_land : elf64_word -> elf64_word -> elf64_word*) + +(*val elf64_word_of_quad : byte -> byte -> byte -> byte -> elf64_word*) + +(*val read_elf64_word : endianness -> byte_sequence -> error (elf64_word * byte_sequence)*) +let read_elf64_word endian bs0:(Uint32.uint32*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_4_bytes_le bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_4_bytes_be bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Uint32_wrapper.of_quad_native b4 b3 b2 b1, bs1)) + )) + +(*val equal_elf64_word : elf64_word -> elf64_word -> bool*) + +(*val quad_of_elf64_word : elf64_word -> (byte * byte * byte * byte)*) + +(*val bytes_of_elf64_word : endianness -> elf64_word -> list byte*) +let bytes_of_elf64_word endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b0; b1; b2; b3] + | Big -> + let (b0, b1, b2, b3) = (Uint32_wrapper.to_bytes_native w) in + [b3; b2; b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf64_word_dict:(Uint32.uint32)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf64_word_dict:(Uint32.uint32)show_class= ({ + + show_method = Uint32.to_string}) + +(** ELF signed word type: + * 4 byte signed type on 32-bit architectures. + * 4 byte signed type on 64-bit architectures. + *) + +(*type elf32_sword*) + +(*val string_of_elf32_sword : elf32_sword -> string*) + +(*val integer_of_elf32_sword : elf32_sword -> integer*) + +(*val elf32_sword_of_quad : byte -> byte -> byte -> byte -> elf32_sword*) + +(*val read_elf32_sword : endianness -> byte_sequence -> error (elf32_sword * byte_sequence)*) +let read_elf32_sword endian bs0:(Int32.t*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_4_bytes_le bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Ml_bindings.int32_of_quad b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_4_bytes_be bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Ml_bindings.int32_of_quad b4 b3 b2 b1, bs1)) + )) + +(*val quad_of_elf32_sword : elf32_sword -> (byte * byte * byte * byte)*) + +(*val bytes_of_elf32_sword : endianness -> elf32_sword -> list byte*) +let bytes_of_elf32_sword endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3) = (Ml_bindings.bytes_of_int32 w) in + [b0; b1; b2; b3] + | Big -> + let (b0, b1, b2, b3) = (Ml_bindings.bytes_of_int32 w) in + [b3; b2; b1; b0] + )) + +let instance_Show_Show_Elf_types_native_uint_elf32_sword_dict:(Int32.t)show_class= ({ + + show_method = Int32.to_string}) + +(** elf64_sword type and bindings *) + +(*type elf64_sword*) + +(*val string_of_elf64_sword : elf64_sword -> string*) + +(*val integer_of_elf64_sword : elf64_sword -> integer*) + +(*val elf64_sword_of_quad : byte -> byte -> byte -> byte -> elf64_sword*) + +(*val read_elf64_sword : endianness -> byte_sequence -> error (elf64_sword * byte_sequence)*) +let read_elf64_sword endian bs0:(Int32.t*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_4_bytes_le bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Ml_bindings.int32_of_quad b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_4_bytes_be bs0 >>= (fun ((b1, b2, b3, b4), bs1) -> + return (Ml_bindings.int32_of_quad b4 b3 b2 b1, bs1)) + )) + +(*val quad_of_elf64_sword : elf64_sword -> (byte * byte * byte * byte)*) + +(*val bytes_of_elf64_sword : endianness -> elf64_sword -> list byte*) +let bytes_of_elf64_sword endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3) = (Ml_bindings.bytes_of_int32 w) in + [b0; b1; b2; b3] + | Big -> + let (b0, b1, b2, b3) = (Ml_bindings.bytes_of_int32 w) in + [b3; b2; b1; b0] + )) + +let instance_Show_Show_Elf_types_native_uint_elf64_sword_dict:(Int32.t)show_class= ({ + + show_method = Int32.to_string}) + +(** ELF extra wide word type: + * 8 byte unsigned type on 64-bit architectures. + *) + +(*type elf64_xword*) + +(*val string_of_elf64_xword : elf64_xword -> string*) + +(*val natural_of_elf64_xword : elf64_xword -> natural*) + +(*val elf64_xword_of_oct : byte -> byte -> byte -> byte -> byte -> byte -> byte -> byte -> elf64_xword*) + +(*val read_elf64_xword : endianness -> byte_sequence -> error (elf64_xword * byte_sequence)*) +let read_elf64_xword endian bs0:(Uint64.uint64*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_8_bytes_le bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Uint64_wrapper.of_oct_native b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_8_bytes_be bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Uint64_wrapper.of_oct_native b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + )) + +(*val elf64_xword_rshift : elf64_xword -> nat -> elf64_xword*) + +(*val elf64_xword_lshift : elf64_xword -> nat -> elf64_xword*) + +(*val elf64_xword_land : elf64_xword -> elf64_xword -> elf64_xword*) + +(*val elf64_xword_lor : elf64_xword -> elf64_xword -> elf64_xword*) + +(*val elf64_xword_lxor : elf64_xword -> elf64_xword -> elf64_xword*) + +(*val elf64_xword_of_natural : natural -> elf64_xword*) + +(*val equal_elf64_xword : elf64_xword -> elf64_xword -> bool*) + +(*val oct_of_elf64_xword : elf64_xword -> (byte * byte * byte * byte * byte * byte * byte * byte)*) + +(*val bytes_of_elf64_xword : endianness -> elf64_xword -> list byte*) +let bytes_of_elf64_xword endian x:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Uint64_wrapper.to_bytes_native x) in + [b0; b1; b2; b3; b4; b5; b6; b7] + | Big -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Uint64_wrapper.to_bytes_native x) in + [b7; b6; b5; b4; b3; b2; b1; b0] + )) + +let instance_Basic_classes_Eq_Elf_types_native_uint_elf64_xword_dict:(Uint64.uint64)eq_class= ({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +let instance_Show_Show_Elf_types_native_uint_elf64_xword_dict:(Uint64.uint64)show_class= ({ + + show_method = Uint64.to_string}) + +(** ELF signed extra wide word type: + * 8 byte signed type on 64-bit architectures. + *) + +(*type elf64_sxword*) + +(*val string_of_elf64_sxword : elf64_sxword -> string*) + +(*val integer_of_elf64_sxword : elf64_sxword -> integer*) + +(*val elf64_sxword_of_integer : integer -> elf64_sxword*) + +(*val elf64_sxword_of_oct : byte -> byte -> byte -> byte -> byte -> byte -> byte -> byte -> elf64_sxword*) + +(*val read_elf64_sxword : endianness -> byte_sequence -> error (elf64_sxword * byte_sequence)*) +let read_elf64_sxword endian bs0:(Int64.t*byte_sequence)error= + ((match endian with + | Little -> + Byte_sequence.read_8_bytes_le bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Ml_bindings.int64_of_oct b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + | Big -> + Byte_sequence.read_8_bytes_be bs0 >>= (fun ((b1, b2, b3, b4, b5, b6, b7, b8), bs1) -> + return (Ml_bindings.int64_of_oct b8 b7 b6 b5 b4 b3 b2 b1, bs1)) + )) + +(*val oct_of_elf64_sxword : elf64_sxword -> (byte * byte * byte * byte * byte * byte * byte * byte)*) + +(*val bytes_of_elf64_sxword : endianness -> elf64_sxword -> list byte*) +let bytes_of_elf64_sxword endian w:(char)list= + ((match endian with + | Little -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Ml_bindings.bytes_of_int64 w) in + [b0; b1; b2; b3; b4; b5; b6; b7] + | Big -> + let (b0, b1, b2, b3, b4, b5, b6, b7) = (Ml_bindings.bytes_of_int64 w) in + [b7; b6; b5; b4; b3; b2; b1; b0] + )) + +let instance_Show_Show_Elf_types_native_uint_elf64_sxword_dict:(Int64.t)show_class= ({ + + show_method = Int64.to_string}) + +(*val natural_land : natural -> natural -> natural*) +(*let natural_land m n:natural= + (* For Isabelle backend...*) + natural_of_elf64_xword (elf64_xword_land (elf64_xword_of_natural m) (elf64_xword_of_natural n))*) + +(*val natural_lor : natural -> natural -> natural*) +(*let natural_lor m n:natural= + (* For Isabelle backend...*) + natural_of_elf64_xword (elf64_xword_lor (elf64_xword_of_natural m) (elf64_xword_of_natural n))*) + +(*val natural_lxor : natural -> natural -> natural*) +(*let natural_lxor m n:natural= + (* For Isabelle backend...*) + natural_of_elf64_xword (elf64_xword_lxor (elf64_xword_of_natural m) (elf64_xword_of_natural n))*) diff --git a/lib/ocaml_rts/linksem/endianness.ml b/lib/ocaml_rts/linksem/endianness.ml new file mode 100644 index 00000000..2821fc6a --- /dev/null +++ b/lib/ocaml_rts/linksem/endianness.ml @@ -0,0 +1,35 @@ +(*Generated by Lem from endianness.lem.*) +(** [endian.lem] defines a type for describing the endianness of an ELF file, + * and functions and other operations over that type. + *) + +open Lem_string +open Show + +(** Type [endianness] describes the endianness of an ELF file. This is deduced from + * the first few bytes (magic number, etc.) of the ELF header. + *) +type endianness + = Big (* Big endian *) + | Little (* Little endian *) + +(** [default_endianness] is a default endianness to use when reading in the ELF header + * before we have deduced from its entries what the rest of the file is encoded + * with. + *) +(*val default_endianness : endianness*) +let default_endianness:endianness= Little + +(** [string_of_endianness e] produces a string representation of the [endianness] value + * [e]. + *) +(*val string_of_endianness : endianness -> string*) +let string_of_endianness e:string= + ((match e with + | Big -> "Big" + | Little -> "Little" + )) + +let instance_Show_Show_Endianness_endianness_dict:(endianness)show_class= ({ + + show_method = string_of_endianness}) diff --git a/lib/ocaml_rts/linksem/error.ml b/lib/ocaml_rts/linksem/error.ml new file mode 100644 index 00000000..45f8a80b --- /dev/null +++ b/lib/ocaml_rts/linksem/error.ml @@ -0,0 +1,112 @@ +(*Generated by Lem from error.lem.*) +open Lem_basic_classes +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +open Show + +(** [error] is a type used to represent potentially failing computations. [Success] + * marks a successful completion of a computation, whilst [Fail err] marks a failure, + * with [err] as the reason. + *) +type 'a error + = Success of 'a + | Fail of string + +(** [return] is the monadic lifting function for [error], representing a successful + * computation. + *) +(*val return : forall 'a. 'a -> error 'a*) +let return r = (Success r) + +(*val with_success : forall 'a 'b. error 'a -> 'b -> ('a -> 'b) -> 'b*) +let with_success err fl suc = +((match err with + | Success s -> suc s + | Fail err -> fl + )) + +(** [fail err] represents a failing computation, with error message [err]. + *) +(*val fail : forall 'a. string -> error 'a*) +let fail err = (Fail err) + +(** [(>>=)] is the monadic binding function for [error]. + *) +(*val >>= : forall 'a 'b. error 'a -> ('a -> error 'b) -> error 'b*) +let (>>=) x f = +((match x with + | Success s -> f s + | Fail err -> Fail err + )) + +(** [as_maybe e] drops an [error] value into a [maybe] value, throwing away + * error information. + *) + +(*val as_maybe : forall 'a. error 'a -> maybe 'a*) +let as_maybe e = +((match e with + | Fail err -> None + | Success s -> Some s + )) + +(** [repeatM count action] fails if [action] is a failing computation, or + * successfully produces a list [count] elements long, where each element is + * the value successfully returned by [action]. + *) +(*val repeatM : forall 'a. natural -> error 'a -> error (list 'a)*) +let rec repeatM count action = +(if Nat_big_num.equal count(Nat_big_num.of_int 0) then + return [] + else + action >>= (fun head -> + repeatM ( Nat_big_num.sub_nat count(Nat_big_num.of_int 1)) action >>= (fun tail -> + return (head::tail)))) + +(** [repeatM' count seed action] is a variant of [repeatM] that acts like [repeatM] + * apart from any successful result returns a tuple whose second component is [seed] + * and whose first component is the same as would be returned by [repeatM]. + *) +(*val repeatM' : forall 'a 'b. natural -> 'b -> ('b -> error ('a * 'b)) -> error ((list 'a) * 'b)*) +let rec repeatM' count seed action = +(if Nat_big_num.equal count(Nat_big_num.of_int 0) then + return ([], seed) + else + action seed >>= (fun (head, seed) -> + repeatM' ( Nat_big_num.sub_nat count(Nat_big_num.of_int 1)) seed action >>= (fun (tail, seed) -> + return ((head::tail), seed)))) + +(** [mapM f xs] maps [f] across [xs], failing if [f] fails on any element of [xs]. + *) +(*val mapM : forall 'a 'b. ('a -> error 'b) -> list 'a -> error (list 'b)*) +let rec mapM f xs = +((match xs with + | [] -> return [] + | x::xs -> + f x >>= (fun hd -> + mapM f xs >>= (fun tl -> + return (hd::tl))) + )) + +(*val foldM : forall 'a 'b. ('a -> 'b -> error 'a) -> 'a -> list 'b -> error 'a*) +let rec foldM f e xs = +((match xs with + | [] -> return e + | x::xs -> f e x >>= (fun res -> foldM f res xs) + )) + +(** [string_of_error err] produces a string representation of [err]. + *) +(*val string_of_error : forall 'a. Show 'a => error 'a -> string*) +let string_of_error dict_Show_Show_a e = +((match e with + | Fail err -> "Fail: " ^ err + | Success s -> dict_Show_Show_a.show_method s + )) + +let instance_Show_Show_Error_error_dict dict_Show_Show_a =({ + + show_method = + (string_of_error dict_Show_Show_a)}) diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_abi.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_abi.ml new file mode 100644 index 00000000..7371547f --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_abi.ml @@ -0,0 +1,131 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_abi.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_num +open Lem_maybe +open Lem_assert_extra +open Show +open Missing_pervasives + +open Byte_sequence + +(* open import Abis *) + +open Elf_file +open Elf_header +open Elf_interpreted_segment +open Elf_interpreted_section +open Elf_program_header_table +open Elf_section_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation +open Elf_types_native_uint +open Memory_image + +(** Optional, like [stt_func] but always points to a function or piece of + * executable code that takes no arguments and returns a function pointer. + *) +let stt_gnu_ifunc : Nat_big_num.num= (Nat_big_num.of_int 10) + +(*val gnu_extend: forall 'abifeature. abi 'abifeature -> abi 'abifeature*) +let gnu_extend a:'abifeature abi= + ({ is_valid_elf_header = (a.is_valid_elf_header) + ; make_elf_header = +( (* t -> entry -> shoff -> phoff -> phnum -> shnum -> shstrndx -> hdr *)fun t -> fun entry -> fun shoff -> fun phoff -> fun phnum -> fun shnum -> fun shstrndx -> + let unmod = (a.make_elf_header t entry shoff phoff phnum shnum shstrndx) + in + { elf64_ident = ((match unmod.elf64_ident with + i0 :: i1 :: i2 :: i3 :: i4 :: i5 :: i6 :: + _ :: _ :: i9 :: i10 :: i11 :: i12 :: i13 :: i14 :: i15 :: [] + -> [i0; i1; i2; i3; i4; i5; i6; + Uint32.of_string (Nat_big_num.to_string elf_osabi_gnu); + Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 1)); + i9; i10; i11; i12; i13; i14; i15] + )) + ; elf64_type = (Uint32.of_string (Nat_big_num.to_string t)) + ; elf64_machine = (unmod.elf64_machine) + ; elf64_version = (unmod.elf64_version) + ; elf64_entry = (unmod.elf64_entry) + ; elf64_phoff = (Uint64.of_string (Nat_big_num.to_string phoff)) + ; elf64_shoff = (Uint64.of_string (Nat_big_num.to_string shoff)) + ; elf64_flags = (unmod.elf64_flags) + ; elf64_ehsize = (unmod.elf64_ehsize) + ; elf64_phentsize= (unmod.elf64_phentsize) + ; elf64_phnum = (Uint32.of_string (Nat_big_num.to_string phnum)) + ; elf64_shentsize= (unmod.elf64_shentsize) + ; elf64_shnum = (Uint32.of_string (Nat_big_num.to_string shnum)) + ; elf64_shstrndx = (Uint32.of_string (Nat_big_num.to_string shstrndx)) + }) + ; reloc = (a.reloc) + ; section_is_special = (fun isec1 -> (fun img2 -> ( + a.section_is_special isec1 img2 + || ( +(Lem.option_equal (=)(Ml_bindings.string_prefix (Nat_big_num.of_int (String.length ".gnu.warning")) isec1.elf64_section_name_as_string) (Some(".gnu.warning")))) + (* FIXME: This is a slight abuse. The GNU linker's treatment of + * ".gnu.warning.*" section is not really a function of the output + * ABI -- it's a function of the input ABI, or arguably perhaps just + * of the linker itself. We have to do something to make sure these + * sections get silently processed separately from the usual linker + * control script, because otherwise our link map output doesn't match + * the GNU linker's. By declaring these sections "special" we achieve + * this by saying they don't participate in linking proper, just like + * ".symtab" and similar sections don't. HMM. I suppose this is + * okay, in that although a non-GNU linker might happily link these + * sections, arguably that is a failure to understand the input files. + * But the issue about it being a per-input-file property remains. + * Q. What does the GNU linker do if a reloc input file whose OSABI + * is *not* GNU contains a .gnu.warning.* section? That would be a fair + * test about whether looking at the input ABI is worth doing. *) + ))) + ; section_is_large = (a.section_is_large) + ; maxpagesize = (a.maxpagesize) + ; minpagesize = (a.minpagesize) + ; commonpagesize = (a.commonpagesize) + ; symbol_is_generated_by_linker = (a.symbol_is_generated_by_linker) + ; make_phdrs = (a.make_phdrs) (* FIXME: also make the GNU phdrs! *) + ; max_phnum = (Nat_big_num.add(Nat_big_num.of_int 1) a.max_phnum) (* FIXME: GNU_RELRO, GNU_STACK; what else? *) + ; guess_entry_point = (a.guess_entry_point) + ; pad_data = (a.pad_data) + ; pad_code = (a.pad_code) + ; generate_support = (fun input_fnames_and_imgs -> + let vanilla_support_img = (a.generate_support input_fnames_and_imgs) in + (* also generate .note.gnu.build-id *) + let new_by_range = (Pset.add (Some(".note.gnu.build-id", (Nat_big_num.of_int 0,Nat_big_num.of_int 24)), FileFeature(ElfSection(Nat_big_num.of_int 4 (* HACK: calculate this *), + { elf64_section_name =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_type = sht_note + ; elf64_section_flags = shf_alloc + ; elf64_section_addr =(Nat_big_num.of_int 0) (* ignored -- covered by element *) + ; elf64_section_offset =(Nat_big_num.of_int 0) (* ignored -- will be replaced when file offsets are assigned *) + ; elf64_section_size =(Nat_big_num.of_int 24) (* ignored? NO, we use it in linker_script to avoid plumbing through the element record *) + ; elf64_section_link =(Nat_big_num.of_int 0) + ; elf64_section_info =(Nat_big_num.of_int 0) + ; elf64_section_align =(Nat_big_num.of_int 4) + ; elf64_section_entsize =(Nat_big_num.of_int 0) + ; elf64_section_body = Byte_sequence.empty (* ignored *) + ; elf64_section_name_as_string = ".note.gnu.build-id" + } + ))) vanilla_support_img.by_range) + in + { elements = (Pmap.add ".note.gnu.build-id" { + startpos = None + ; length1 = (Some(Nat_big_num.of_int 24)) + ; contents = ([]) + } (vanilla_support_img.elements)) + ; by_tag = (by_tag_from_by_range + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) instance_Basic_classes_SetType_var_dict new_by_range) + ; by_range = new_by_range + }) + ; concretise_support = (a.concretise_support) + ; get_reloc_symaddr = (a.get_reloc_symaddr) + }) diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_dynamic.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_dynamic.ml new file mode 100644 index 00000000..e2957380 --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_dynamic.ml @@ -0,0 +1,531 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_dynamic.lem.*) +(** [gnu_ext_dynamic] contains GNU extension specific definitions related to the + * .dynamic section of an ELF file. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_num +open Lem_string + +open Error +open Show +open String_table + +open Elf_dynamic +open Elf_types_native_uint + +(** Additional dynamic entries, see LSB section 11.3.2.2. + * All values taken from elf.c from binutils and GLIBC as the LSB does not + * specify them. + * + * 98 #define OLD_DT_LOOS 0x60000000 + * 99 #define DT_LOOS 0x6000000d + * 100 #define DT_HIOS 0x6ffff000 + * 101 #define DT_VALRNGLO 0x6ffffd00 + * 102 #define DT_VALRNGHI 0x6ffffdff + * 103 #define DT_ADDRRNGLO 0x6ffffe00 + * 104 #define DT_ADDRRNGHI 0x6ffffeff + * 105 #define DT_VERSYM 0x6ffffff0 + * 106 #define DT_RELACOUNT 0x6ffffff9 + * 107 #define DT_RELCOUNT 0x6ffffffa + * 108 #define DT_FLAGS_1 0x6ffffffb + * 109 #define DT_VERDEF 0x6ffffffc + * 110 #define DT_VERDEFNUM 0x6ffffffd + * 111 #define DT_VERNEED 0x6ffffffe + * 112 #define DT_VERNEEDNUM 0x6fffffff + * 113 #define OLD_DT_HIOS 0x6fffffff + * 114 #define DT_LOPROC 0x70000000 + * 115 #define DT_HIPROC 0x7fffffff + *) + +let elf_dt_gnu_addrrnghi : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939523967)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffeff*) +let elf_dt_gnu_addrrnglo : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939523840)(Nat_big_num.of_int 2)) (*0x6ffffe00*) +let elf_dt_gnu_auxiliary : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 1073741822)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x7ffffffd*) +let elf_dt_gnu_filter : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 1073741823)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x7fffffff*) +(** The following is "specified" in the LSB document but is not present in the + * elf.c file so taken from elf.h from GLIBC: + *) +let elf_dt_gnu_num : Nat_big_num.num= (Nat_big_num.of_int 32) (** ??? This should match something *) +let elf_dt_gnu_posflag_1 : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939523838)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffdfd*) +let elf_dt_gnu_relcount : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939524093)(Nat_big_num.of_int 2)) (*0x6ffffffa*) +let elf_dt_gnu_relacount : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524092)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6FFFFFF9*) +let elf_dt_gnu_syminent : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939523839)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffdff*) +let elf_dt_gnu_syminfo : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939523967)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffeff*) +let elf_dt_gnu_syminsz : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939523839)(Nat_big_num.of_int 2)) (*0x6ffffdfe*) +let elf_dt_gnu_valrnghi : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939523839)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffdff*) +let elf_dt_gnu_valrnglo : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 939523712)(Nat_big_num.of_int 2)) (*0x6ffffd00*) +let elf_dt_gnu_verdef : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939524094)(Nat_big_num.of_int 2)) (*0x6ffffffc*) +let elf_dt_gnu_verdefnum : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524094)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffffd*) +let elf_dt_gnu_verneed : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939524095)(Nat_big_num.of_int 2)) (*0x6ffffffe*) +let elf_dt_gnu_verneednum : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524095)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6fffffff*) +let elf_dt_gnu_versym : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 939524088)(Nat_big_num.of_int 2)) (*0x6ffffff0*) + +(** Not present in the LSB but turns up in "real" ELF files... *) + +let elf_dt_gnu_hash : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939523962)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffef5*) +let elf_dt_gnu_flags_1 : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 939524093)(Nat_big_num.of_int 2))(Nat_big_num.of_int 1)) (*0x6ffffffb*) +let elf_dt_gnu_checksum : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 939523836)(Nat_big_num.of_int 2)) (* 0x6FFFFDF8 *) +let elf_dt_gnu_prelinked : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939523834))(Nat_big_num.of_int 1)) (* 0x6FFFFDF5 *) + +(** Extended DT flags for FLAGS_1 dynamic section types. Taken from GLibC source + * as they appear to be completely unspecified! + *) + +let gnu_df_1_now : Nat_big_num.num= (Nat_big_num.of_int 1) (*0x00000001*) +let gnu_df_1_global : Nat_big_num.num= (Nat_big_num.of_int 2) (*0x00000002*) +let gnu_df_1_group : Nat_big_num.num= (Nat_big_num.of_int 4) (*0x00000004*) +let gnu_df_1_nodelete : Nat_big_num.num= (Nat_big_num.of_int 8) (*0x00000008*) +let gnu_df_1_loadfltr : Nat_big_num.num= (Nat_big_num.of_int 16) (*0x00000010*) +let gnu_df_1_initfirst : Nat_big_num.num= (Nat_big_num.of_int 32) (*0x00000020*) +let gnu_df_1_noopen : Nat_big_num.num= (Nat_big_num.of_int 64) (*0x00000040*) +let gnu_df_1_origin : Nat_big_num.num= (Nat_big_num.of_int 128) (*0x00000080*) +let gnu_df_1_direct : Nat_big_num.num= (Nat_big_num.of_int 256) (*0x00000100*) +let gnu_df_1_trans : Nat_big_num.num= (Nat_big_num.of_int 512) (*0x00000200*) +let gnu_df_1_interpose : Nat_big_num.num= (Nat_big_num.of_int 1024) (*0x00000400*) +let gnu_df_1_nodeflib : Nat_big_num.num= (Nat_big_num.of_int 2048) (*0x00000800*) +let gnu_df_1_nodump : Nat_big_num.num= (Nat_big_num.of_int 4096) (*0x00001000*) +let gnu_df_1_confalt : Nat_big_num.num= (Nat_big_num.of_int 8192) (*0x00002000*) +let gnu_df_1_endfiltee : Nat_big_num.num= (Nat_big_num.of_int 16384) (*0x00004000*) +let gnu_df_1_dispreldne : Nat_big_num.num= (Nat_big_num.of_int 32768) (*0x00008000*) +let gnu_df_1_disprelpnd : Nat_big_num.num= (Nat_big_num.of_int 65536) (*0x00010000*) + +(** [gnu_string_of_dt_flag1 m] produces a string based representation of GNU + * extensions flag_1 value [m]. + *) +(*val gnu_string_of_dt_flag_1 : natural -> string*) +let gnu_string_of_dt_flag_1 flag:string= + (if check_flag flag(Nat_big_num.of_int 0) then + "None" + else if check_flag flag gnu_df_1_now then + "NOW" + else if check_flag flag gnu_df_1_global then + "GLOBAL" + else if check_flag flag gnu_df_1_group then + "GROUP" + else if check_flag flag gnu_df_1_nodelete then + "NODELETE" + else if check_flag flag gnu_df_1_loadfltr then + "LOADFLTR" + else if check_flag flag gnu_df_1_initfirst then + "INITFIRST" + else if check_flag flag gnu_df_1_noopen then + "NOOPEN" + else if check_flag flag gnu_df_1_origin then + "ORIGIN" + else if check_flag flag gnu_df_1_direct then + "DIRECT" + else if check_flag flag gnu_df_1_trans then + "TRANS" + else if check_flag flag gnu_df_1_interpose then + "INTERPOSE" + else if check_flag flag gnu_df_1_nodeflib then + "NODEFLIB" + else if check_flag flag gnu_df_1_nodump then + "NODUMP" + else if check_flag flag gnu_df_1_confalt then + "CONFALT" + else if check_flag flag gnu_df_1_endfiltee then + "ENDFILTEE" + else if check_flag flag gnu_df_1_dispreldne then + "DISPRELDNE" + else if check_flag flag gnu_df_1_disprelpnd then + "DISPRELPND" + else if check_flag flag ( Nat_big_num.add gnu_df_1_nodelete gnu_df_1_now) then + "NOW NODELETE" + else if check_flag flag ( Nat_big_num.add gnu_df_1_nodelete gnu_df_1_initfirst) then + "NODELETE INITFIRST" + else (* XXX: add more as necessary *) + "Invalid GNU dynamic flag") + +(** [gnu_ext_os_additional_ranges m] checks whether dynamic section type [m] + * lies within the ranges set aside for GNU specific functionality. + * NB: quite ad hoc as this is not properly specified anywhere. + *) +(*val gnu_ext_os_additional_ranges : natural -> bool*) +let gnu_ext_os_additional_ranges m:bool= + (if Nat_big_num.greater_equal m elf_dt_gnu_addrrnglo && Nat_big_num.less_equal m elf_dt_gnu_addrrnghi then + true + else Nat_big_num.equal (* ad hoc extensions go here... *) + m elf_dt_gnu_verneed || (Nat_big_num.equal + m elf_dt_gnu_verneednum || (Nat_big_num.equal + m elf_dt_gnu_versym || (Nat_big_num.equal + m elf_dt_gnu_verdef || (Nat_big_num.equal + m elf_dt_gnu_verdefnum || (Nat_big_num.equal + m elf_dt_gnu_flags_1 || (Nat_big_num.equal + m elf_dt_gnu_relcount || (Nat_big_num.equal + m elf_dt_gnu_relacount || (Nat_big_num.equal + m elf_dt_gnu_checksum || Nat_big_num.equal + m elf_dt_gnu_prelinked))))))))) + +(** [gnu_ext_tag_correspondence_of_tag0 m] produces a tag correspondence for the + * extended GNU-specific dynamic section types [m]. Used to provide the ABI + * specific functionality expected of the corresponding function in the elf_dynamic + * module. + *) +(*val gnu_ext_tag_correspondence_of_tag0 : natural -> error tag_correspondence*) +let gnu_ext_tag_correspondence_of_tag0 m:(tag_correspondence)error= + (if Nat_big_num.equal m elf_dt_gnu_hash then + return C_Ptr + else if Nat_big_num.equal m elf_dt_gnu_flags_1 then + return C_Val + else if Nat_big_num.equal m elf_dt_gnu_versym then + return C_Ptr + else if Nat_big_num.equal m elf_dt_gnu_verneednum then + return C_Val + else if Nat_big_num.equal m elf_dt_gnu_verneed then + return C_Ptr + else if Nat_big_num.equal m elf_dt_gnu_verdef then + return C_Ptr + else if Nat_big_num.equal m elf_dt_gnu_verdefnum then + return C_Val + else if Nat_big_num.equal m elf_dt_gnu_relcount then + return C_Val + else if Nat_big_num.equal m elf_dt_gnu_relacount then + return C_Val + else if Nat_big_num.equal m elf_dt_gnu_checksum then + return C_Val + else if Nat_big_num.equal m elf_dt_gnu_prelinked then + return C_Val + else + fail "gnu_ext_tag_correspondence_of_tag0: invalid dynamic tag") + +(** [gnu_ext_tag_correspondence_of_tag m] produces a tag correspondence for the + * extended GNU-specific dynamic section types [m]. Used to provide the ABI + * specific functionality expected of the corresponding function in the elf_dynamic + * module. + * TODO: examine whether this and the function above really need separating into + * two functions. + *) +(*val gnu_ext_tag_correspondence_of_tag : natural -> error tag_correspondence*) +let gnu_ext_tag_correspondence_of_tag m:(tag_correspondence)error= + (if Nat_big_num.greater_equal m elf_dt_gnu_addrrnglo && Nat_big_num.less_equal m elf_dt_gnu_addrrnghi then + return C_Ptr + else if Nat_big_num.greater_equal m elf_dt_gnu_valrnglo && Nat_big_num.less_equal m elf_dt_gnu_valrnghi then + return C_Val + else if gnu_ext_os_additional_ranges m then + gnu_ext_tag_correspondence_of_tag0 m + else if Nat_big_num.equal m elf_dt_gnu_syminsz then + return C_Val (** unsure *) + else if Nat_big_num.equal m elf_dt_gnu_syminfo then + return C_Ptr (** unsure *) + else if Nat_big_num.equal m elf_dt_gnu_syminent then + return C_Val (** unsure *) + else if Nat_big_num.equal m elf_dt_gnu_posflag_1 then + return C_Val (** unsure *) + else if Nat_big_num.equal m elf_dt_gnu_num then + return C_Ignored + else if Nat_big_num.equal m elf_dt_gnu_filter then + return C_Val (** unsure *) + else if Nat_big_num.equal m elf_dt_gnu_auxiliary then + return C_Val (** unsure *) + else + fail ("gnu_ext_tag_correspondence_of_tag: unrecognised GNU dynamic tag")) + +(** [gnu_ext_elf32_value_of_elf32_dyn0 dyn] extracts a dynamic value from the + * dynamic section entry [dyn] under the assumption that its type is a GNU + * extended dynamic section type. Fails otherwise. Used to provide the + * ABI-specific functionality expected of the corresponding functions in + * elf_dynamic.lem. + *) +(*val gnu_ext_elf32_value_of_elf32_dyn0 : elf32_dyn -> string_table -> error elf32_dyn_value*) +let gnu_ext_elf32_value_of_elf32_dyn0 dyn stbl:(((Uint32.uint32),(Uint32.uint32))dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int32 dyn.elf32_dyn_tag)) in + if Nat_big_num.equal tag elf_dt_gnu_hash then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf32_value_of_elf32_dyn: GNU_HASH must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: GNU_HASH must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_flags_1 then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: FLAGS_1 must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: FlAGS_1 must be a Val" + ) >>= (fun f -> + return (Flags1 (Nat_big_num.of_string (Uint32.to_string f)))) + else if Nat_big_num.equal tag elf_dt_gnu_versym then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERSYM must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERSYM must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_verdef then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERDEF must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERDEF must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_verdefnum then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERDEFNUM must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERDEFNUM must be a Val" + ) >>= (fun sz -> + return (Numeric (Nat_big_num.of_string (Uint32.to_string sz)))) + else if Nat_big_num.equal tag elf_dt_gnu_verneednum then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERNEEDNUM must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERNEEDNUM must be a Val" + ) >>= (fun sz -> + return (Numeric (Nat_big_num.of_string (Uint32.to_string sz)))) + else if Nat_big_num.equal tag elf_dt_gnu_verneed then + (match dyn.elf32_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERNEED must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: VERNEED must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_relcount then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: RELCOUNT must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: RELCOUNT must be a Val" + ) >>= (fun sz -> + return (Numeric (Nat_big_num.of_string (Uint32.to_string sz)))) + else if Nat_big_num.equal tag elf_dt_gnu_relacount then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: RELACOUNT must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: RELACOUNT must be a Val" + ) >>= (fun sz -> + return (Numeric (Nat_big_num.of_string (Uint32.to_string sz)))) + else if Nat_big_num.equal tag elf_dt_gnu_checksum then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: CHECKSUM must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: CHECKSUM must be a Val" + ) >>= (fun sz -> + return (Checksum (Nat_big_num.of_string (Uint32.to_string sz)))) + else if Nat_big_num.equal tag elf_dt_gnu_prelinked then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: GNU_PRELINKED must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: GNU_PRELINKED must be a Val" + ) >>= (fun off -> + return (Timestamp (Nat_big_num.of_string (Uint32.to_string off)))) + else + fail "gnu_ext_elf32_value_of_elf32_dyn0: unrecognised GNU dynamic tag") + +(** [gnu_ext_elf64_value_of_elf64_dyn0 dyn] extracts a dynamic value from the + * dynamic section entry [dyn] under the assumption that its type is a GNU + * extended dynamic section type. Fails otherwise. Used to provide the + * ABI-specific functionality expected of the corresponding functions in + * elf_dynamic.lem. + *) +(*val gnu_ext_elf64_value_of_elf64_dyn0 : elf64_dyn -> string_table -> error elf64_dyn_value*) +let gnu_ext_elf64_value_of_elf64_dyn0 dyn stbl:(((Uint64.uint64),(Uint64.uint64))dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int64 dyn.elf64_dyn_tag)) in + if Nat_big_num.equal tag elf_dt_gnu_hash then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf64_value_of_elf64_dyn: GNU_HASH must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: GNU_HASH must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_flags_1 then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: FLAGS_1 must be a Val" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: FlAGS_1 must be a Val" + ) >>= (fun f -> + return (Flags1 (Ml_bindings.nat_big_num_of_uint64 f))) + else if Nat_big_num.equal tag elf_dt_gnu_versym then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERSYM must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERSYM must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_verdef then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERDEF must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERDEF must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_verdefnum then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf64_dyn: VERDEFNUM must be a Val" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf64_dyn: VERDEFNUM must be a Val" + ) >>= (fun sz -> + return (Numeric (Ml_bindings.nat_big_num_of_uint64 sz))) + else if Nat_big_num.equal tag elf_dt_gnu_verneednum then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERNEEDNUM must be a Val" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERNEEDNUM must be a Val" + ) >>= (fun sz -> + return (Numeric (Ml_bindings.nat_big_num_of_uint64 sz))) + else if Nat_big_num.equal tag elf_dt_gnu_verneed then + (match dyn.elf64_dyn_d_un with + | D_Val v -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERNEED must be a PTR" + | D_Ptr p -> return p + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: VERNEED must be a PTR" + ) >>= (fun addr -> + return (Address addr)) + else if Nat_big_num.equal tag elf_dt_gnu_relcount then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: RELCOUNT must be a Val" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: RELCOUNT must be a Val" + ) >>= (fun sz -> + return (Numeric (Ml_bindings.nat_big_num_of_uint64 sz))) + else if Nat_big_num.equal tag elf_dt_gnu_relacount then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: RELACOUNT must be a Val" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: RELACOUNT must be a Val" + ) >>= (fun sz -> + return (Numeric (Ml_bindings.nat_big_num_of_uint64 sz))) + else if Nat_big_num.equal tag elf_dt_gnu_checksum then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: CHECKSUM must be a Val" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: CHECKSUM must be a Val" + ) >>= (fun sz -> + return (Checksum (Ml_bindings.nat_big_num_of_uint64 sz))) + else if Nat_big_num.equal tag elf_dt_gnu_prelinked then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: GNU_PRELINKED must be a Val" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: GNU_PRELINKED must be a Val" + ) >>= (fun off -> + return (Timestamp (Ml_bindings.nat_big_num_of_uint64 off))) + else + fail "gnu_ext_elf64_value_of_elf64_dyn0: unrecognised GNU dynamic tag") + +(** [gnu_ext_elf32_value_of_elf32_dyn dyn] extracts a dynamic value from the + * dynamic section entry [dyn] under the assumption that its type is a GNU + * extended dynamic section type. Fails otherwise. Used to provide the + * ABI-specific functionality expected of the corresponding functions in + * elf_dynamic.lem. + * TODO: some of these cases are missing as they have never come up in "real" + * ELF files that have been processed as part of validation. Try and find some + * files that do actually exhibit these. + *) +(*val gnu_ext_elf32_value_of_elf32_dyn : elf32_dyn -> string_table -> error elf32_dyn_value*) +let gnu_ext_elf32_value_of_elf32_dyn dyn stbl:(elf32_dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int32 dyn.elf32_dyn_tag)) in + if gnu_ext_os_additional_ranges tag then (* this should cover valrngs and addrrngs *) + gnu_ext_elf32_value_of_elf32_dyn0 dyn stbl + else if Nat_big_num.equal tag elf_dt_gnu_syminsz then + (match dyn.elf32_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf32_value_of_elf32_dyn: SYMINSZ must be a VAL" + | D_Ignored i -> fail "gnu_ext_elf32_value_of_elf32_dyn: SYMINSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag elf_dt_gnu_syminfo then + fail "SYMINFO" (* XXX: never seen in 32-bit ELF *) + else if Nat_big_num.equal tag elf_dt_gnu_syminent then + fail "SYMINENT" (* XXX: never seen in 32-bit ELF *) + else if Nat_big_num.equal tag elf_dt_gnu_posflag_1 then + fail "POSFLAG_1" (* XXX: never seen in 32-bit ELF *) + else if Nat_big_num.equal tag elf_dt_gnu_num then + fail "NUM" (* XXX: never seen in 32-bit ELF *) + else if Nat_big_num.equal tag elf_dt_gnu_filter then + fail "FILTER" (* XXX: never seen in 32-bit ELF *) + else if Nat_big_num.equal tag elf_dt_gnu_auxiliary then + fail "AUXILIARY" (* XXX: never seen in 32-bit ELF *) + else + fail "gnu_ext_elf32_value_of_elf32_dyn: unrecognised GNU dynamic tag") + +(** [gnu_ext_elf64_value_of_elf64_dyn dyn] extracts a dynamic value from the + * dynamic section entry [dyn] under the assumption that its type is a GNU + * extended dynamic section type. Fails otherwise. Used to provide the + * ABI-specific functionality expected of the corresponding functions in + * elf_dynamic.lem. + * TODO: some of these cases are missing as they have never come up in "real" + * ELF files that have been processed as part of validation. Try and find some + * files that do actually exhibit these. + *) +(*val gnu_ext_elf64_value_of_elf64_dyn : elf64_dyn -> string_table -> error elf64_dyn_value*) +let gnu_ext_elf64_value_of_elf64_dyn dyn stbl:(elf64_dyn_value)error= + (let tag = (Nat_big_num.abs (Nat_big_num.of_int64 dyn.elf64_dyn_tag)) in + if gnu_ext_os_additional_ranges tag then (* this should cover valrngs and addrrngs *) + gnu_ext_elf64_value_of_elf64_dyn0 dyn stbl + else if Nat_big_num.equal tag elf_dt_gnu_syminsz then + (match dyn.elf64_dyn_d_un with + | D_Val v -> return v + | D_Ptr p -> fail "gnu_ext_elf64_value_of_elf64_dyn: SYMINSZ must be a VAL" + | D_Ignored i -> fail "gnu_ext_elf64_value_of_elf64_dyn: SYMINSZ must be a VAL" + ) >>= (fun sz -> + return (Size sz)) + else if Nat_big_num.equal tag elf_dt_gnu_syminfo then + fail "SYMINFO" (* XXX: fill in as seen *) + else if Nat_big_num.equal tag elf_dt_gnu_syminent then + fail "SYMINENT" (* XXX: fill in as seen *) + else if Nat_big_num.equal tag elf_dt_gnu_posflag_1 then + fail "POSFLAG_1" (* XXX: fill in as seen *) + else if Nat_big_num.equal tag elf_dt_gnu_num then + fail "NUM" (* XXX: fill in as seen *) + else if Nat_big_num.equal tag elf_dt_gnu_filter then + fail "FILTER" (* XXX: fill in as seen *) + else if Nat_big_num.equal tag elf_dt_gnu_auxiliary then + fail "AUXILIARY" (* XXX: fill in as seen *) + else + fail "gnu_ext_elf64_value_of_elf64_dyn: unrecognised GNU dynamic tag") + +(** [string_of_gnu_ext_dynamic_tag0 m] produces a string based representation of + * GNU extensions dynamic tag value [m]. + *) +(*val string_of_gnu_ext_dynamic_tag0 : natural -> string*) +let string_of_gnu_ext_dynamic_tag0 m:string= + (if Nat_big_num.equal m elf_dt_gnu_hash then + "GNU_HASH" + else if Nat_big_num.equal m elf_dt_gnu_flags_1 then + "FLAGS_1" + else if Nat_big_num.equal m elf_dt_gnu_versym then + "VERSYM" + else if Nat_big_num.equal m elf_dt_gnu_verneednum then + "VERNEEDNUM" + else if Nat_big_num.equal m elf_dt_gnu_verneed then + "VERNEED" + else if Nat_big_num.equal m elf_dt_gnu_relcount then + "RELCOUNT" + else if Nat_big_num.equal m elf_dt_gnu_relacount then + "RELACOUNT" + else if Nat_big_num.equal m elf_dt_gnu_verdefnum then + "VERDEFNUM" + else if Nat_big_num.equal m elf_dt_gnu_verdef then + "VERDEF" + else if Nat_big_num.equal m elf_dt_gnu_checksum then + "CHECKSUM" + else if Nat_big_num.equal m elf_dt_gnu_prelinked then + "GNU_PRELINKED" + else + "Invalid dynamic tag") + +(** [string_of_gnu_ext_dynamic_tag m] produces a string based representation of + * GNU extensions dynamic tag value [m]. + *) +(*val string_of_gnu_ext_dynamic_tag : natural -> string*) +let string_of_gnu_ext_dynamic_tag m:string= + (if Nat_big_num.greater_equal m elf_dt_gnu_addrrnglo && Nat_big_num.less_equal m elf_dt_gnu_addrrnghi then + string_of_gnu_ext_dynamic_tag0 m + else if Nat_big_num.greater_equal m elf_dt_gnu_valrnglo && Nat_big_num.less_equal m elf_dt_gnu_valrnghi then + string_of_gnu_ext_dynamic_tag0 m + else if gnu_ext_os_additional_ranges m then + string_of_gnu_ext_dynamic_tag0 m + else if Nat_big_num.equal m elf_dt_gnu_syminsz then + "SYMINSZ" + else if Nat_big_num.equal m elf_dt_gnu_syminfo then + "SYMINFO" + else if Nat_big_num.equal m elf_dt_gnu_syminent then + "SYMINENT" + else if Nat_big_num.equal m elf_dt_gnu_posflag_1 then + "POSFLAG_1" + else if Nat_big_num.equal m elf_dt_gnu_num then + "NUM" + else if Nat_big_num.equal m elf_dt_gnu_filter then + "FILTER" + else if Nat_big_num.equal m elf_dt_gnu_auxiliary then + "AUXILIARY" + else + "Invalid dynamic tag") diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_note.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_note.ml new file mode 100644 index 00000000..f8f4328f --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_note.ml @@ -0,0 +1,268 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_note.lem.*) +(** [gnu_ext_note] contains GNU extension specific definitions relating to the + * .note section/segment of an ELF file. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_maybe +open Lem_string + +open Byte_sequence +open Endianness +open Error +open Missing_pervasives +open String_table + +open Elf_note +open Elf_section_header_table +open Elf_types_native_uint + +open Gnu_ext_section_header_table + +(** The following two functions are utility functions to convert a list of bytes + * into words, ready for further processing into strings. + *) + +(*val group_elf32_words : endianness -> list byte -> error (list elf32_word)*) +let rec group_elf32_words endian xs:((Uint32.uint32)list)error= + ((match xs with + | [] -> return [] + | x1::x2::x3::x4::xs -> + let bs0 = (Byte_sequence.from_byte_lists [[x1;x2;x3;x4]]) in + read_elf32_word endian bs0 >>= (fun (w, _) -> + group_elf32_words endian xs >>= (fun ws -> + return (w::ws))) + | xs -> fail "group_elf32_words: the impossible happened" + )) + +(*val group_elf64_words : endianness -> list byte -> error (list elf64_word)*) +let rec group_elf64_words endian xs:((Uint32.uint32)list)error= + ((match xs with + | [] -> return [] + | x1::x2::x3::x4::xs -> + let bs0 = (Byte_sequence.from_byte_lists [[x1;x2;x3;x4]]) in + read_elf64_word endian bs0 >>= (fun (w, _) -> + group_elf64_words endian xs >>= (fun ws -> + return (w::ws))) + | xs -> fail "group_elf64_words: the impossible happened" + )) + +(** [gnu_ext_check_elf32_abi_note_tag_section endain sht stbl bs0] checks the + * .note.ABI-tag section of an ELF file to ensure conformance with the GNU + * extensions. The string in this note should contain the string "GNU". + *) +(*val gnu_ext_check_elf32_abi_note_tag_section : endianness -> elf32_section_header_table -> + string_table -> byte_sequence -> bool*) +let gnu_ext_check_elf32_abi_note_tag_section endian sht sect_hdr_tbl bs0:bool= + (let abi_note_sects = +(List.filter (fun x -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_type)) sht_note then + let nm = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_name)) in + (match String_table.get_string_at nm sect_hdr_tbl with + | Success name1 -> name1 = ".note.ABI-tag" + | Fail _ -> false + ) + else + false + ) sht) + in + (match abi_note_sects with + | [note] -> + let off = (Nat_big_num.of_string (Uint32.to_string note.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string note.elf32_sh_size)) in + let abi_tag = +(Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + Elf_note.read_elf32_note endian rel >>= (fun (abi_tag, _) -> + return abi_tag))) + in + (match abi_tag with + | Fail _ -> false + | Success abi_tag -> + let str = (name_string_of_elf32_note abi_tag) in + if str = "GNU\000" then + if Nat_big_num.greater_equal (Nat_big_num.of_string (Uint32.to_string abi_tag.elf32_note_descsz))(Nat_big_num.of_int 16) then + let take2 = (Lem_list.take( 16) abi_tag.elf32_note_desc) in + if List.length take2 < 16 then + false + else + true + else + false + else + false + ) + | _ -> + false + )) + +(** [gnu_ext_check_elf64_abi_note_tag_section endain sht stbl bs0] checks the + * .note.ABI-tag section of an ELF file to ensure conformance with the GNU + * extensions. The string in this note should contain the string "GNU". + *) +(*val gnu_ext_check_elf64_abi_note_tag_section : endianness -> elf64_section_header_table -> + string_table -> byte_sequence -> bool*) +let gnu_ext_check_elf64_abi_note_tag_section endian sht sect_hdr_tbl bs0:bool= + (let abi_note_sects = +(List.filter (fun x -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string x.elf64_sh_type)) sht_note then + let nm = (Nat_big_num.of_string (Uint32.to_string x.elf64_sh_name)) in + (match String_table.get_string_at nm sect_hdr_tbl with + | Success name1 -> name1 = ".note.ABI-tag" + | Fail _ -> false + ) + else + false + ) sht) + in + (match abi_note_sects with + | [note] -> + let off = (Nat_big_num.of_string (Uint64.to_string note.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 note.elf64_sh_size) in + let abi_tag = +(Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + Elf_note.read_elf64_note endian rel >>= (fun (abi_tag, _) -> + return abi_tag))) + in + (match abi_tag with + | Fail _ -> false + | Success abi_tag -> + let str = (name_string_of_elf64_note abi_tag) in + if str = "GNU\000" then + if Nat_big_num.greater_equal (Ml_bindings.nat_big_num_of_uint64 abi_tag.elf64_note_descsz)(Nat_big_num.of_int 16) then + let take2 = (Lem_list.take( 16) abi_tag.elf64_note_desc) in + if List.length take2 < 16 then + false + else + true + else + false + else + false + ) + | _ -> + false + )) + +(** [gnu_ext_extract_elf32_earliest_compatible_kernel end sht stab bs0] extracts + * the earliest compatible Linux kernel with the given ELF file from its section + * header table [sht], and string table [stbl], assuming endianness [endian]. + * NB: marked as OCaml only as need to extract a string from integers. + * TODO: implement some string parsing functions in Isabelle/HOL so things like + * this can be extracted. + *) +(*val gnu_ext_extract_elf32_earliest_compatible_kernel : endianness -> elf32_section_header_table -> + string_table -> byte_sequence -> error string*) +let gnu_ext_extract_elf32_earliest_compatible_kernel endian sht sect_hdr_tbl bs0:(string)error= + (let abi_note_sects = +(List.filter (fun x -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_type)) sht_note then + let nm = (Nat_big_num.of_string (Uint32.to_string x.elf32_sh_name)) in + (match String_table.get_string_at nm sect_hdr_tbl with + | Success name1 -> name1 = ".note.ABI-tag" + | Fail _ -> false + ) + else + false + ) sht) + in + (match abi_note_sects with + | [note] -> + let off = (Nat_big_num.of_string (Uint32.to_string note.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string note.elf32_sh_size)) in + let abi_tag = +(Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + Elf_note.read_elf32_note endian rel >>= (fun (abi_tag, _) -> + return abi_tag))) + in + (match abi_tag with + | Fail _ -> fail "gnu_ext_extract_elf32_earliest_compatible_kernel: parsing of NOTE section failed" + | Success abi_tag -> + let str = (name_string_of_elf32_note abi_tag) in + if str = "GNU\000" then + if Nat_big_num.greater_equal (Nat_big_num.of_string (Uint32.to_string abi_tag.elf32_note_descsz))(Nat_big_num.of_int 16) then + let take2 = (Lem_list.take( 16) abi_tag.elf32_note_desc) in + if List.length take2 < 16 then + fail "gnu_ext_extract_elf32_earliest_compatible_kernel: the impossible happened" + else + (match group_elf32_words endian take2 with + | Fail err -> fail "gnu_ext_extract_elf32_earliest_compatible_kernel: word grouping failed" + | Success ss -> + (match ss with + | c1::c2::c3::cs -> + let c1 = (Uint32.to_string c1) in + let c2 = (Uint32.to_string c2) in + let c3 = (Uint32.to_string c3) in + return (List.fold_right (^) (intercalate "." [c1;c2;c3]) "") + | _ -> fail "gnu_ext_extract_elf32_earliest_compatible_kernel: kernel version must have three components" + ) + ) + else + fail "gnu_ext_extract_elf32_earliest_compatible_kernel: .note.ABI-tag description size not required length" + else + fail "gnu_ext_extract_elf32_earliest_compatible_kernel: required GNU string not present" + ) + | _ -> fail "gnu_ext_extract_elf32_earliest_compatible_kernel: more than one .note.ABI-tag section present" + )) + +(** [gnu_ext_extract_elf64_earliest_compatible_kernel end sht stab bs0] extracts + * the earliest compatible Linux kernel with the given ELF file from its section + * header table [sht], and string table [stbl], assuming endianness [endian]. + * NB: marked as OCaml only as need to extract a string from integers. + * TODO: implement some string parsing functions in Isabelle/HOL so things like + * this can be extracted. + *) +(*val gnu_ext_extract_elf64_earliest_compatible_kernel : endianness -> elf64_section_header_table -> + string_table -> byte_sequence -> error string*) +let gnu_ext_extract_elf64_earliest_compatible_kernel endian sht sect_hdr_tbl bs0:(string)error= + (let abi_note_sects = +(List.filter (fun x -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string x.elf64_sh_type)) sht_note then + let nm = (Nat_big_num.of_string (Uint32.to_string x.elf64_sh_name)) in + (match String_table.get_string_at nm sect_hdr_tbl with + | Success name1 -> name1 = ".note.ABI-tag" + | Fail _ -> false + ) + else + false + ) sht) + in + (match abi_note_sects with + | [note] -> + let off = (Nat_big_num.of_string (Uint64.to_string note.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 note.elf64_sh_size) in + let abi_tag = +(Byte_sequence.offset_and_cut off siz bs0 >>= (fun rel -> + Elf_note.read_elf64_note endian rel >>= (fun (abi_tag, _) -> + return abi_tag))) + in + (match abi_tag with + | Fail _ -> fail "gnu_ext_extract_elf64_earliest_compatible_kernel: parsing of NOTE section failed" + | Success abi_tag -> + let str = (name_string_of_elf64_note abi_tag) in + if str = "GNU\000" then + if Nat_big_num.greater_equal (Ml_bindings.nat_big_num_of_uint64 abi_tag.elf64_note_descsz)(Nat_big_num.of_int 16) then + let take2 = (Lem_list.take( 16) abi_tag.elf64_note_desc) in + if List.length take2 < 16 then + fail "gnu_ext_extract_elf64_earliest_compatible_kernel: the impossible happened" + else + (match group_elf64_words endian take2 with + | Fail err -> fail "gnu_ext_extract_elf64_earliest_compatible_kernel: word grouping failed" + | Success ss -> + (match ss with + | c1::c2::c3::cs -> + let c1 = (Uint32.to_string c1) in + let c2 = (Uint32.to_string c2) in + let c3 = (Uint32.to_string c3) in + return (List.fold_right (^) (intercalate "." [c1;c2;c3]) "") + | _ -> fail "gnu_ext_extract_elf64_earliest_compatible_kernel: kernel version must have three components" + ) + ) + else + fail "gnu_ext_extract_elf64_earliest_compatible_kernel: .note.ABI-tag description size not required length" + else + fail "gnu_ext_extract_elf64_earliest_compatible_kernel: required GNU string not present" + ) + | _ -> fail "gnu_ext_extract_elf64_earliest_compatible_kernel: more than one .note.ABI-tag section present" + )) diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_program_header_table.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_program_header_table.ml new file mode 100644 index 00000000..4c5b78c1 --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_program_header_table.ml @@ -0,0 +1,34 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_program_header_table.lem.*) +(** [gnu_ext_program_header_table] contains GNU extension specific functionality + * related to the program header table. + *) + +open Lem_basic_classes +open Lem_num + +(** GNU extensions, as defined in the LSB, see section 11.2. *) + +(** The element specifies the location and size of a segment that may be made + * read-only after relocations have been processed. + *) +let elf_pt_gnu_relro : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 421345620))(Nat_big_num.of_int 2)) (* 0x6474e552 *) +(** The [p_flags] member specifies the permissions of the segment containing the + * stack and is used to indicate whether the stack should be executable. + *) +let elf_pt_gnu_stack : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 421345620))(Nat_big_num.of_int 1)) (* 0x6474e551 *) +(** Element specifies the location and size of exception handling information. *) +let elf_pt_gnu_eh_frame : Nat_big_num.num= (Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 421345620)) (* 0x6474e550 *) + +(** [string_of_gnu_ext_segment_type m] produces a string representation of + * GNU extension segment type [m]. + *) +(*val string_of_gnu_ext_segment_type : natural -> string*) +let string_of_gnu_ext_segment_type pt:string= + (if Nat_big_num.equal pt elf_pt_gnu_relro then + "GNU_RELRO" + else if Nat_big_num.equal pt elf_pt_gnu_stack then + "GNU_STACK" + else if Nat_big_num.equal pt elf_pt_gnu_eh_frame then + "GNU_EH_FRAME" + else + "Invalid GNU EXT segment type") diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_header_table.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_header_table.ml new file mode 100644 index 00000000..98faa8e4 --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_header_table.ml @@ -0,0 +1,151 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_section_header_table.lem.*) +(** The module [gnu_ext_section_header_table] implements function, definitions + * and types relating to the GNU extensions to the standard ELF section header + * table. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_map +open Lem_maybe +open Lem_num +open Lem_string + +open Hex_printing + +open Error +open String_table +open Show + +open Elf_section_header_table +open Elf_interpreted_section + +(** GNU extended section types *) + +(** [GNU_HASH] does not appear to be defined in the LSB but is present in + * several ELF binaries collected in the wild... + * + * TODO: find out where this comes from? + * ANSW: a mailing list apparently! See here: + * https://sourceware.org/ml/binutils/2006-10/msg00377.html + *) +let sht_gnu_hash : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524091)) (* 0x6FFFFFF6 *) + +(** The following are all defined in Section 10.2.2.2 of the LSB as additional + * section types over the ones defined in the SCO ELF spec. + *) + +(** [sht_gnu_verdef] contains the symbol versions that are provided. + *) +let sht_gnu_verdef : Nat_big_num.num= (Nat_big_num.sub_nat ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524095))(Nat_big_num.of_int 1)) (* 0x6ffffffd *) +(** [sht_gnu_verneed] contains the symbol versions that are required. + *) +let sht_gnu_verneed : Nat_big_num.num= ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524095)) (* 0x6ffffffe *) +(** [sht_gnu_versym] contains the symbol version table. + *) +let sht_gnu_versym : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524095))(Nat_big_num.of_int 1)) (* 0x6fffffff *) +(** [sht_gnu_liblist] appears to be undocumented but appears in PowerPC 64 ELF + * binaries in "the wild". + *) +let sht_gnu_liblist : Nat_big_num.num= (Nat_big_num.add ( Nat_big_num.mul(Nat_big_num.of_int 2)(Nat_big_num.of_int 939524091))(Nat_big_num.of_int 1)) (* 0x6FFFFFF7 *) + +(** [string_of_gnu_ext_section_type m] produces a string based representation of + * GNU extension section type [m]. + *) +(*val string_of_gnu_ext_section_type : natural -> string*) +let string_of_gnu_ext_section_type i:string= + (if Nat_big_num.equal i sht_gnu_hash then + "GNU_HASH" + else if Nat_big_num.equal i sht_gnu_verdef then + "VERDEF" + else if Nat_big_num.equal i sht_gnu_verneed then + "VERNEED" + else if Nat_big_num.equal i sht_gnu_versym then + "VERSYM" + else if Nat_big_num.equal i sht_gnu_liblist then + "GNU_LIBLIST" + else if Nat_big_num.greater_equal i sht_loos && Nat_big_num.less_equal i sht_hios then + let diff = (Nat_big_num.sub_nat i sht_loos) in + let suff = (unsafe_hex_string_of_natural( 0) diff) in + "LOOS+" ^ suff + else + "Invalid GNU EXT section type: " ^ Nat_big_num.to_string i) + +(** [gnu_ext_additionall_special_sections] records additional section names that + * map appear in GNU ELF binaries and their required associated types and + * attributes. See Section 10.3.1.1 of the LSB and the related map + * [elf_special_sections] in [Elf_section_header_table] which records section + * names and their required types and attributes that all ELF binaries share. + *) +(*val gnu_ext_additional_special_sections : Map.map string (natural * natural)*) +let gnu_ext_additional_special_sections:((string),(Nat_big_num.num*Nat_big_num.num))Pmap.map= + (Lem_map.fromList (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + (".ctors", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".data.rel.ro", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".dtors", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".eh_frame", (sht_progbits, shf_alloc)) + ; (".eh_frame_hdr", (sht_progbits, shf_alloc)) + ; (".gcc_execpt_table", (sht_progbits, shf_alloc)) + ; (".gnu.version", (sht_gnu_versym, shf_alloc)) + ; (".gnu.version_d", (sht_gnu_verdef, shf_alloc)) + ; (".gnu.version_r", (sht_gnu_verneed, shf_alloc)) + ; (".got.plt", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".jcr", (sht_progbits, Nat_big_num.add shf_alloc shf_write)) + ; (".note.ABI-tag", (sht_note, shf_alloc)) + ; (".stab", (sht_progbits,Nat_big_num.of_int 0)) + ; (".stabstr", (sht_strtab,Nat_big_num.of_int 0)) + ]) + +(** [is_valid_gnu_ext_elf32_section_header_table_entry scts stbl] checks whether + * sections [scts] conforms with the contents of the special sections table. + * Fails otherwise. + *) +(*val is_valid_gnu_ext_elf32_section_header_table_entry : elf32_interpreted_section -> + string_table -> bool*) +let is_valid_gnu_ext_elf32_section_header_table_entry ent stbl:bool= + ((match String_table.get_string_at ent.elf32_section_name stbl with + | Fail f -> false + | Success name1 -> + (match Pmap.lookup name1 gnu_ext_additional_special_sections with + | None -> + is_valid_elf32_section_header_table_entry ent stbl + | Some (typ, flags) -> Nat_big_num.equal + typ ent.elf32_section_type && Nat_big_num.equal flags ent.elf32_section_flags + ) + )) + +(** [is_valid_gnu_ext_elf32_section_header_table sht stbl] checks whether every + * member of the section header table [sht] conforms with the special sections + * table. + *) +(*val is_valid_gnu_ext_elf32_section_header_table : list elf32_interpreted_section -> + string_table -> bool*) +let is_valid_gnu_ext_elf32_section_header_table ents stbl:bool= + (List.for_all (fun x -> is_valid_gnu_ext_elf32_section_header_table_entry x stbl) ents) + +(** [is_valid_gnu_ext_elf64_section_header_table_entry scts stbl] checks whether + * sections [scts] conforms with the contents of the special sections table. + * Fails otherwise. + *) +(*val is_valid_gnu_ext_elf64_section_header_table_entry : elf64_interpreted_section -> + string_table -> bool*) +let is_valid_gnu_ext_elf64_section_header_table_entry ent stbl:bool= + ((match String_table.get_string_at ent.elf64_section_name stbl with + | Fail f -> false + | Success name1 -> + (match Pmap.lookup name1 gnu_ext_additional_special_sections with + | None -> + is_valid_elf64_section_header_table_entry ent stbl + | Some (typ, flags) -> Nat_big_num.equal + typ ent.elf64_section_type && Nat_big_num.equal flags ent.elf64_section_flags + ) + )) + +(** [is_valid_gnu_ext_elf64_section_header_table sht stbl] checks whether every + * member of the section header table [sht] conforms with the special sections + * table. + *) +(*val is_valid_gnu_ext_elf64_section_header_table : list elf64_interpreted_section -> + string_table -> bool*) +let is_valid_gnu_ext_elf64_section_header_table ents stbl:bool= + (List.for_all (fun x -> is_valid_gnu_ext_elf64_section_header_table_entry x stbl) ents) diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_to_segment_mapping.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_to_segment_mapping.ml new file mode 100644 index 00000000..86a5c5ed --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_to_segment_mapping.ml @@ -0,0 +1,265 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_section_to_segment_mapping.lem.*) +(** [gnu_ext_section_to_segment_mapping] contains (GNU specific) functionality + * relating to calculating the section to segment mapping for an ELF file. In + * particular, the test over whether a section is inside a segment is ABI + * specific. This module provides that test. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_num + +open Elf_header +open Elf_program_header_table +open Elf_section_header_table +open Elf_types_native_uint + +open Lem_string +open Show + +open Gnu_ext_program_header_table + +(** [elf32_section_in_segment sec_hdr segment] implements the + * ELF_SECTION_IN_SEGMENT1 macro from readelf. Note the macro is always used + * with [check_vma] and [strict] set to 1. + * + #define ELF_SECTION_IN_SEGMENT_1(sec_hdr, segment, check_vma, strict) \ + ((/* Only PT_LOAD, PT_GNU_RELRO and PT_TLS segments can contain \ + SHF_TLS sections. */ \ + ((((sec_hdr)->sh_flags & SHF_TLS) != 0) \ + && ((segment)->p_type == PT_TLS \ + || (segment)->p_type == PT_GNU_RELRO \ + || (segment)->p_type == PT_LOAD)) \ + /* PT_TLS segment contains only SHF_TLS sections, PT_PHDR no \ + sections at all. */ \ + || (((sec_hdr)->sh_flags & SHF_TLS) == 0 \ + && (segment)->p_type != PT_TLS \ + && (segment)->p_type != PT_PHDR)) \ + /* PT_LOAD and similar segments only have SHF_ALLOC sections. */ \ + && !(((sec_hdr)->sh_flags & SHF_ALLOC) == 0 \ + && ((segment)->p_type == PT_LOAD \ + || (segment)->p_type == PT_DYNAMIC \ + || (segment)->p_type == PT_GNU_EH_FRAME \ + || (segment)->p_type == PT_GNU_RELRO \ + || (segment)->p_type == PT_GNU_STACK)) \ + /* Any section besides one of type SHT_NOBITS must have file \ + offsets within the segment. */ \ + && ((sec_hdr)->sh_type == SHT_NOBITS \ + || ((bfd_vma) (sec_hdr)->sh_offset >= (segment)->p_offset \ + && (!(strict) \ + || ((sec_hdr)->sh_offset - (segment)->p_offset \ + <= (segment)->p_filesz - 1)) \ + && (((sec_hdr)->sh_offset - (segment)->p_offset \ + + ELF_SECTION_SIZE(sec_hdr, segment)) \ + <= (segment)->p_filesz))) \ + /* SHF_ALLOC sections must have VMAs within the segment. */ \ + && (!(check_vma) \ + || ((sec_hdr)->sh_flags & SHF_ALLOC) == 0 \ + || ((sec_hdr)->sh_addr >= (segment)->p_vaddr \ + && (!(strict) \ + || ((sec_hdr)->sh_addr - (segment)->p_vaddr \ + <= (segment)->p_memsz - 1)) \ + && (((sec_hdr)->sh_addr - (segment)->p_vaddr \ + + ELF_SECTION_SIZE(sec_hdr, segment)) \ + <= (segment)->p_memsz))) \ + /* No zero size sections at start or end of PT_DYNAMIC. */ \ + && ((segment)->p_type != PT_DYNAMIC \ + || (sec_hdr)->sh_size != 0 \ + || (segment)->p_memsz == 0 \ + || (((sec_hdr)->sh_type == SHT_NOBITS \ + || ((bfd_vma) (sec_hdr)->sh_offset > (segment)->p_offset \ + && ((sec_hdr)->sh_offset - (segment)->p_offset \ + < (segment)->p_filesz))) \ + && (((sec_hdr)->sh_flags & SHF_ALLOC) == 0 \ + || ((sec_hdr)->sh_addr > (segment)->p_vaddr \ + && ((sec_hdr)->sh_addr - (segment)->p_vaddr \ + < (segment)->p_memsz)))))) + * + * From [internal.h] of readelf's source code. + *) + +(*val elf32_section_flags : elf32_section_header_table_entry -> natural -> bool*) +let elf32_section_flags0 sec_hdr typ:bool= (not ((Uint32.logand sec_hdr.elf32_sh_flags (Uint32.of_string (Nat_big_num.to_string typ))) = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) + +(*val elf64_section_flags : elf64_section_header_table_entry -> natural -> bool*) +let elf64_section_flags0 sec_hdr typ:bool= (not ((Uint64.logand sec_hdr.elf64_sh_flags (Uint64.of_string (Nat_big_num.to_string typ))) = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))))) + +(*val elf32_section_of_type : elf32_section_header_table_entry -> natural -> bool*) +let elf32_section_of_type sec_hdr typ:bool= + (sec_hdr.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string typ)) + +(*val elf64_section_of_type : elf64_section_header_table_entry -> natural -> bool*) +let elf64_section_of_type sec_hdr typ:bool= + (sec_hdr.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string typ)) + +(*val elf32_segment_of_type : elf32_program_header_table_entry -> natural -> bool*) +let elf32_segment_of_type segment typ:bool= + (segment.elf32_p_type = Uint32.of_string (Nat_big_num.to_string typ)) + +(*val elf64_segment_of_type : elf64_program_header_table_entry -> natural -> bool*) +let elf64_segment_of_type segment typ:bool= + (segment.elf64_p_type = Uint32.of_string (Nat_big_num.to_string typ)) + +(** Only PT_LOAD, PT_GNU_RELRO and PT_TLS segments can contain SHF_TLS sections + * and PT_TLS segment contains only SHF_TLS sections, PT_PHDR no sections at all + *) +(*val elf32_section_in_segment1 : elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let elf32_section_in_segment1 sec_hdr segment:bool= + ((elf32_section_flags0 sec_hdr shf_tls && + (elf32_segment_of_type segment elf_pt_tls || +(elf32_segment_of_type segment elf_pt_gnu_relro || + elf32_segment_of_type segment elf_pt_load))) || + (not (elf32_section_flags0 sec_hdr shf_tls) + && (not (elf32_segment_of_type segment elf_pt_tls) + && not (elf32_segment_of_type segment elf_pt_phdr)))) + +(*val elf64_section_in_segment1 : elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let elf64_section_in_segment1 sec_hdr segment:bool= + ((elf64_section_flags0 sec_hdr shf_tls && + (elf64_segment_of_type segment elf_pt_tls || +(elf64_segment_of_type segment elf_pt_gnu_relro || + elf64_segment_of_type segment elf_pt_load))) || + (not (elf64_section_flags0 sec_hdr shf_tls) + && (not (elf64_segment_of_type segment elf_pt_tls) + && not (elf64_segment_of_type segment elf_pt_phdr)))) + +(** PT_LOAD and similar segments only have SHF_ALLOC sections *) + +(*val elf32_section_in_segment2 : elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let elf32_section_in_segment2 sec_hdr segment:bool= + (not ((not (elf32_section_flags0 sec_hdr shf_alloc)) && + (elf32_segment_of_type segment elf_pt_load || +(elf32_segment_of_type segment elf_pt_dynamic || +(elf32_segment_of_type segment elf_pt_gnu_eh_frame || +(elf32_segment_of_type segment elf_pt_gnu_relro || + elf32_segment_of_type segment elf_pt_gnu_stack)))))) + +(*val elf64_section_in_segment2 : elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let elf64_section_in_segment2 sec_hdr segment:bool= + (not ((not (elf64_section_flags0 sec_hdr shf_alloc)) && + (elf64_segment_of_type segment elf_pt_load || +(elf64_segment_of_type segment elf_pt_dynamic || +(elf64_segment_of_type segment elf_pt_gnu_eh_frame || +(elf64_segment_of_type segment elf_pt_gnu_relro || + elf64_segment_of_type segment elf_pt_gnu_stack)))))) + + +(** Any section besides one of type SHT_NOBITS must have file offsets within + * the segment. + *) + +(*val elf32_sect_size : elf32_header -> elf32_section_header_table_entry -> elf32_program_header_table_entry -> natural*) +let elf32_sect_size hdr sec_hdr segment:Nat_big_num.num= + (if is_elf32_tbss_special sec_hdr segment then Nat_big_num.of_int 0 + else + Nat_big_num.of_string (Uint32.to_string (hdr.elf32_shentsize))) + +(*val elf64_sect_size : elf64_header -> elf64_section_header_table_entry -> elf64_program_header_table_entry -> natural*) +let elf64_sect_size hdr sec_hdr segment:Nat_big_num.num= + (if is_elf64_tbss_special sec_hdr segment then Nat_big_num.of_int 0 + else + Nat_big_num.of_string (Uint32.to_string (hdr.elf64_shentsize))) + +(*val elf32_section_in_segment3 : elf32_header -> elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let elf32_section_in_segment3 hdr sec_hdr segment:bool= + (let sec_off = ((Nat_big_num.of_string (Uint32.to_string sec_hdr.elf32_sh_offset))) in + let seg_off = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_offset))) in + let seg_fsz = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_filesz))) in + let sec_siz = ((elf32_sect_size hdr sec_hdr segment)) in + elf32_section_of_type sec_hdr sht_nobits || + ( Nat_big_num.greater_equal sec_off seg_off && +(( Nat_big_num.less_equal( Nat_big_num.sub sec_off seg_off) ( Nat_big_num.sub seg_fsz(Nat_big_num.of_int 1))) && + ( Nat_big_num.less_equal (Nat_big_num.sub sec_off ( Nat_big_num.add seg_off sec_siz)) seg_fsz)))) + +(*val elf64_section_in_segment3 : elf64_header -> elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let elf64_section_in_segment3 hdr sec_hdr segment:bool= + (let sec_off = ((Nat_big_num.of_string (Uint64.to_string sec_hdr.elf64_sh_offset))) in + let seg_off = ((Nat_big_num.of_string (Uint64.to_string segment.elf64_p_offset))) in + let seg_fsz = ((Ml_bindings.nat_big_num_of_uint64 segment.elf64_p_filesz)) in + let sec_siz = ((elf64_sect_size hdr sec_hdr segment)) in + elf64_section_of_type sec_hdr sht_nobits || + ( Nat_big_num.greater_equal sec_off seg_off && +(( Nat_big_num.less_equal( Nat_big_num.sub sec_off seg_off) ( Nat_big_num.sub seg_fsz(Nat_big_num.of_int 1))) && + ( Nat_big_num.less_equal (Nat_big_num.sub sec_off ( Nat_big_num.add seg_off sec_siz)) seg_fsz)))) + +(** SHF_ALLOC sections must have VMAs within the segment + *) + +(*val elf32_section_in_segment4 : elf32_header -> elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let elf32_section_in_segment4 hdr sec_hdr segment:bool= + (let sec_addr = ((Nat_big_num.of_string (Uint32.to_string sec_hdr.elf32_sh_addr))) in + let seg_vadr = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_vaddr))) in + let seg_mmsz = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_memsz))) in + let sec_size = ((elf32_sect_size hdr sec_hdr segment)) in + (not (elf32_section_flags0 sec_hdr shf_alloc) || Nat_big_num.greater_equal + sec_addr seg_vadr) && (Nat_big_num.less_equal (Nat_big_num.sub + sec_addr seg_vadr) (Nat_big_num.sub seg_mmsz(Nat_big_num.of_int 1)) && Nat_big_num.less_equal (Nat_big_num.sub + sec_addr ( Nat_big_num.add seg_vadr sec_size)) seg_mmsz)) + +(*val elf64_section_in_segment4 : elf64_header -> elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let elf64_section_in_segment4 hdr sec_hdr segment:bool= + (let sec_addr = ((Ml_bindings.nat_big_num_of_uint64 sec_hdr.elf64_sh_addr)) in + let seg_vadr = ((Ml_bindings.nat_big_num_of_uint64 segment.elf64_p_vaddr)) in + let seg_mmsz = ((Ml_bindings.nat_big_num_of_uint64 segment.elf64_p_memsz)) in + let sec_size = ((elf64_sect_size hdr sec_hdr segment)) in + (not (elf64_section_flags0 sec_hdr shf_alloc) || Nat_big_num.greater_equal + sec_addr seg_vadr) && (Nat_big_num.less_equal (Nat_big_num.sub + sec_addr seg_vadr) (Nat_big_num.sub seg_mmsz(Nat_big_num.of_int 1)) && Nat_big_num.less_equal (Nat_big_num.sub + sec_addr ( Nat_big_num.add seg_vadr sec_size)) seg_mmsz)) + +(** No zero size sections at start or end of PT_DYNAMIC *) + +(*val elf32_section_in_segment5 : elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let elf32_section_in_segment5 sec_hdr segment:bool= + (let sec_siz = ((Nat_big_num.of_string (Uint32.to_string sec_hdr.elf32_sh_size))) in + let seg_msz = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_memsz))) in + let sec_off = ((Nat_big_num.of_string (Uint32.to_string sec_hdr.elf32_sh_offset))) in + let seg_off = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_offset))) in + let seg_fsz = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_filesz))) in + let sec_adr = ((Nat_big_num.of_string (Uint32.to_string sec_hdr.elf32_sh_addr))) in + let seg_vad = ((Nat_big_num.of_string (Uint32.to_string segment.elf32_p_vaddr))) in + (not (elf32_segment_of_type segment elf_pt_dynamic)) || (not (Nat_big_num.equal sec_siz(Nat_big_num.of_int 0)) || (Nat_big_num.equal + seg_msz(Nat_big_num.of_int 0) || + ((elf32_section_of_type sec_hdr sht_nobits || + ( Nat_big_num.greater sec_off seg_off && Nat_big_num.less (Nat_big_num.sub + sec_off seg_off) seg_fsz)) && + (not (elf32_section_flags0 sec_hdr shf_alloc) || + ( Nat_big_num.greater sec_adr seg_vad && Nat_big_num.less (Nat_big_num.sub + sec_adr seg_vad) seg_msz)))))) + +(*val elf64_section_in_segment5 : elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let elf64_section_in_segment5 sec_hdr segment:bool= + (let sec_siz = ((Ml_bindings.nat_big_num_of_uint64 sec_hdr.elf64_sh_size)) in + let seg_msz = ((Ml_bindings.nat_big_num_of_uint64 segment.elf64_p_memsz)) in + let sec_off = ((Nat_big_num.of_string (Uint64.to_string sec_hdr.elf64_sh_offset))) in + let seg_off = ((Nat_big_num.of_string (Uint64.to_string segment.elf64_p_offset))) in + let seg_fsz = ((Ml_bindings.nat_big_num_of_uint64 segment.elf64_p_filesz)) in + let sec_adr = ((Ml_bindings.nat_big_num_of_uint64 sec_hdr.elf64_sh_addr)) in + let seg_vad = ((Ml_bindings.nat_big_num_of_uint64 segment.elf64_p_vaddr)) in + (not (elf64_segment_of_type segment elf_pt_dynamic)) || (not (Nat_big_num.equal sec_siz(Nat_big_num.of_int 0)) || (Nat_big_num.equal + seg_msz(Nat_big_num.of_int 0) || + ((elf64_section_of_type sec_hdr sht_nobits || + ( Nat_big_num.greater sec_off seg_off && Nat_big_num.less (Nat_big_num.sub + sec_off seg_off) seg_fsz)) && + (not (elf64_section_flags0 sec_hdr shf_alloc) || + ( Nat_big_num.greater sec_adr seg_vad && Nat_big_num.less (Nat_big_num.sub + sec_adr seg_vad) seg_msz)))))) + +(** The final section in segment tests, bringing all the above together. + *) + +(*val elf32_section_in_segment : elf32_header -> elf32_section_header_table_entry -> elf32_program_header_table_entry -> bool*) +let elf32_section_in_segment hdr sec_hdr segment:bool= + (elf32_section_in_segment1 sec_hdr segment && +(elf32_section_in_segment2 sec_hdr segment && +(elf32_section_in_segment3 hdr sec_hdr segment && +(elf32_section_in_segment4 hdr sec_hdr segment && + elf32_section_in_segment5 sec_hdr segment)))) + +(*val elf64_section_in_segment : elf64_header -> elf64_section_header_table_entry -> elf64_program_header_table_entry -> bool*) +let elf64_section_in_segment hdr sec_hdr segment:bool= + (elf64_section_in_segment1 sec_hdr segment && +(elf64_section_in_segment2 sec_hdr segment && +(elf64_section_in_segment3 hdr sec_hdr segment && +(elf64_section_in_segment4 hdr sec_hdr segment && + elf64_section_in_segment5 sec_hdr segment)))) diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_symbol_versioning.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_symbol_versioning.ml new file mode 100644 index 00000000..fe9382b0 --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_symbol_versioning.ml @@ -0,0 +1,294 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_symbol_versioning.lem.*) +(** The [gnu_ext_symbol_versioning] defines constants, types and functions + * relating to the GNU symbol versioning extensions (i.e. contents of + * GNU_VERSYM sections). + * + * TODO: work out what is going on with symbol versioning. The specification + * is completely opaque. + *) + +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string + +open Byte_sequence +open Endianness +open Error + +open Elf_dynamic +open Elf_file +open Elf_header +open Elf_section_header_table +open Elf_symbol_table +open Elf_types_native_uint + +open Missing_pervasives +open Show + +open Gnu_ext_dynamic +open Gnu_ext_section_header_table + +(** [gnu_ext_elf32_symbol_version_table] is an array (linked list, here) of + * [elf32_half] entries. + *) +type gnu_ext_elf32_symbol_version_table = Uint32.uint32 + list + +type gnu_ext_elf64_symbol_version_table = Uint32.uint32 + list + +(*val obtain_gnu_ext_elf32_symbol_version_table : elf32_file -> byte_sequence -> error gnu_ext_elf32_symbol_version_table*) +let obtain_gnu_ext_elf32_symbol_version_table f1 bs0:((Uint32.uint32)list)error= + (let sht = (f1.elf32_file_section_header_table) in + let endian = (get_elf32_header_endianness f1.elf32_file_header) in + let vers = (List.filter (fun ent -> + ent.elf32_sh_type = Uint32.of_string (Nat_big_num.to_string sht_gnu_versym) + ) sht) + in + (match vers with + | [] -> return [] + | [ver] -> + let off = (Nat_big_num.of_string (Uint32.to_string ver.elf32_sh_offset)) in + let siz = (Nat_big_num.of_string (Uint32.to_string ver.elf32_sh_size)) in + let lnk = (Nat_big_num.of_string (Uint32.to_string ver.elf32_sh_link)) in + get_elf32_symbol_table_by_index f1 lnk >>= (fun symtab -> + let dlen = (Nat_big_num.of_int (List.length symtab)) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun ver -> + Error.repeatM' dlen bs0 (read_elf32_half endian) >>= (fun (ver, _) -> + return ver))) + | _ -> fail "obtain_gnu_ext_elf32_symbol_version_table: multiple sections of type .gnu_versym present in file" + )) + +(*val obtain_gnu_ext_elf64_symbol_version_table : endianness -> elf64_section_header_table -> elf64_symbol_table -> byte_sequence -> error gnu_ext_elf64_symbol_version_table*) +let obtain_gnu_ext_elf64_symbol_version_table endian sht dynsym bs0:((Uint32.uint32)list)error= + (let dlen = (Nat_big_num.of_int (List.length dynsym)) in + if Nat_big_num.equal dlen(Nat_big_num.of_int 0) then + return [] + else + let vers = (List.filter (fun ent -> + ent.elf64_sh_type = Uint32.of_string (Nat_big_num.to_string sht_gnu_versym) + ) sht) + in + (match vers with + | [] -> return [] + | [ver] -> + let off = (Nat_big_num.of_string (Uint64.to_string ver.elf64_sh_offset)) in + let siz = (Ml_bindings.nat_big_num_of_uint64 ver.elf64_sh_size) in + Byte_sequence.offset_and_cut off siz bs0 >>= (fun ver -> + Error.repeatM' dlen bs0 (read_elf64_half endian) >>= (fun (ver, _) -> + return ver)) + | _ -> fail "obtain_gnu_ext_elf64_symbol_version_table: multiple sections of type .gnu_versym present in file" + )) + +type gnu_ext_elf32_verdef = + { gnu_ext_elf32_vd_version : Uint32.uint32 + ; gnu_ext_elf32_vd_flags : Uint32.uint32 + ; gnu_ext_elf32_vd_ndx : Uint32.uint32 + ; gnu_ext_elf32_vd_cnt : Uint32.uint32 + ; gnu_ext_elf32_vd_hash : Uint32.uint32 + ; gnu_ext_elf32_vd_aux : Uint32.uint32 + ; gnu_ext_elf32_vd_next : Uint32.uint32 + } + +type gnu_ext_elf64_verdef = + { gnu_ext_elf64_vd_version : Uint32.uint32 + ; gnu_ext_elf64_vd_flags : Uint32.uint32 + ; gnu_ext_elf64_vd_ndx : Uint32.uint32 + ; gnu_ext_elf64_vd_cnt : Uint32.uint32 + ; gnu_ext_elf64_vd_hash : Uint32.uint32 + ; gnu_ext_elf64_vd_aux : Uint32.uint32 + ; gnu_ext_elf64_vd_next : Uint32.uint32 + } + +(*val string_of_gnu_ext_elf32_verdef : gnu_ext_elf32_verdef -> string*) +let string_of_gnu_ext_elf32_verdef verdef:string= + (unlines [ +("Version: " ^ Uint32.to_string verdef.gnu_ext_elf32_vd_version) + ; ("Flags: " ^ Uint32.to_string verdef.gnu_ext_elf32_vd_flags) + ; ("Index: " ^ Uint32.to_string verdef.gnu_ext_elf32_vd_ndx) + ; ("Count: " ^ Uint32.to_string verdef.gnu_ext_elf32_vd_cnt) + ; ("Hash: " ^ Uint32.to_string verdef.gnu_ext_elf32_vd_hash) + ]) + +(*val string_of_gnu_ext_elf64_verdef : gnu_ext_elf64_verdef -> string*) +let string_of_gnu_ext_elf64_verdef verdef:string= + (unlines [ +("Version: " ^ Uint32.to_string verdef.gnu_ext_elf64_vd_version) + ; ("Flags: " ^ Uint32.to_string verdef.gnu_ext_elf64_vd_flags) + ; ("Index: " ^ Uint32.to_string verdef.gnu_ext_elf64_vd_ndx) + ; ("Count: " ^ Uint32.to_string verdef.gnu_ext_elf64_vd_cnt) + ; ("Hash: " ^ Uint32.to_string verdef.gnu_ext_elf64_vd_hash) + ]) + +(*val read_gnu_ext_elf32_verdef : endianness -> byte_sequence -> error (gnu_ext_elf32_verdef * byte_sequence)*) +let read_gnu_ext_elf32_verdef endian bs0:(gnu_ext_elf32_verdef*byte_sequence)error= + (read_elf32_half endian bs0 >>= (fun (ver, bs0) -> + read_elf32_half endian bs0 >>= (fun (flg, bs0) -> + read_elf32_half endian bs0 >>= (fun (ndx, bs0) -> + read_elf32_half endian bs0 >>= (fun (cnt, bs0) -> + read_elf32_word endian bs0 >>= (fun (hsh, bs0) -> + read_elf32_word endian bs0 >>= (fun (aux, bs0) -> + read_elf32_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf32_vd_version = ver; gnu_ext_elf32_vd_flags = flg; + gnu_ext_elf32_vd_ndx = ndx; gnu_ext_elf32_vd_cnt = cnt; + gnu_ext_elf32_vd_hash = hsh; gnu_ext_elf32_vd_aux = aux; + gnu_ext_elf32_vd_next = nxt }, bs0))))))))) + +(*val read_gnu_ext_elf64_verdef : endianness -> byte_sequence -> error (gnu_ext_elf64_verdef * byte_sequence)*) +let read_gnu_ext_elf64_verdef endian bs0:(gnu_ext_elf64_verdef*byte_sequence)error= + (read_elf64_half endian bs0 >>= (fun (ver, bs0) -> + read_elf64_half endian bs0 >>= (fun (flg, bs0) -> + read_elf64_half endian bs0 >>= (fun (ndx, bs0) -> + read_elf64_half endian bs0 >>= (fun (cnt, bs0) -> + read_elf64_word endian bs0 >>= (fun (hsh, bs0) -> + read_elf64_word endian bs0 >>= (fun (aux, bs0) -> + read_elf64_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf64_vd_version = ver; gnu_ext_elf64_vd_flags = flg; + gnu_ext_elf64_vd_ndx = ndx; gnu_ext_elf64_vd_cnt = cnt; + gnu_ext_elf64_vd_hash = hsh; gnu_ext_elf64_vd_aux = aux; + gnu_ext_elf64_vd_next = nxt }, bs0))))))))) + +(*val gnu_ext_elf32_verdef_size : natural*) +let gnu_ext_elf32_verdef_size:Nat_big_num.num= (Nat_big_num.of_int 160) + +(*val gnu_ext_elf64_verdef_size : natural*) +let gnu_ext_elf64_verdef_size:Nat_big_num.num= (Nat_big_num.of_int 256) + +type gnu_ext_elf32_veraux = + { gnu_ext_elf32_vda_name : Uint32.uint32 + ; gnu_ext_elf32_vda_next : Uint32.uint32 + } + +type gnu_ext_elf64_veraux = + { gnu_ext_elf64_vda_name : Uint32.uint32 + ; gnu_ext_elf64_vda_next : Uint32.uint32 + } + +(*val gnu_ext_elf32_veraux_size : natural*) +let gnu_ext_elf32_veraux_size:Nat_big_num.num= (Nat_big_num.of_int 64) + +(*val gnu_ext_elf64_veraux_size : natural*) +let gnu_ext_elf64_veraux_size:Nat_big_num.num= (Nat_big_num.of_int 128) + +(*val read_gnu_ext_elf32_veraux : endianness -> byte_sequence -> error (gnu_ext_elf32_veraux * byte_sequence)*) +let read_gnu_ext_elf32_veraux endian bs0:(gnu_ext_elf32_veraux*byte_sequence)error= + (read_elf32_word endian bs0 >>= (fun (nme, bs0) -> + read_elf32_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf32_vda_name = nme; gnu_ext_elf32_vda_next = nxt }, bs0)))) + +(*val read_gnu_ext_elf64_veraux : endianness -> byte_sequence -> error (gnu_ext_elf64_veraux * byte_sequence)*) +let read_gnu_ext_elf64_veraux endian bs0:(gnu_ext_elf64_veraux*byte_sequence)error= + (read_elf64_word endian bs0 >>= (fun (nme, bs0) -> + read_elf64_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf64_vda_name = nme; gnu_ext_elf64_vda_next = nxt }, bs0)))) + +type gnu_ext_elf32_verneed = + { gnu_ext_elf32_vn_version : Uint32.uint32 + ; gnu_ext_elf32_vn_cnt : Uint32.uint32 + ; gnu_ext_elf32_vn_file : Uint32.uint32 + ; gnu_ext_elf32_vn_aux : Uint32.uint32 + ; gnu_ext_elf32_vn_next : Uint32.uint32 + } + +type gnu_ext_elf64_verneed = + { gnu_ext_elf64_vn_version : Uint32.uint32 + ; gnu_ext_elf64_vn_cnt : Uint32.uint32 + ; gnu_ext_elf64_vn_file : Uint32.uint32 + ; gnu_ext_elf64_vn_aux : Uint32.uint32 + ; gnu_ext_elf64_vn_next : Uint32.uint32 + } + +(*val gnu_ext_elf32_verneed_size : natural*) +let gnu_ext_elf32_verneed_size:Nat_big_num.num= (Nat_big_num.of_int 128) + +(*val gnu_ext_elf64_verneed_size : natural*) +let gnu_ext_elf64_verneed_size:Nat_big_num.num= (Nat_big_num.of_int 224) + +(*val read_gnu_ext_elf32_verneed : endianness -> byte_sequence -> error (gnu_ext_elf32_verneed * byte_sequence)*) +let read_gnu_ext_elf32_verneed endian bs0:(gnu_ext_elf32_verneed*byte_sequence)error= + (read_elf32_half endian bs0 >>= (fun (ver, bs0) -> + read_elf32_half endian bs0 >>= (fun (cnt, bs0) -> + read_elf32_word endian bs0 >>= (fun (fle, bs0) -> + read_elf32_word endian bs0 >>= (fun (aux, bs0) -> + read_elf32_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf32_vn_version = ver; gnu_ext_elf32_vn_cnt = cnt; + gnu_ext_elf32_vn_file = fle; gnu_ext_elf32_vn_aux = aux; + gnu_ext_elf32_vn_next = nxt }, bs0))))))) + +(*val read_gnu_ext_elf64_verneed : endianness -> byte_sequence -> error (gnu_ext_elf64_verneed * byte_sequence)*) +let read_gnu_ext_elf64_verneed endian bs0:(gnu_ext_elf64_verneed*byte_sequence)error= + (read_elf64_half endian bs0 >>= (fun (ver, bs0) -> + read_elf64_half endian bs0 >>= (fun (cnt, bs0) -> + read_elf64_word endian bs0 >>= (fun (fle, bs0) -> + read_elf64_word endian bs0 >>= (fun (aux, bs0) -> + read_elf64_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf64_vn_version = ver; gnu_ext_elf64_vn_cnt = cnt; + gnu_ext_elf64_vn_file = fle; gnu_ext_elf64_vn_aux = aux; + gnu_ext_elf64_vn_next = nxt }, bs0))))))) + +type gnu_ext_elf32_vernaux = + { gnu_ext_elf32_vna_hash : Uint32.uint32 + ; gnu_ext_elf32_vna_flags : Uint32.uint32 + ; gnu_ext_elf32_vna_other : Uint32.uint32 + ; gnu_ext_elf32_vna_name : Uint32.uint32 + ; gnu_ext_elf32_vna_next : Uint32.uint32 + } + +type gnu_ext_elf64_vernaux = + { gnu_ext_elf64_vna_hash : Uint32.uint32 + ; gnu_ext_elf64_vna_flags : Uint32.uint32 + ; gnu_ext_elf64_vna_other : Uint32.uint32 + ; gnu_ext_elf64_vna_name : Uint32.uint32 + ; gnu_ext_elf64_vna_next : Uint32.uint32 + } + +(*val string_of_gnu_ext_elf32_vernaux : gnu_ext_elf32_vernaux -> string*) +let string_of_gnu_ext_elf32_vernaux vernaux:string= + (unlines [ +("Hash: " ^ Uint32.to_string vernaux.gnu_ext_elf32_vna_hash) + ; ("Flags: " ^ Uint32.to_string vernaux.gnu_ext_elf32_vna_flags) + ; ("Other: " ^ Uint32.to_string vernaux.gnu_ext_elf32_vna_other) + ; ("Name: " ^ Uint32.to_string vernaux.gnu_ext_elf32_vna_name) + ; ("Next: " ^ Uint32.to_string vernaux.gnu_ext_elf32_vna_next) + ]) + +(*val string_of_gnu_ext_elf64_vernaux : gnu_ext_elf64_vernaux -> string*) +let string_of_gnu_ext_elf64_vernaux vernaux:string= + (unlines [ +("Hash: " ^ Uint32.to_string vernaux.gnu_ext_elf64_vna_hash) + ; ("Flags: " ^ Uint32.to_string vernaux.gnu_ext_elf64_vna_flags) + ; ("Other: " ^ Uint32.to_string vernaux.gnu_ext_elf64_vna_other) + ; ("Name: " ^ Uint32.to_string vernaux.gnu_ext_elf64_vna_name) + ; ("Next: " ^ Uint32.to_string vernaux.gnu_ext_elf64_vna_next) + ]) + +(*val gnu_ext_elf32_vernaux_size : natural*) +let gnu_ext_elf32_vernaux_size:Nat_big_num.num= (Nat_big_num.of_int 16) + +(*val gnu_ext_elf64_vernaux_size : natural*) +let gnu_ext_elf64_vernaux_size:Nat_big_num.num= (Nat_big_num.of_int 224) + +(*val read_gnu_ext_elf32_vernaux : endianness -> byte_sequence -> error (gnu_ext_elf32_vernaux * byte_sequence)*) +let read_gnu_ext_elf32_vernaux endian bs0:(gnu_ext_elf32_vernaux*byte_sequence)error= + (read_elf32_word endian bs0 >>= (fun (hsh, bs0) -> + read_elf32_half endian bs0 >>= (fun (flg, bs0) -> + read_elf32_half endian bs0 >>= (fun (otr, bs0) -> + read_elf32_word endian bs0 >>= (fun (nme, bs0) -> + read_elf32_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf32_vna_hash = hsh; gnu_ext_elf32_vna_flags = flg; + gnu_ext_elf32_vna_other = otr; gnu_ext_elf32_vna_name = nme; + gnu_ext_elf32_vna_next = nxt }, bs0))))))) + +(*val read_gnu_ext_elf64_vernaux : endianness -> byte_sequence -> error (gnu_ext_elf64_vernaux * byte_sequence)*) +let read_gnu_ext_elf64_vernaux endian bs0:(gnu_ext_elf64_vernaux*byte_sequence)error= + (read_elf64_word endian bs0 >>= (fun (hsh, bs0) -> + read_elf64_half endian bs0 >>= (fun (flg, bs0) -> + read_elf64_half endian bs0 >>= (fun (otr, bs0) -> + read_elf64_word endian bs0 >>= (fun (nme, bs0) -> + read_elf64_word endian bs0 >>= (fun (nxt, bs0) -> + return ({ gnu_ext_elf64_vna_hash = hsh; gnu_ext_elf64_vna_flags = flg; + gnu_ext_elf64_vna_other = otr; gnu_ext_elf64_vna_name = nme; + gnu_ext_elf64_vna_next = nxt }, bs0))))))) diff --git a/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_types_native_uint.ml b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_types_native_uint.ml new file mode 100644 index 00000000..ec4be185 --- /dev/null +++ b/lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_types_native_uint.ml @@ -0,0 +1,12 @@ +(*Generated by Lem from gnu_extensions/gnu_ext_types_native_uint.lem.*) +(** [gnu_ext_types_native_uint] provides extended types defined by the GNU + * extensions over and above the based ELF types. + *) + +open Missing_pervasives +open Elf_types_native_uint + +(** LSB section 9.2.1.1: in addition to SCO ELF spec types GNU defines an + * additional 1-byte integral type. + *) +type gnu_ext_byte = char diff --git a/lib/ocaml_rts/linksem/hex_printing.ml b/lib/ocaml_rts/linksem/hex_printing.ml new file mode 100644 index 00000000..fe2c42ca --- /dev/null +++ b/lib/ocaml_rts/linksem/hex_printing.ml @@ -0,0 +1,68 @@ +(*Generated by Lem from hex_printing.lem.*) +(** [hex_printing] is a utility module for converting natural numbers and integers + * into hex strings of various widths. Split into a new module as both the + * validation code and the main program need this functionality. + *) + +open Lem_basic_classes +open Lem_list +open Lem_num +open Lem_string + +open Missing_pervasives +open Elf_types_native_uint + +(*val hex_string_of_big_int_no_padding : natural -> string*) +(* declare ocaml target_rep function hex_string_of_big_int_no_padding = `Ml_bindings.hex_string_of_big_int_no_padding` *) +let hex_string_of_big_int_no_padding:Nat_big_num.num ->string= hex_string_of_natural +(*val hex_string_of_big_int_no_padding' : integer -> string*) +(*val hex_string_of_big_int_pad2 : natural -> string*) +(*val hex_string_of_big_int_pad4 : natural -> string*) +(*val hex_string_of_big_int_pad5 : natural -> string*) +(*val hex_string_of_big_int_pad6 : natural -> string*) +(*val hex_string_of_big_int_pad7 : natural -> string*) +(*val hex_string_of_big_int_pad8 : natural -> string*) +(*val hex_string_of_big_int_pad16 : natural -> string*) + +(*val hex_string_of_nat_pad2 : nat -> string*) + +(*val unsafe_hex_string_of_natural : nat -> natural -> string*) +let unsafe_hex_string_of_natural pad m:string= + (if pad = 2 then + Ml_bindings.hex_string_of_big_int_pad2 m + else if pad = 5 then + Ml_bindings.hex_string_of_big_int_pad5 m + else if pad = 4 then + Ml_bindings.hex_string_of_big_int_pad4 m + else if pad = 6 then + Ml_bindings.hex_string_of_big_int_pad6 m + else if pad = 7 then + Ml_bindings.hex_string_of_big_int_pad7 m + else if pad = 8 then + Ml_bindings.hex_string_of_big_int_pad8 m + else if pad = 16 then + Ml_bindings.hex_string_of_big_int_pad16 m + else + hex_string_of_big_int_no_padding m) + +(*val unsafe_hex_string_of_uc_list : list unsigned_char -> string*) +let rec unsafe_hex_string_of_uc_list xs:string= + ((match xs with + | [] -> "" + | x::y::xs -> + let sx = (unsafe_hex_string_of_natural( 2) (Nat_big_num.of_string (Uint32.to_string x))) in + let sy = (unsafe_hex_string_of_natural( 2) (Nat_big_num.of_string (Uint32.to_string y))) in + let sx = +(if String.length sx = 2 then + sx + else + "0" ^ sx) + in + let sy = +(if String.length sy = 2 then + sy + else + "0" ^ sy) + in + sx ^ (" " ^ (sy ^ (" " ^ unsafe_hex_string_of_uc_list xs))) + )) diff --git a/lib/ocaml_rts/linksem/input_list.ml b/lib/ocaml_rts/linksem/input_list.ml new file mode 100644 index 00000000..fe698586 --- /dev/null +++ b/lib/ocaml_rts/linksem/input_list.ml @@ -0,0 +1,317 @@ +(*Generated by Lem from input_list.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_string_extra +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_list_extra +open Lem_sorting +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show + +open Archive +open Command_line +open Elf_types_native_uint +open Elf_file +open Elf_header + +(* Here we elaborate away various properties of the command line: + * archives, groups, library paths, -l, --as-needed, --whole-archive, + * and which inputs can be used to resolve symbols undefined in which other inputs. + * + * What we get out is a list of input files and the options applying to them. + * Input files are either relocatable files, shared objects or linker scripts. + *) + +type input_blob = Reloc of byte_sequence + | Shared of byte_sequence + | Script of byte_sequence + | ControlScript + +(* We remember where the input item came from on the command line, + * using "coordinates" identifying the index in the higher-up list + * followed by the index within that item. *) +type origin_coord = InArchive of (Nat_big_num.num * Nat_big_num.num * string * Nat_big_num.num) (* archive-id, pos-within-archive, archive-name, archive-member-count *) + | InGroup of (Nat_big_num.num * Nat_big_num.num) (* group-id, pos-within-group *) + | InCommandLine of Nat_big_num.num + | Builtin + +(*val string_of_origin_coord : origin_coord -> string*) +let string_of_origin_coord c:string= ((match c with + InArchive(aid, aidx, aname, _) -> "at position " ^ ((Nat_big_num.to_string aidx) ^ (" within archive " ^ (aname ^ (" (at position " ^ ((Nat_big_num.to_string aid) ^ ")"))))) + | InGroup(gid1, gidx) -> "at position " ^ ((Nat_big_num.to_string gidx) ^ (" within group at position " ^ (Nat_big_num.to_string gid1))) + | InCommandLine(cid) -> "(command line)" + | Builtin -> "(built-in)" +)) + +let instance_Show_Show_Input_list_origin_coord_dict:(origin_coord)show_class= ({ + + show_method = string_of_origin_coord}) + +type input_origin = input_unit * origin_coord list + +type input_item = string * input_blob * input_origin + +(*val string_of_input_blob : input_blob -> string*) +let string_of_input_blob item:string= ((match item with + Reloc(seq) -> "relocatable file (" ^ ((Nat_big_num.to_string (Byte_sequence.length0 seq)) ^ " bytes)") + | Shared(seq) -> "shared object (" ^ ((Nat_big_num.to_string (Byte_sequence.length0 seq)) ^ " bytes)") + | Script(seq) -> "script (" ^ ((Nat_big_num.to_string (Byte_sequence.length0 seq)) ^ " bytes)") + | ControlScript -> "the linker control script" +)) + +let instance_Show_Show_Input_list_input_blob_dict:(input_blob)show_class= ({ + + show_method = string_of_input_blob}) + +(*val short_string_of_input_item : input_item -> string*) +let short_string_of_input_item item:string= + (let (fname1, blob, (u, origin)) = item + in + (match origin with + InArchive(aid, aidx, aname, _) :: _ -> aname ^ ("(" ^ (fname1 ^ ")")) + | _ -> fname1 + )) + +(* About symbol resolution and "suppliers". + * + * Groups change this. + * + * When we expand a .a file into a list of .o files, what is the supplier + * relation among them? I *THINK* that within the archive, each can supply any other, + * but outside the archive, each can only supply leftmore. + *) + +type can_supply_function = input_item list -> int -> bool list + +type input_options = { item_fmt : string + ; item_check_sections : bool + ; item_copy_dt_needed : bool + ; item_force_output : bool (* true for .o, false for .a unless --whole-archive, + true for .so with --no-as-needed, + false for .so with --as-needed *) + } + +(*val null_input_options : input_options*) +let null_input_options:input_options= + ({ item_fmt = "" + ; item_check_sections = false + ; item_copy_dt_needed = false + ; item_force_output = true + }) + +(*val string_of_input_options : input_options -> string*) +let string_of_input_options opts:string= "(some options)" + +let instance_Show_Show_Input_list_input_options_dict:(input_options)show_class= ({ + + show_method = string_of_input_options}) + +type input_list = (input_item * input_options) list + +(*val toplevel_dot_o_can_supply : list input_item -> nat -> list bool*) +let toplevel_dot_o_can_supply inputs pos:(bool)list= + (Lem_list.genlist (fun _ -> true) (List.length inputs)) + +(*val toplevel_shared_can_supply : list input_item -> nat -> list bool*) +let toplevel_shared_can_supply inputs pos:(bool)list= + (Lem_list.genlist (fun ndx -> ndx <= pos) (List.length inputs)) + +(*val toplevel_archive_can_supply : list input_item -> nat -> list bool*) +let toplevel_archive_can_supply inputs pos:(bool)list= + (Lem_list.genlist (fun ndx -> ndx <= pos) (List.length inputs)) + +(*val lib_filename_from_spec : string -> string -> string*) +let lib_filename_from_spec spec ext:string= + ((match (Xstring.explode spec) with + ':' :: more -> (Xstring.implode more) + | _ -> "lib" ^ (spec ^ ("." ^ ext)) + )) + +(*val find_library_in : string -> list string -> list string -> maybe string*) +let find_library_in spec extensions pathlist:(string)option= +( + (* Recall the GNU libc's "libc.so is a linker script" hack. + * This tells us that we should only look at file extensions, not contents. *)let file_exists name1= + ((match Byte_sequence.acquire name1 with (* FIXME: use cheaper call *) + Success _ -> true + | Fail _ -> false + )) + in + let expand_candidate_libname = (fun path -> fun ext -> (path ^ ("/" ^ (lib_filename_from_spec spec ext)))) + in + let get_expansions_existing = (fun path -> + let x2 = ([]) in List.fold_right (fun cand x2 -> if file_exists cand then cand :: x2 else x2) + (Lem_list.map (expand_candidate_libname path) extensions) x2) + in + let found_by_path = (Lem_list.map (fun path -> (path, get_expansions_existing path)) pathlist) + in + (* Do we take the first path for which some extension is found? + * Or do we keep going if we prefer shared libraries, say? + * I think it's the former. *) + (match Lem_list.list_find_opt (fun (path, exps) -> (List.length exps) > 0) found_by_path with + Some (path, exps) -> Some(List.hd exps) + | None -> None + )) + +(*val find_one_library_filename : input_file_options -> string -> string*) +let find_one_library_filename options str:string= + (let extensions = (if options.input_link_sharedlibs then ["so"; "a"] else ["a"]) + in + let found = (find_library_in str extensions options.input_libpath) + in (match found with + None -> failwith ("couldn't find library matching '" ^ (str ^ "'")) + | Some result -> result + )) + +(*val is_elf64_with_type : elf64_half -> byte_sequence -> bool*) +let is_elf64_with_type typ seq:bool= +( + (*let _ = Missing_pervasives.errs ("elf64? " ^ + (match seq with Sequence(bs) -> show (List.take 16 bs) end)) + in*)(match Elf_file.read_elf64_file seq with + Success(e) -> (* let _ = Missing_pervasives.errln ": yes" in *) (e.elf64_file_header.elf64_type = typ) + | Fail _ -> (* let _ = Missing_pervasives.errln ": no" in *) false + )) + +(*val is_archive : byte_sequence -> bool*) +let is_archive seq:bool= + ((match read_archive_global_header seq with + Success _ -> true + | Fail _ -> false + )) + +(*val open_file_and_expand : string -> input_unit -> natural -> list input_item*) +let open_file_and_expand toplevel_fname u fpos:(string*input_blob*(input_unit*(origin_coord)list))list= + ((match Byte_sequence.acquire toplevel_fname with + Fail _ -> failwith ("could not open file " ^ toplevel_fname) + | Success seq -> + if is_elf64_with_type (Uint32.of_string (Nat_big_num.to_string elf_ft_rel)) seq + then [(toplevel_fname, Reloc(seq), (u, []))] + else if is_elf64_with_type (Uint32.of_string (Nat_big_num.to_string elf_ft_dyn)) seq + then [(toplevel_fname, Shared(seq), (u, []))] + else if is_archive seq + then + (match read_archive seq with + Fail _ -> failwith ("could not read archive " ^ toplevel_fname) + | Success (pairs : (string * byte_sequence) list) -> + (*let _ = Missing_pervasives.errln (toplevel_fname ^ " is an archive with " ^ (show (List.length pairs)) ^ " members") + in*) + let not_elf = (List.filter (fun (inner_fname, seq) -> not (is_elf64_with_type (Uint32.of_string (Nat_big_num.to_string elf_ft_rel)) seq)) pairs) + in + if List.length not_elf = 0 + then mapMaybei + (fun (i : Nat_big_num.num) -> (fun ((inner_fname : string), seq) -> + let (trimmed_inner_fname : string) = ((match ((Ml_bindings.string_index_of '/' inner_fname) : Nat_big_num.num option) with + None -> inner_fname + | Some (ind : Nat_big_num.num) -> (match Ml_bindings.string_prefix ind inner_fname with + Some s -> s + | None -> failwith "impossible: string has character index >= its length" + ) + )) + in + Some (trimmed_inner_fname, Reloc(seq), (u, [InArchive(fpos, i, toplevel_fname, length pairs)])) + )) pairs + else let (names, seqs) = (List.split not_elf) in + failwith ("archive with unsupported contents" (*(" ^ (show names) ^ ")*)) + ) + else [(toplevel_fname, Script(seq), (u, []))] + )) + +(*val make_input_items_and_options : list input_item -> Command_line.input_file_options -> list origin_coord -> list (input_item * input_options)*) +let make_input_items_and_options file_list cmdopts coords_to_append:((string*input_blob*(input_unit*(origin_coord)list))*input_options)list= + ((match file_list with + [] -> failwith "impossible: empty list of files" + | [(fname1, Reloc(seq), (u, coords))] -> + [((fname1, Reloc(seq), (u, List.rev_append (List.rev coords) coords_to_append)), + { item_fmt = (cmdopts.input_fmt) + ; item_check_sections = (cmdopts.input_check_sections) + ; item_copy_dt_needed = (cmdopts.input_copy_dt_needed) + ; item_force_output = true + })] + | [(fname1, Shared(seq), (u, coords))] -> + [((fname1, Shared(seq), (u, List.rev_append (List.rev coords) coords_to_append)), + { item_fmt = (cmdopts.input_fmt) + ; item_check_sections = (cmdopts.input_check_sections) + ; item_copy_dt_needed = (cmdopts.input_copy_dt_needed) + ; item_force_output = (if cmdopts.input_as_needed then false else true) + })] + | [(fname1, Script(seq), (u, coords))] -> + [((fname1, Script(seq), (u, List.rev_append (List.rev coords) coords_to_append)), + { item_fmt = (cmdopts.input_fmt) + ; item_check_sections = (cmdopts.input_check_sections) + ; item_copy_dt_needed = (cmdopts.input_copy_dt_needed) + ; item_force_output = true + })] + | _ -> (* guaranteed to be all relocs, from one archive *) + let (items_and_options : (input_item * input_options) list) = + (mapMaybei (fun i -> (fun (fname1, reloc1, (u, coords)) -> + let (item : input_item) = (fname1, reloc1, (u, List.rev_append (List.rev coords) coords_to_append)) + in + let (options : input_options) = + ({ item_fmt = (cmdopts.input_fmt) + ; item_check_sections = (cmdopts.input_check_sections) + ; item_copy_dt_needed = (cmdopts.input_copy_dt_needed) + ; item_force_output = (if cmdopts.input_whole_archive then true else false) + }) + in Some (item, options) + )) file_list) + in items_and_options + | _ -> failwith "impossible expanded input item" + )) + +(*val elaborate_input_helper : natural -> list Command_line.input_unit -> input_list -> input_list*) +let rec elaborate_input_helper input_pos inputs acc:(input_item*input_options)list= + ((match inputs with + [] -> acc + | input :: more_inputs -> + (match input with + File(spec, options) + -> (match spec with + Filename(str) + -> elaborate_input_helper ( Nat_big_num.add input_pos(Nat_big_num.of_int 1)) more_inputs + ( List.rev_append (List.rev acc) (make_input_items_and_options + (open_file_and_expand str input input_pos) options [InCommandLine(input_pos)])) + | Libname(str) + -> elaborate_input_helper ( Nat_big_num.add input_pos(Nat_big_num.of_int 1)) more_inputs + ( List.rev_append (List.rev acc) (make_input_items_and_options + (open_file_and_expand (find_one_library_filename options str) input input_pos) + options [InCommandLine(input_pos)])) + ) + | Group(specs_and_options) -> + (* Every member of a group is either a filename or a libname. + * First expand the libnames, leaving the Group intact. *) + let group_with_lib_files + = (Lem_list.map (fun (spec, options) -> (match spec with + Filename(str) -> (str, options) + | Libname(str) -> (find_one_library_filename options str, options) + )) specs_and_options) + in + (* Now expand archives into file lists. *) + let group_with_file_lists + = (mapMaybei (fun i -> (fun (str, options) -> + Some ((open_file_and_expand str input input_pos), options) + )) group_with_lib_files) + in + (* Now expand them into files and fix up the options appropriately *) + let to_add + = (mapMaybei (fun index_in_group -> (fun (file_list, options) -> ( + Some( + make_input_items_and_options file_list options [InGroup(input_pos, index_in_group); InCommandLine(input_pos)] + )))) group_with_file_lists) + in + elaborate_input_helper ( Nat_big_num.add input_pos(Nat_big_num.of_int 1)) more_inputs ( List.rev_append (List.rev acc) (List.concat to_add)) + ) + )) + +(*val elaborate_input : list Command_line.input_unit -> input_list*) +let rec elaborate_input inputs:(input_item*input_options)list= (elaborate_input_helper(Nat_big_num.of_int 0) inputs []) diff --git a/lib/ocaml_rts/linksem/link.ml b/lib/ocaml_rts/linksem/link.ml new file mode 100644 index 00000000..1265de61 --- /dev/null +++ b/lib/ocaml_rts/linksem/link.ml @@ -0,0 +1,1005 @@ +(*Generated by Lem from link.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_map +open Lem_set +(*import Set_extra*) +open Lem_num +open Lem_maybe +open Lem_assert_extra +(*import Command_line*) +(*import Input_list*) + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show +open Endianness + +open Elf_header +open Elf_interpreted_section +open Elf_interpreted_segment +open Elf_section_header_table +open Elf_program_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation + +open Abis +open Abi_amd64_relocation (* HACK -- remove me *) + +open Input_list +open Linkable_list +(*import Command_line*) + +open Memory_image +open Memory_image_orderings +open Elf_memory_image +open Elf_memory_image_of_elf64_file +open Linker_script + +let all_common_symbols img2:(symbol_definition)list= (List.filter (fun def -> Nat_big_num.equal + (Nat_big_num.of_string (Uint32.to_string def.def_syment.elf64_st_shndx)) shn_common +) (elf_memory_image_defined_symbols img2)) + +(* Q. On what does the decision about a reloc depend? definitely on + * + * -- command-line options applying to the referenc*ed* object; + * (CHECK: I'm inferring that -Bsymbolic, like -Bstatic, applies to the + * *referenced* object, not the referring -- need experimental conf.) + * ACTUALLY, it seems to be global: if a definition goes in the library, + * bind to it; doesn't matter where it comes from. So + * + * -- command-line options applying to the output object / whole link (-Bsymbolic); + * + * -- command-line options applying to the referencing object? + * + * What decision can we make? + * Given a reloc, it might be + * - not bound (weak symbols) -- THIS MEANS it *is* bound but to the value 0! + * - bound to a definition + * + * ... perhaps our distinction is between "firm binding or provisional binding"? + * "final binding or overridable binding"? + * + * Can we also hit cases where the binding is final but can't be relocated til load time? + * YES, e.g. any final R_*_64_64 reference in a shared library's data segment. + * WHAT do we do in these cases? Apply what we can and generate a R_*_RELATIVE? + * Yes, that's where R_*_RELATIVE come from, since they don't appear in .o inputs. + *) + +(*val def_is_in_reloc : linkable_item -> bool*) +let def_is_in_reloc def_item:bool= ((match def_item with + (RelocELF(_), _, _) -> true + | (ScriptAST(_), _, _) -> true + | _ -> false +)) + +let retrieve_binding_for_ref dict_Basic_classes_Eq_b r r_linkable_idx item bindings_by_name:('b*symbol_reference*'d)*'c= + (let maybe_found_bs = (Pmap.lookup r.ref.ref_symname bindings_by_name) + in + (match maybe_found_bs with + None -> failwith "impossible: list of bindings does not include symbol reference (map empty)" + (* FIXME: could this actually be an "undefined symbol" link error perhaps? *) + | Some bis_and_bs -> (match List.filter (fun (b_idx, ((b_ref_idx, b_ref, b_ref_item), b_maybe_def)) -> + if dict_Basic_classes_Eq_b.isEqual_method b_ref_idx r_linkable_idx && (b_ref = r.ref) then + (*let _ = Missing_pervasives.errln ("saw ref from linkable idx " ^ (show r_linkable_idx) + ^ ", ref sym scn " ^ (show r.ref.ref_sym_scn) ^ ", ref sym idx "^ (show r.ref.ref_sym_idx) + ^ ", item " ^ (show item) ^ "; binding to " ^ ( + match b_maybe_def with + Just (def_idx, def, def_item) -> "linkable idx " ^ (show def_idx) ^ + ", def sym scn " ^ (show def.def_sym_scn) ^ ", def sym idx " ^ + (show def.def_sym_idx) + | Nothing -> "no definition" + end + ) + ) + in*) true + else false) bis_and_bs with + [] -> failwith "impossible: list of bindings does not include symbol reference (filtered list empty)" + | [(bi, b)] -> b + | _ -> failwith ("impossible: list of bindings binds reference to symbol `" + ^ (r.ref.ref_symname ^ "' more than one way (filtered list has >1 element)")) + ) + )) + +type reloc_site_resolution = reloc_site * binding * reloc_decision + + +(*val mark_fate_of_relocs : natural -> abi any_abi_feature -> set Command_line.link_option -> + binding_map -> linkable_item -> elf_memory_image -> ((list reloc_site_resolution) * elf_memory_image)*) +let mark_fate_of_relocs linkable_idx a options bindings_by_name item img2:(reloc_site*((Nat_big_num.num*symbol_reference*(linkable_object*input_item*input_options))*(Nat_big_num.num*symbol_definition*(linkable_object*input_item*input_options))option)*reloc_decision)list*(any_abi_feature)annotated_memory_image= +( + (* Our image already models relocation sites. For each relocation *record*, + * we use our bindings to make a decision about whether to apply it or not. + * + * Q1. How do we get the .rela.dyn made? Synthesise a fake reloc section? + * Or pass them through to the linker script separately? + * AHA. Note that the script already has an entry for .rela.dyn. + * And it matches the ordinary rel sections, e.g. .rela.text and so on. + * So if "-q" is active, the applied relocs need to be injected back in *after* the script + * has run. + * So we need both to materialize some relocs into the script inputs, *and* save some for later. + * + * Can we just use memory image metadata as the "saved for later" case? YES, I think so. + * What do we do with metadata that is now being materialized? + * I think we should only remove the metadata when we apply the relocation. + * Q. When do we do that? + * A. *After* address assignment has happened, i.e. all sections are allocated. + *)let building_executable = (Pset.mem (Command_line.OutputKind(Command_line.Executable)) options) in + let building_shared_library = (Pset.mem (Command_line.OutputKind(Command_line.SharedLibrary)) options) in + let bind_functions_early = (Pset.mem Command_line.BindFunctionsEarly options) in + let bind_non_functions_early = (Pset.mem Command_line.BindNonFunctionsEarly options) in + let (new_by_tag, rev_decisions) = (List.fold_left (fun (acc_by_tag, rev_acc_decisions) -> (fun (tag, maybe_range) -> + let pass_through = (Pset.add (tag, maybe_range) acc_by_tag, rev_acc_decisions) + in + (match tag with + SymbolRef(r) -> + (match r.maybe_reloc with + Some reloc1 -> + (* decision: do we want to + * - apply it? if so, do we need a consequent relocation (e.g. R_*_RELATIVE) in the output? + * - PICify it, but leave it interposable? + * - is "PICified, non-interposable" a thing? I don't think so, because non-interposable bindings are + either intra-object *or* necessarily need load-time relocation to account for load addresses. + In fact ELF can't express "non-interposable inter-object bindings" because we can't name + specific objects when binding symbols. + * - leave it alone, i.e. "relocate at load time"? + * + * Some useful questions: is the binding final? + * The GNU linker *never* leaves text relocs alone when generating shared libs; + * it always PICifies them. + * It can leave them alone when generating executables, though. + * This is an approximation; load-time text relocation can make sense for shared libs. + * (but it's dangerous because PC32 relocs might overflow) + *) + let (binding_is_final : Command_line.link_option Pset.set -> binding -> bool) + = (fun options -> (fun ((ref_idx, ref1, ref_item), maybe_def) -> + (match maybe_def with + (* Weak bindings to 0 are final (though libcrunch wishes they weren't!). *) + None -> true + | Some (def_idx, def, def_item) -> Nat_big_num.equal +( + (* Bindings to non-global symbols are final. *)get_elf64_symbol_binding def.def_syment) stb_local + || +( + (* Bindings to hidden- or protected- or internal-visibility globals + * are final. *)Pset.mem (get_symbol_visibility def.def_syment.elf64_st_info)(Pset.from_list Nat_big_num.compare [ stv_hidden; stv_protected; stv_internal ]) + || +( + (* Bindings to global symbols are non-final + * *unless* + * 1. the symbol definition is [going to end up] in the executable + * 2. we're -Bsymbolic, outputting a shared object, + * and the symbol definition is [going to end up] within the same shared object + * 3. we're -Bsymbolic-functions, outputting a shared object, + * and the symbol definition has STT_FUNC and is [going to end up] within the same shared object + * + * ... where "going to end up in an X" means "we're building an X and def is in a RelocELF rather than a SharedELF". + *) + (* 1. *)(building_executable && def_is_in_reloc def_item) || + (* 2 and 3. *) + (building_shared_library && (def_is_in_reloc def_item && + ( ( Nat_big_num.equal(get_elf64_symbol_type def.def_syment) stt_func && bind_functions_early) + || ( not (Nat_big_num.equal (get_elf64_symbol_type def.def_syment) stt_func) && bind_non_functions_early) + )) + ))) + (* FIXME: does it matter if the binding is intra-object or inter-object? + * We don't get inter-object bindings much to non-{default global}s. How much? *) + ))) + in + let (reloc_is_absolute : reloc_site -> bool) = (fun rs -> + let kind = (get_elf64_relocation_a_type rs.ref_relent) in + let (is_abs, _) = (a.reloc kind) in + is_abs) + in + (* What's our decision for this reloc? leave, apply, MakePIC? + * In fact we return both a decision and a maybe-function to create + * the consequent reloc. + * In what circumstances do we leave the reloc? If we're making an executable + and the definition is not in a relocatable input file or archive or script. + Or if we're making a shared library and the reference is "from data". + What does "from data" mean? I think it means it's a PC-relative reloc. + If we compile our code to do movabs $addr, even from a *local* address, + it's not PIC because that address needs load-time fixup. + So actually it's "is absolute address" again. + *) + let b = (retrieve_binding_for_ref + instance_Basic_classes_Eq_Num_natural_dict r linkable_idx item bindings_by_name) + in + let ((ref_idx, _, ref_item), maybe_def) = b + in + let defined_in_shared_lib = ((match maybe_def with + Some (def_idx, def, def_item) -> not (def_is_in_reloc def_item) + | None -> false (* i.e. the "definition", 0, can be "linked in" *) + )) + in + let decide = (fun decision -> ( + (*let _ = errln ("Decided to " ^ match decision with + LeaveReloc -> "leave" + | ApplyReloc -> "apply" + end ^ " relocation in linkable " ^ (show ref_item) ^ "'s image, bound to " ^ + match maybe_def with + Just(def_idx, def, def_item) -> "a definition called `" ^ def.def_symname ^ "' in linkable " ^ + (show def_item) + | Nothing -> "no definition" + end + ) + in*) + Pset.add (SymbolRef({ + ref = (r.ref) + ; maybe_reloc = (r.maybe_reloc) + ; maybe_def_bound_to = (Some (decision, + (match maybe_def with + Some(def_idx, def, def_item) -> + Some { def_symname = (def.def_symname) + ; def_syment = (def.def_syment) + ; def_sym_scn = (def.def_sym_scn) + ; def_sym_idx = (def.def_sym_idx) + ; def_linkable_idx = def_idx + } + | None -> None + ) + )) + } + ), maybe_range) acc_by_tag, +((reloc1, b, decision) :: rev_acc_decisions))) + in + if (building_executable && defined_in_shared_lib) + || (building_shared_library && (reloc_is_absolute reloc1)) + then decide LeaveReloc + else + (* In what circumstances do we apply the reloc? If it's a final binding. *) + if binding_is_final options b then decide ApplyReloc + (* In what circumstances do we MakePIC? If it's a non-absolute relocatable field + * and we're building a shared library. + * + * PIC is a kind of "consequent relocation", so let's think through it. + * A call site that calls <printf> will usually be non-final (overridable). + * Output needs to call <printf@plt>. BUT the trick is as follows: + * the reloc is swizzled so that it binds to the PLT slot <printf@plt>; + * the PLT slot is locally generated, so no reloc is needed. + * So the point is that + * a *non*-applied reloc + * might still need "applying" after a fashion (swizzling). + * The initial reloc is removed! Since PLT means removing relocs from code + * and reproducing their effect using a PLT. + * That's why we need this special MakePIC behaviour. + * Actually, generalise to a ChangeRelocTo. + * + * What about data? + * Suppose I have a shared library containing a read-only pointer to <environ>. + * The binding is final because <environ> is defined in the executable, say. + * PIC doesn't handle this case -- we still need load-time relocation. + * It's PIC, not PID: data can't be made position-independent. + * + * So, at least for simple cases of PIC, we don't need consequent relocation if + * we don't apply the reloc. We'll be removing the reloc. But we *do* need to create + * extra stuff later (PLT, GOT). + *) + else if building_shared_library then decide (* MakePIC *) (ChangeRelocTo(Nat_big_num.of_int 0, r.ref, reloc1)) (* FIXME *) + (* The above are non-exclusive and non-exhaustive. Often, more than one option is available, + * ABIs / practice makes an arbitrary choice. For example, final bindings + * within a library could be realised the PIC way, but aren't (it'd create a + * pointless indirection). *) + else failwith "didn't know what to do with relocation" + | None -> + (* symbol ref with no reloc *) + pass_through + ) + | _ -> pass_through + ) + )) ((Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) []), []) (Pset.elements img2.by_tag)) + in + (List.rev rev_decisions, { elements = (img2.elements) + ; by_tag = new_by_tag + ; by_range = (by_range_from_by_tag + instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) new_by_tag) + })) + +(*val strip_metadata_sections : list (reloc_site * binding * reloc_decision) -> abi any_abi_feature -> elf_memory_image -> elf_memory_image*) +let strip_metadata_sections reloc_decisions a img2:(any_abi_feature)annotated_memory_image= + (let (section_tags, section_ranges) = (elf_memory_image_section_ranges img2) + in + let rel_sections = (Lem_list.mapMaybe (fun (range_tag1, (el_name, el_range)) -> + (match range_tag1 with + FileFeature(ElfSection(idx1, isec1)) -> + if Pset.mem isec1.elf64_section_type(Pset.from_list Nat_big_num.compare [ sht_rel; sht_rela ]) + then Some (idx1, isec1, el_name) + else None + | _ -> None + ) + ) (list_combine section_tags section_ranges)) + in + let discarded_sections_with_element_name = (Lem_list.mapMaybe (fun (range_tag1, (el_name, el_range)) -> + (match range_tag1 with + FileFeature(ElfSection(idx1, isec1)) -> + if a.section_is_special isec1 img2 (* discard reloc sections, and we'll re-add them *) + then Some (el_name, range_tag1) else None + ) + ) (list_combine section_tags section_ranges)) + in + let discarded_elements_map = (List.fold_left (fun m -> (fun (el_name, range_tag1) -> + (*let _ = errln ("Discarding a metadata element named `" ^ el_name ^ "'") in*) + Pmap.add el_name range_tag1 m + )) (Pmap.empty compare) discarded_sections_with_element_name) + in + let filtered_image = (Memory_image.filter_elements (fun (el_name, el) -> not (Pmap.mem el_name discarded_elements_map)) img2) + in + let new_reloc_section_length = (fun idx1 -> (fun isec1 -> + let retained_relocs_from_this_section = (let x2 = + ([]) in List.fold_right + (fun(reloc1, b, decision) x2 -> + if Nat_big_num.equal (* is it from this section? *) reloc1.ref_rel_scn + idx1 (* are we retaining it? *) && (decision = LeaveReloc) then + (reloc1, b, decision) :: x2 else x2) reloc_decisions x2) + in Nat_big_num.mul (length retained_relocs_from_this_section) isec1.elf64_section_entsize + )) + in + let (new_reloc_elements, new_reloc_tags_and_ranges) = (List.split (let x2 = + ([]) in List.fold_right + (fun(idx1, isec1, el_name) x2 -> + if Nat_big_num.greater (new_reloc_section_length idx1 isec1) + (Nat_big_num.of_int 0) then + (let new_len = (new_reloc_section_length idx1 isec1) in + let new_el = ({ startpos = None ; length1 = (Some new_len); contents = + ([]) }) in + let new_isec = ({ elf64_section_name = (isec1.elf64_section_name) + ; elf64_section_type = (isec1.elf64_section_type) + ; elf64_section_flags = (isec1.elf64_section_flags) + ; elf64_section_addr =(Nat_big_num.of_int 0) (* should be 0 anyway *) + ; elf64_section_offset =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_size = new_len + ; elf64_section_link = (isec1.elf64_section_link) + ; elf64_section_info = (isec1.elf64_section_info) + ; elf64_section_align = (isec1.elf64_section_align) + ; elf64_section_entsize = (isec1.elf64_section_entsize) + ; elf64_section_body = Byte_sequence.empty (* ignored *) + ; elf64_section_name_as_string = (isec1.elf64_section_name_as_string) + }) in + let new_meta = (FileFeature (ElfSection (idx1, new_isec))) in + ((el_name, new_el), (new_meta, Some + (el_name, (Nat_big_num.of_int 0, new_len))))) + :: x2 else x2) rel_sections x2)) + in + let new_by_tag = (Pset.bigunion (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))))(Pset.from_list (Pset.compare_by (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))))) [ filtered_image.by_tag; (Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) new_reloc_tags_and_ranges) ])) + in + { + elements = (List.fold_right Pmap.union [filtered_image.elements; Lem_map.fromList + (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) new_reloc_elements] (Pmap.empty compare)) + ; by_tag = new_by_tag + ; by_range = (by_range_from_by_tag + instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) new_by_tag) + }) + + +let expand_sections_for_one_image a options bindings_by_name linkable_idx item strip_relocs:(reloc_site*binding*reloc_decision)list*(any_abi_feature)annotated_memory_image*(input_spec)list= + ((match item with + (RelocELF(img2), (fname1, blob, origin), input_opts) -> + (*let _ = List.foldl (fun _ -> fun (isec, shndx) -> + let _ = errln ("For file " ^ fname ^ " before stripping, saw section idx " ^ (show shndx) ^ + " with name " ^ isec.elf64_section_name_as_string ^ ", first 20 bytes: " ^ (show (take 20 ( + (let maybe_elname = elf_memory_image_element_coextensive_with_section shndx img + in + match maybe_elname with + Nothing -> failwith ("impossible: no such section (" ^ (show shndx) ^ ") in image of " ^ fname) + | Just idstr -> + match Map.lookup idstr img.elements with + Just el -> el.contents + | Nothing -> failwith "no such element" + end + end + ))))) + in + () + ) () (elf_memory_image_sections_with_indices img) + in*) + let ((reloc_decisions : (reloc_site * binding * reloc_decision) list), marked_img) = (mark_fate_of_relocs linkable_idx a options bindings_by_name item img2) + in + (* Now we have a decision for each reloc: Leave, Apply, MakePIC. Which ones + * do we materialize? Only the Leave ones, for now. To support -q we'll + * have to support tweaking this. + * + * For each relocation that we Leave, we figure out its originating section + * and re-create a lookalike in the memory image. + * + * We also get called for the "generated" memory image that contains .plt, + * .rela.plt and so on. We don't strip these, since they actually contain relocs + * that need to go directly into the output file. That's what the strip_relocs + * argument is for. FIXME: refactor this into two functions. + *) + let stripped_img_with_reloc_sections = (if strip_relocs + then (*let _ = errln ("Discarding metadata sections from image of `" ^ fname ^ "'") in*) + strip_metadata_sections reloc_decisions a marked_img + else marked_img) + in + (* Now we have a whole new image! It differs from the old one in that + * - non-special sections have been stripped + * - the relocs we want to participate in linking have been materialized. + *) + (* The "-q" option is tricky. It causes all incoming relocs to be retained, but + * they *don't* participate in linking -- notice that the default linker script + * pulls all .rela.* sections into .rela.dyn, whereas these ones *don't* go in there. + * So FIXME: to support this, we need a way to re-add them, probably when we + * generate meta-output like .symtab etc.. *) + let inputs = + + (List.rev_append (List.rev (let x2 = + ([]) (* not (a.section_is_special isec img *)in + List.fold_right + (fun(isec1, shndx1) x2 -> + if true then + (let short_name = (short_string_of_linkable_item item) in + (*let _ = errln ("For file " ^ short_name ^ " after stripping, saw section idx " ^ (show shndx) ^ + " with name " ^ isec.elf64_section_name_as_string ^ ", first 20 bytes: " ^ (show (take 20 ( + (let maybe_elname = elf_memory_image_element_coextensive_with_section shndx stripped_img_with_reloc_sections + in + match maybe_elname with + Nothing -> failwith ("impossible: no such section (matching " ^ (show shndx) ^ ")") + | Just idstr -> + match Map.lookup idstr stripped_img_with_reloc_sections.elements with + Just el -> el.contents + | Nothing -> failwith "no such element" + end + end + ))))) + in*) + InputSection + ({ idx = linkable_idx ; fname = short_name + ; img = stripped_img_with_reloc_sections ; shndx = shndx1 + ; secname = (isec1.elf64_section_name_as_string) ; isec = isec1 + })) :: x2 else x2) + (elf_memory_image_sections_with_indices stripped_img_with_reloc_sections) + x2)) ( + (* One item per common symbol. FIXME: what about common symbols that have the same name? + * We need to explicitly instantiate common symbols somewhere, probably here. + * This means dropping any that are unreferenced (does it?) and merging any multiply-defined. + * Actually, we deal with section merging at the same time as section concatenation, so during + * linker script processing. For discarding unused common symbols, I *think* that this has already + * been done by discarding unreferenced inputs. *) + let common_symbols = (all_common_symbols stripped_img_with_reloc_sections) + in + (*let _ = errln ("Expanding " ^ (show (length common_symbols)) ^ " common symbols") + in*) + let x2 = ([]) in List.fold_right + (fun def x2 -> + if + (*let _ = Missing_pervasives.outln ((space_padded_and_maybe_newline 20 def.def_symname) + ^ (let hexstr = "0x" ^ (hex_string_of_natural (natural_of_elf64_xword def.def_syment.elf64_st_size)) + in + space_padded_and_maybe_newline 20 hexstr + ) + ^ + fname) + in*) + true then + Common (linkable_idx, fname1, stripped_img_with_reloc_sections, def) :: + x2 else x2) common_symbols x2 + )) + in (reloc_decisions, stripped_img_with_reloc_sections, inputs) + | _ -> failwith "non-reloc linkable not supported yet" +)) + +type reloc_resolution = reloc_site * binding * reloc_decision + +(*val default_merge_generated : abi any_abi_feature -> elf_memory_image -> list (list Linker_script.input_spec) -> list (list Linker_script.input_spec)*) +let default_merge_generated a generated_img input_spec_lists:((input_spec)list)list= +( + (* We expand the sections in the generated image and hang them off + * the first linkable item. *) + (*let _ = errln ("Generated image has " ^ (show (Map.size generated_img.elements)) ^ " elements and " ^ (show (Set.size (generated_img.by_tag))) ^ + " metadata elements (sanity: " ^ (show (Set.size (generated_img.by_range))) ^ ")") + in*)let dummy_input_item = ("(no file)", Input_list.Reloc(Sequence([])), ((Command_line.File(Command_line.Filename("(no file)"), Command_line.null_input_file_options)), [InCommandLine(Nat_big_num.of_int 0)])) + in + let dummy_linkable_item = (RelocELF(generated_img), dummy_input_item, Input_list.null_input_options) + in + let (_, _, generated_inputs) = (expand_sections_for_one_image a(Pset.from_list compare []) (Pmap.empty compare)(Nat_big_num.of_int 0) dummy_linkable_item false) + in + (*let _ = errln ("Generated image yielded " ^ (show (length generated_inputs)) ^ " input items") + in*) + (* okay, hang them off the first one *) + (match input_spec_lists with + [] -> failwith "link job empty" + | first_input_list :: more_input_lists -> ( List.rev_append (List.rev first_input_list) generated_inputs) :: more_input_lists + )) + (* input_spec_lists *) + +(*val expand_sections_for_all_inputs : abi any_abi_feature -> set Command_line.link_option -> binding_map -> + (abi any_abi_feature -> elf_memory_image -> list (list Linker_script.input_spec) -> list (list Linker_script.input_spec)) (* merge_generated *) -> + list (natural * Linkable_list.linkable_item) -> + list (list reloc_resolution * elf_memory_image * list Linker_script.input_spec)*) +let expand_sections_for_all_inputs a options bindings_by_name merge_generated idx_and_linkables:((reloc_site*binding*reloc_decision)list*(any_abi_feature)annotated_memory_image*(input_spec)list)list= + (let (expanded_reloc_lists, expanded_imgs, linker_script_input_lists) = (unzip3 (Lem_list.map (fun (idx1, linkable) -> + expand_sections_for_one_image a options bindings_by_name idx1 linkable true) idx_and_linkables)) + in + let fnames = (Lem_list.map (fun (idx1, (_, (fname1, _, _), _)) -> fname1) idx_and_linkables) + in + (* We pass the collection of linkable images and reloc decision lists + * to an ABI tap function. + * + * This returns us a new *image* containing all the elements. Logically + * this is another participant in the link, which we could expand separately. + * A personality function takes care of actually merging it back into the + * linker script inputs... in the case of the GNU linker, this means pretending + * the generated stuff came from the first input object. + *) + let generated_img = (a.generate_support (* expanded_relocs *) (list_combine fnames expanded_imgs)) + in + (* We need to return a + * + * list (list reloc_decision * elf_memory_image * list Linker_script.input_spec) + * + * i.e. one item for every input image. *) + let (final_input_spec_lists : ( Linker_script.input_spec list) list) = (merge_generated a generated_img linker_script_input_lists) + in + zip3 expanded_reloc_lists expanded_imgs final_input_spec_lists) + +(*val relocate_output_image : abi any_abi_feature -> map string (list (natural * binding)) -> elf_memory_image -> elf_memory_image*) +let relocate_output_image a bindings_by_name img2:(any_abi_feature)annotated_memory_image= + (let relocs = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (SymbolRef(null_symbol_reference_and_reloc_site)) + img2.by_tag) + in + + (*let _ = errln ("For __libc_multiple_threads (in relocate_output_image), we have " ^ + (let all_bs = match Map.lookup "__libc_multiple_threads" bindings_by_name with + Just l -> l + | Nothing -> [] + end + in + ((show (length all_bs)) ^ + " bindings, of which " ^ + (show (length (List.filter (fun (bi, ((ref_idx, ref, ref_item), maybe_def)) -> + match maybe_def with + Just _ -> true + | _ -> false + end + ) all_bs))) ^ " have defs"))) + in*) + let apply_reloc = (fun img2 -> fun (el_name, start, len) -> fun symref_and_reloc_site -> fun symaddr -> ( + let reloc_site1 = ((match symref_and_reloc_site.maybe_reloc with + None -> failwith "impossible: no reloc site during relocation" + | Some r -> r + )) + in + let (field_is_absolute_addr, applyfn) = (a.reloc (get_elf64_relocation_a_type reloc_site1.ref_relent)) + in + let element1 = ((match Pmap.lookup el_name img2.elements with + None -> failwith "impossible: reloc site in nonexistent section" + | Some e -> e + )) + in + let site_address = ((match element1.startpos with + Some addr -> Nat_big_num.add addr start + | None -> failwith "error: relocation in section with no address" + )) + in + let (width, calculate) = (applyfn img2 site_address symref_and_reloc_site) + in + let existing_field = (extract_natural_field width element1 start) + in + (*let _ = errln ("Existing field has value 0x" ^ (hex_string_of_natural existing_field)) + in*) + (*let _ = errln ("Symaddr has value 0x" ^ (hex_string_of_natural symaddr)) + in*) + let addend = (Nat_big_num.of_int64 reloc_site1.ref_relent.elf64_ra_addend) + in + let new_field_value = (calculate symaddr addend existing_field) + in + (*let _ = errln ("Calculated new field value 0x" ^ (hex_string_of_natural new_field_value)) + in*) + let new_element = (write_natural_field new_field_value width element1 start) + in + { + elements = (Pmap.add el_name new_element (Pmap.remove el_name img2.elements)) + ; by_tag = (Pset.diff img2.by_tag(Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) [(SymbolRef(symref_and_reloc_site), Some(el_name, (start, len)))])) + ; by_range = (Pset.diff img2.by_range(Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) [(Some(el_name, (start, len)), SymbolRef(symref_and_reloc_site))])) + } + )) + in + let relocated_img = (List.fold_left (fun acc_img -> (fun (tag, maybe_range) -> + (match tag with + SymbolRef(x) -> (match x.maybe_reloc with + Some rs -> + (match maybe_range with + None -> failwith "impossible: reloc site with no range" + | Some (el_name, (start, len)) -> + (*let _ = errln ("During relocation, saw a reloc site in element " ^ el_name ^ ", offset 0x" ^ + (hex_string_of_natural start) ^ ", length 0x" ^ (hex_string_of_natural len) ^ + ", reloc type " ^ (* a. *) Abi_amd64_relocation.string_of_amd64_relocation_type (get_elf64_relocation_a_type rs.ref_relent) ^ + ", symbol name `" ^ x.ref.ref_symname ^ "'") + in*) + let symaddr = ((match x.maybe_def_bound_to with + Some(ApplyReloc, Some(bound_def)) -> + (* Here we are mapping + * *from* the definition found in an input object during resolution (bound_def) + * *to* the corresponding symbol in the output image, now that we've built it. + * + * Q. What about ABI-specific interventions, e.g. + * redirecting a symbol reference to its GOT or PLT slot? + * A. Indeed, we need to ask the ABI to give us the target + * address. The default implementation is just to look for + * a matching symbol and use its address. But ABIs can do + * wacky things if they like. + *) + a.get_reloc_symaddr bound_def img2 x.maybe_reloc + | None -> failwith "no def found for bound-to symbol" + | Some(ApplyReloc, None) -> + (*let _ = errln "No definition, so we think this is a weak reference; giving it value 0." + in*) + (* CHECK: does the syment say it's weak? *) + if not (Nat_big_num.equal (get_elf64_symbol_binding x.ref.ref_syment) stb_weak) then + (*let _ = errln "Actually not weak! bailing" + in*) + failwith "not a weak reference, but no binding" + else Nat_big_num.of_int + (* Weak symbol. *)0 + | Some(LeaveReloc, _) -> + (* We shouldn't be seeing this, given that we're applying the reloc Right Now. *) + failwith "internal error: applying reloc that is not to be applied" + )) + in + (*let _ = errln ("Got symaddr: 0x" ^ (hex_string_of_natural symaddr)) + in*) + apply_reloc acc_img (el_name, start, len) x symaddr + ) + | None -> (* okay, do nothing *) acc_img + ) + | _ -> failwith "impossible: not a symbol ref" + ) + )) img2 relocs) + in + relocated_img) + +(*val link : address_expr_fn_map allocated_sections_map -> linker_control_script -> abi any_abi_feature -> set Command_line.link_option -> linkable_list -> elf_memory_image*) +let link alloc_map script1 a options linkables:(any_abi_feature)annotated_memory_image= + (let initial_included_indices = (mapMaybei (fun i -> (fun (obj, inp, (opts : input_options)) -> + if opts.item_force_output + then Some i + else None + )) linkables) + in + let linker_script_linkable_idx = (length linkables) + in + let defmap = (all_definitions_by_name linkables) + in + let (accumulated_bindings : binding list) + = +( (* accumulate_bindings_bf a linkables defmap {} initial_included_indices [] *)accumulate_bindings_objectwise_df a linkables defmap [](Pset.from_list Nat_big_num.compare []) initial_included_indices) + in + (* Keep a map whose keys are referenced objects, and whose values are + * *some* (diagnostic purposes only) reference to that linkable. *) + let referenced_object_indices_and_reasons = (List.fold_left (fun acc_m -> (fun ((ref_idx, ref_sym, ref_linkable), maybe_def_idx_and_sym_and_linkable) -> + (match maybe_def_idx_and_sym_and_linkable with + None -> acc_m + | Some (def_idx, def_sym, def_linkable) -> + (* Make sure the map contains this key. *) + if (Lem.option_equal (Lem.pair_equal (=) + (tripleEqual instance_Basic_classes_Eq_var_dict + (instance_Basic_classes_Eq_tup3_dict + instance_Basic_classes_Eq_string_dict + instance_Basic_classes_Eq_var_dict + (instance_Basic_classes_Eq_tup2_dict + instance_Basic_classes_Eq_var_dict + (instance_Basic_classes_Eq_list_dict + instance_Basic_classes_Eq_var_dict))) + instance_Basic_classes_Eq_var_dict)) (Pmap.lookup def_idx acc_m) None) + then Pmap.add def_idx (ref_sym, ref_linkable) acc_m + else acc_m + ) + )) ((Pmap.empty Nat_big_num.compare) : (Nat_big_num.num, (symbol_reference * linkable_item)) Pmap.map) accumulated_bindings) + in + (* Print something similar to GNU ld's linker map output, about included archive members. *) + (*let _ = Missing_pervasives.outln "Archive member included to satisfy reference by file (symbol)\n" in*) + let linkables_not_discarded = (mapMaybei (fun i -> (fun (obj, inp, opts) -> + let referenced_object_map_entry = (Pmap.lookup i referenced_object_indices_and_reasons) + in + let referenced = ( not ((Lem.option_equal (Lem.pair_equal (=) + (tripleEqual instance_Basic_classes_Eq_var_dict + (instance_Basic_classes_Eq_tup3_dict + instance_Basic_classes_Eq_string_dict + instance_Basic_classes_Eq_var_dict + (instance_Basic_classes_Eq_tup2_dict + instance_Basic_classes_Eq_var_dict + (instance_Basic_classes_Eq_list_dict + instance_Basic_classes_Eq_var_dict))) + instance_Basic_classes_Eq_var_dict)) referenced_object_map_entry None))) + in + (* Print our link map thing *) + (*let _ = ( + if (not referenced) then () else + (* Did it come from an archive? *) + let (name, _, (inp_unit, coordlist)) = inp in + match coordlist with + InArchive(aid, aidx, aname, _) :: _ -> + (* yes, from an archive, so print a line *) + let (ref_sym, (ref_obj, (ref_name, ref_blob, ref_origin), ref_opts)) = match referenced_object_map_entry with + Just(x, y) -> (x, y) + | Nothing -> failwith "impossible: referenced item has no definition" + end + in + let lhs_name = aname ^ "(" ^ name ^ ")" + in + let lhs_name_len = stringLength lhs_name + in + let spacing = if lhs_name_len >= 29 + then ("\n" ^ (makeString 30 #' ')) + else makeString (30 - lhs_name_len) #' ' + in + Missing_pervasives.outln ( + lhs_name ^ spacing ^ + (match ref_origin with + (_, InArchive(bid, bidx, bname, _) :: _) -> bname ^ "(" ^ ref_name ^ ")" + | _ -> ref_name + end) + ^ " (" ^ ref_sym.ref_symname ^ ")" + ) + | _ (* not from an archive *) -> () + end + ) + in*) + if referenced || opts.item_force_output + then Some (i, (obj, inp, opts)) + else None + )) linkables) + in + (*let _ = Missing_pervasives.outln "\nAllocating common symbols\nCommon symbol size file\n" + in*) + (* We have to do a pass over relocations quite early. This is because relocs *do* participate + * in linking. For each reloc, we need to decide whether to apply it or not. For those not applied, + * we include it in a synthesised section that participates in linking. + * + * Similarly, the GOT needs to participate in linking, so that it gets assigned an address + * at the appropriate place (as determined by the script). So we have to generate the GOT + * *before* running the linker script. The GNU linker hangs the whole GOT and PLT content + * off the first input object (usually crt1.o). In general, expand_sections calls an ABI tap + * which synthesises all the necessary things, like (in the GNU case) the .got and .plt sections + * hanging off the first input object. *) + let (initial_bindings_by_name : (string, ( (Nat_big_num.num * binding)list)) Pmap.map) = + (List.fold_left (fun m -> fun (b_idx, ((ref_idx, ref1, ref_item), maybe_def)) -> (match Pmap.lookup ref1.ref_symname m with + None -> Pmap.add ref1.ref_symname [ (b_idx, ((ref_idx, ref1, ref_item), maybe_def)) ] m + | Some ((bi, b) :: more) -> Pmap.add ref1.ref_symname ((b_idx, ((ref_idx, ref1, ref_item), maybe_def)) :: ((bi, b) :: more)) m + | _ -> failwith "impossible: found empty list in map lacking empties by construction" + )) (Pmap.empty compare) (Lem_list.mapi (fun i -> fun b -> (Nat_big_num.of_int i, b)) accumulated_bindings)) + in + let (expanded_triples : ( reloc_resolution list * elf_memory_image * Linker_script.input_spec list) list) + = (expand_sections_for_all_inputs a options initial_bindings_by_name default_merge_generated linkables_not_discarded) + in + let (reloc_resolutions, imgs, input_lists) = (unzip3 expanded_triples) + in + let input_sections = (list_concat input_lists) + in + let seen_ordering = (fun is1 -> (fun is2 -> ( + let toNaturalList = (fun is -> ( + (* We're mapping the item to a list of naturals that determine a + * lexicographic order. The list has a fixed depth: + * + * [within-commandline, within-group, within-archive, section-or-symbol] + * + * For .o files on the command line, we use the command line order. This + * is the first level in the hierarchy. + * + * For .a files with --whole-archive, we want to do the same. Do this + * by using archive position as the second level of the hierarchy, *if* + * the item is marked as force_output. + * + * For other archives, "order seen" means something different: it's + * the order in which they were "pulled in" during input enumeration. Another + * way to say this is that they're ordered by the first binding that was + * made to them. We map these to numbers starting from the size of the archive, + * i.e. so that "force_output" makes an element appear sooner. In practice + * we won't get a mixture of force_output and non- in the same archive, + * so each archive will use only one of the two orderings. + * + * How do sections order relative to common symbols? Again, in practice it + * doesn't matter because no input query will get a mixture of the two. + * For symbols, we start the numbering from the number of sections in the file, + * so symbols always appear later in the sortd order. + *) + let (linkable_idx, section_or_symbol_idx) = ((match is with + Common(idx1, fname1, img2, def) -> (idx1, Nat_big_num.add + (let (_, l) = (elf_memory_image_section_ranges img2) in length l) def.def_sym_idx) + | InputSection(isrec) -> (isrec.idx, isrec.shndx) + )) + in + (match Lem_list.list_index linkables (Nat_big_num.to_int linkable_idx) with + None -> failwith "impossible: linker input not in linkables list" + | Some (obj, (fname1, blob, (inp_unit, coords)), options) -> + let (our_cid, our_gid, our_aid, maybe_archive_size) = ((match coords with + InArchive(aid, aidx, _, asize) :: InGroup(gid1, gidx) :: [InCommandLine(cid)] -> (cid, gid1, aid, Some asize) + | InArchive(aid, aidx, _, asize) :: [InCommandLine(cid)] -> (cid,Nat_big_num.of_int 0, aid, Some asize) + | InGroup(gid1, gidx) :: [InCommandLine(cid)] -> (cid, gid1,Nat_big_num.of_int 0, None) + | [InCommandLine(cid)] -> (cid,Nat_big_num.of_int 0,Nat_big_num.of_int 0, None) + | _ -> failwith "internal error: impossible coordinates" + )) + in + let aid_to_use = (if options.item_force_output then our_aid + else (* how many elements does the archive have? *) + let archive_size = ((match maybe_archive_size with + None -> failwith "impossible: archive with no size" + | Some a -> a + )) + in Nat_big_num.add archive_size + (* search the bindings: we want the index of the first binding + that refers to this object. + *) + (match Lem_list.find_index (fun ((b_ref_idx, b_ref, b_ref_item), b_maybe_def) -> (match b_maybe_def with + Some (b_def_idx, b_def, b_def_item) -> Nat_big_num.equal b_def_idx linkable_idx + | _ -> false + )) accumulated_bindings with + Some n -> Nat_big_num.of_int n + | None -> failwith "impossible: non-force-output object does not contain any bound-to defs" + )) + in + (* do we care about group idx? probably not. *) + [our_cid; aid_to_use; section_or_symbol_idx] + ) + )) + in +(lexicographic_compare Nat_big_num.compare (toNaturalList is1) (toNaturalList is2)) + ))) + in + (* + let get_binding_for_ref = (fun symref -> (fun linkable_idx -> (fun fname -> + let name_matches = match Map.lookup symref.ref_symname bindings_by_name with Just x -> x | Nothing -> [] end + in + match List.filter (fun (bi, ((r_idx, r, r_item), m_d)) -> r_idx = linkable_idx && r = symref) name_matches with + [(b_idx, b)] -> (b_idx, b) + | [] -> failwith "no binding found" + | _ -> failwith ("ambiguous binding found for symbol `" ^ symref.ref_symname ^ "' in file " ^ fname) + end + ))) + in + *) + let (unrelocated_output_image_lacking_abs_symbols, bindings_by_name) + = (interpret_linker_control_script alloc_map script1 linkables linker_script_linkable_idx a input_sections seen_ordering default_place_orphans initial_bindings_by_name) + in + (* also copy over ABS (range-less) symbols from all included input items *) + let all_abs_range_tags_in_included_inputs = (List.concat ( + Lem_list.map (fun (img2, (idx1, linkable)) -> + let abslist = (Lem_list.mapMaybe (fun (tag, maybeRange) -> + (match tag with + SymbolDef(ent) -> if (Lem.option_equal (Lem.pair_equal (=) (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal)) maybeRange None) && Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ent.def_syment.elf64_st_shndx)) shn_abs + then Some (maybeRange, ent) + else None + | _ -> None + ) + ) (tagged_ranges_matching_tag + instance_Basic_classes_Ord_Abis_any_abi_feature_dict instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict (SymbolDef(null_symbol_definition)) img2)) + in + (*let _ = errln ("Copying " ^ (show (length abslist)) ^ " ABS symbols (names: " ^ + List.foldl (fun acc -> fun str -> if stringLength acc = 0 then str else acc ^ ", " ^ str) "" + (List.map (fun (_, x) -> x.def_symname) abslist) + ^ ") from not-discarded linkable item " ^ + (short_string_of_linkable_item linkable)) + in*) + let x2 = ([]) in List.fold_right + (fun(maybe_range, ent) x2 -> + if true then + (maybe_range, SymbolDef + ({ def_symname = (ent.def_symname) + ; def_syment = (ent.def_syment) + ; def_sym_scn = (ent.def_sym_scn) + ; def_sym_idx = (ent.def_sym_idx) + ; def_linkable_idx = idx1 })) :: x2 else x2) + abslist x2 + ) (list_combine imgs linkables_not_discarded) + )) + in + let by_range_including_abs_symbols = + + (Pset.(union) unrelocated_output_image_lacking_abs_symbols.by_range + ((Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) all_abs_range_tags_in_included_inputs))) + in + let unrelocated_output_image = ({ + elements = (unrelocated_output_image_lacking_abs_symbols.elements) + ; by_range = by_range_including_abs_symbols + ; by_tag = (by_tag_from_by_range + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) instance_Basic_classes_SetType_var_dict by_range_including_abs_symbols) + }) + (* This image has + * - addresses assigned + * - relocations *not* applied + * - no entry point + * - some ABI features not generated? GOT, certainly. HMM. + -- don't consider output features, like symtabs, yet; + -- other ABI features have to be generated before the linker script runs (dyn relocs, GOT, PLT?) + -- ... so we might be okay for now. + *) + in + let remaining_relocs = (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (SymbolRef(null_symbol_reference_and_reloc_site)) + unrelocated_output_image.by_tag) + in + let _ = (List.fold_left (fun _ -> (fun (tag, maybe_range) -> + let _ = ((match tag with + SymbolRef(x) -> (match x.maybe_reloc with + Some rs -> + (match maybe_range with + None -> failwith "impossible: reloc site with no range" + | Some (el_name, (start, len)) -> + () (* errln ("After linking, saw a reloc site in element " ^ el_name ^ ", offset 0x" ^ + (hex_string_of_natural start) ^ ", length 0x" ^ (hex_string_of_natural len) ^ + ", reloc type " ^ Abi_amd64_relocation.string_of_amd64_relocation_type (get_elf64_relocation_a_type rs.ref_relent)) *) + ) + | None -> (* okay, do nothing *) () + ) + | _ -> failwith "impossible: not a symbol ref" + )) + in + () + )) () remaining_relocs) + in + (* Before we relocate, we concretise any ABI features that we've linked in. *) + (*let _ = errln "Asking ABI to concretise support structures" in*) + let unrelocated_concrete_output_image = (a.concretise_support unrelocated_output_image) + in + let output_image = (relocate_output_image a bindings_by_name unrelocated_concrete_output_image) + in + let (maybe_entry_point_address : Nat_big_num.num option) = + ((match Command_line.find_option_matching_tag (Command_line.EntryAddress(Nat_big_num.of_int 0)) options with + None -> a.guess_entry_point output_image + | Some(Command_line.EntryAddress(x)) -> Some x + )) + in + (match maybe_entry_point_address with + Some addr -> + (match address_to_element_and_offset addr output_image with + Some (el_name, el_offset) -> + (*let _ = errln ("Tagging element " ^ el_name ^ " as containing entry point at offset 0x" ^ (hex_string_of_natural el_offset)) + in*) + tag_image (EntryPoint) el_name el_offset(Nat_big_num.of_int 0) output_image + | None -> + (* HMM. entry point symbol has no address at present. *) + failwith ("error: entry point address 0x" ^ ((hex_string_of_natural addr) ^ " does not correspond to any element position")) + ) + | None -> + (*let _ = errln "Warning: not tagging entry point in output image" + in*) + output_image + )) diff --git a/lib/ocaml_rts/linksem/linkable_list.ml b/lib/ocaml_rts/linksem/linkable_list.ml new file mode 100644 index 00000000..c128563c --- /dev/null +++ b/lib/ocaml_rts/linksem/linkable_list.ml @@ -0,0 +1,568 @@ +(*Generated by Lem from linkable_list.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_string_extra +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_list_extra +open Lem_set +open Lem_set_extra +(*import Map*) +open Lem_sorting +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show + +open Elf_types_native_uint +open Elf_memory_image +open Elf_header +open Elf_file +open Memory_image +open Elf_memory_image +open Elf_section_header_table +open Elf_symbol_table +open String_table +open Input_list + +open Elf_memory_image +open Elf_memory_image_of_elf64_file + +type script = byte_sequence (* FIXME *) + +type linkable_object = RelocELF of elf_memory_image (* memory image without address assignments *) + | SharedELF of elf_memory_image (* memory image with address assignments *) + | ScriptAST of script (* FIXME: should be elaborated away *) + | ControlScriptDefs + +(*val string_of_linkable_object : linkable_object -> string*) +let string_of_linkable_object l:string= ((match l with + RelocELF(_) -> "a relocatable file (...)" + | SharedELF(_) -> "a shared library (...)" + | ScriptAST(_) -> "a linker script (...)" + | ControlScriptDefs -> "the control script" +)) + +(* We keep the original input item around, hence the filename and byte sequence + * and options. *) +type linkable_item = linkable_object * input_item * input_options + +(*val short_string_of_linkable_item : linkable_item -> string*) +let short_string_of_linkable_item item:string= + (let (obj, inp, opts) = item + in + short_string_of_input_item inp) + +let instance_Show_Show_Linkable_list_linkable_object_dict:(linkable_object)show_class= ({ + + show_method = string_of_linkable_object}) + +type linkable_list = linkable_item list + +type symbol_resolution_oracle = linkable_list -> int -> string -> int list +type binding = (Nat_big_num.num * symbol_reference * linkable_item) * (Nat_big_num.num * symbol_definition * linkable_item)option +type binding_list = binding list +type binding_map = (string, ( (Nat_big_num.num * binding)list)) Pmap.map + + +let image_of_linkable_item item:(Abis.any_abi_feature)annotated_memory_image= ((match item with + (RelocELF(image), _, _) -> image + | (SharedELF(image), _, _) -> image + | _ -> failwith "no image" +)) + +(*val linkable_item_of_input_item_and_options : forall 'abifeature. abi 'abifeature -> input_item -> input_options -> linkable_item*) +let linkable_item_of_input_item_and_options a it opts:linkable_object*(string*input_blob*(Command_line.input_unit*(origin_coord)list))*input_options= + ((match ((match it with + (fname1, Reloc(seq), origin) -> + (*let _ = Missing_pervasives.errln ("Considering relocatable file " ^ fname) in*) + Elf_file.read_elf64_file seq >>= (fun e -> + return (RelocELF(elf_memory_image_of_elf64_file a fname1 e), it, opts)) + | (fname1, Shared(seq), origin) -> + (*let _ = Missing_pervasives.errln ("Skipping shared object " ^ fname) in *) + fail "unsupported input item" + | (fname1, Script(seq), origin) -> + (*let _ = Missing_pervasives.errln ("Skipping linker script " ^ fname) in*) + fail "unsupported input item" + )) + with + Success(item) -> item + | Fail(str) -> failwith (str ^ ": non-ELF or non-relocatable input file") + )) + +(*val string_of_linkable : linkable_item -> string*) +let string_of_linkable l:string= ((match l with + (_, item, _) -> string_of_triple + instance_Show_Show_string_dict instance_Show_Show_Input_list_input_blob_dict (instance_Show_Show_tup2_dict + Command_line.instance_Show_Show_Command_line_input_unit_dict + (instance_Show_Show_list_dict + instance_Show_Show_Input_list_origin_coord_dict)) item +)) + +(* How do we signal "multiple definitions"? + * This is part of the policy baked into the particular oracle: + * are multiple definitions okay, or do we fail? + * + * NOTE that multiple definitions *globally* is not the same as + * multiple definitions as candidates for a given binding. We + * can get the former even if we don't have the latter, in some + * weird group/archive arrangements. The right place to detect + * this condition is probably when generating the output symtab. + *) + +(*val add_definition_to_map : (natural * symbol_definition * linkable_item) -> Map.map string (list (natural * symbol_definition * linkable_item)) + -> Map.map string (list (natural * symbol_definition * linkable_item))*) +let add_definition_to_map def_idx_and_def_and_linkable m:((string),((Nat_big_num.num*symbol_definition*(linkable_object*input_item*input_options))list))Pmap.map= + (let (def_idx, def, def_linkable) = def_idx_and_def_and_linkable + in + (match Pmap.lookup def.def_symname m with + Some curlist -> Pmap.add def.def_symname ((def_idx, def, def_linkable) :: curlist) m + | None -> Pmap.add def.def_symname [(def_idx, def, def_linkable)] m + )) + +(*val all_definitions_by_name : linkable_list -> Map.map string (list (natural * symbol_definition * linkable_item))*) +let all_definitions_by_name linkables:((string),((Nat_big_num.num*symbol_definition*linkable_item)list))Pmap.map= +( + (* Now that linkables are ELF memory images, we can make the + * list of definitions much more easily. *)let list_of_deflists = (Lem_list.mapi (fun (idx1 : int) -> (fun (item : linkable_item) -> + let img2 = (image_of_linkable_item item) + in + let (all_def_tags, all_def_ranges) + = (List.split (Multimap.lookupBy0 + (Memory_image_orderings.instance_Basic_classes_Ord_Memory_image_range_tag_dict + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (SymbolDef(null_symbol_definition)) img2.by_tag)) + in + let all_defs = (Lem_list.map (fun tag -> (match tag with + SymbolDef(def) -> (def, item) + | _ -> failwith "matched tag not a symbol definition" + )) all_def_tags) + in + let x2 = ([]) in List.fold_right + (fun(def, def_linkable) x2 -> + if true then (Nat_big_num.of_int idx1, def, def_linkable) :: x2 else x2) + all_defs x2 + )) linkables) + in + List.fold_left (fun accum -> (fun deflist -> + List.fold_left (fun m -> (fun (def_idx, def, def_linkable) -> add_definition_to_map (def_idx, def, def_linkable) m)) accum deflist + )) (Pmap.empty compare) list_of_deflists) + +type binding_oracle = + linkable_list + -> (string, ( (Nat_big_num.num * symbol_definition * linkable_item)list)) Pmap.map + -> (Nat_big_num.num * symbol_reference * linkable_item) + -> (Nat_big_num.num * symbol_definition * linkable_item)option + +(*val resolve_one_reference_default : forall 'abifeature. abi 'abifeature -> binding_oracle*) +let resolve_one_reference_default a linkables defmap ref_idx_and_ref_and_linkable:(Nat_big_num.num*symbol_definition*(linkable_object*(string*input_blob*(Command_line.input_unit*(origin_coord)list))*input_options))option= + (let (ref_idx, ref1, ref_linkable) = ref_idx_and_ref_and_linkable + in + (* Get the list of all definitions whose name matches. + * Don't match empty names. + * How should we handle common symbols here? + * A common symbol is a potential definition, so it goes in the def list. + *) + let (defs_and_linkables_with_matching_name : (Nat_big_num.num * symbol_definition * linkable_item) list) + = ((match Pmap.lookup ref1.ref_symname defmap with + Some (l : ( (Nat_big_num.num * symbol_definition * linkable_item)list)) -> l + | None -> [] + )) + in + (* Filter the list by eligibility rules. + * Normally, + * + * - any .o file can supply any other .o file on the command line + * - any .a file supplies only files appearing to its left + * i.e. "it is searched once for definitions" + * - does a .o file supply a .a file? to both its right and left? Experimentally, YES. + * + * So the restrictions are + * - archives may not supply weak references + * - archives may only supply to the left, or to themselves, or to objects in the same group + *) + let (ref_obj, (ref_fname, ref_blob, (ref_u, ref_coords)), ref_options) = ref_linkable + in + let ref_is_weak = (Nat_big_num.equal (get_elf64_symbol_binding ref1.ref_syment) stb_weak) + in + let def_is_eligible = (fun (def_idx, def, def_linkable) -> + let ref_is_unnamed = (ref1.ref_symname = "") + in + let ref_is_to_defined_or_common_symbol = ( not (Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ref1.ref_syment.elf64_st_shndx)) stn_undef)) + in + let def_sym_is_ref_sym = ( Nat_big_num.equal ref_idx def_idx && (Nat_big_num.equal ref1.ref_sym_scn def.def_sym_scn + && Nat_big_num.equal ref1.ref_sym_idx def.def_sym_idx)) + in + let (def_obj, (def_fname, def_blob, def_origin), def_options) = def_linkable + in + let (def_u, def_coords) = def_origin + in + let (def_in_group, def_in_archive) = ((match def_coords with + InArchive(aid, aidx, _, _) :: InGroup(gid1, gidx) :: [_] -> (Some gid1, Some aid) + | InArchive(aid, aidx, _, _) :: [_] -> (None, Some aid) + | InGroup(gid1, gidx) :: [_] -> (Some gid1, None) + | [_] -> (None, None) + | _ -> failwith "internal error: didn't understand origin coordinates of definition" + )) + in + let ref_is_leftmore = (Nat_big_num.less_equal ref_idx def_idx) + in + (* For simplicity we include the case of "same archive" in "in group with". *) + let ref_is_in_group_with_def = ((match def_in_group with + None -> false + | Some def_gid -> + (match ref_coords with + InArchive(_, _, _, _) :: InGroup(gid1, _) :: [_] -> Nat_big_num.equal gid1 def_gid + | InGroup(gid1, _) :: [_] -> Nat_big_num.equal gid1 def_gid + | _ -> false + ) + )) + in + (* but maybe same archive? *) + (* DEBUGGING: print some stuff out if we care about this symbol. *)let _ = + (if (ref_fname = "backtrace.o") && (def.def_symname = "_Unwind_GetCFA") then + (*Missing_pervasives.errln ("saw backtrace.o referencing _Unwind_GetCFA; coords are " + ^ "def: " ^ (show def_coords) ^ ", ref: " ^ (show ref_coords) ^ "; ref_is_in_group_with_def: " + ^ (show ref_is_in_group_with_def) ^ "; def_in_group: " ^ (show def_in_group))*) + () + else ()) + in + let ref_and_def_are_in_same_archive = ((match (def_coords, ref_coords) with + (InArchive(x1, _, _, _) :: _, InArchive(x2, _, _, _) :: _) -> Nat_big_num.equal x1 x2 + | _ -> false + )) + in + let def_is_in_archive = ((match def_in_archive with + Some _ -> true + | None -> false + )) + in + if ref_is_to_defined_or_common_symbol then def_sym_is_ref_sym + else + if ref_is_unnamed then false + else + if def_is_in_archive + then + (* Weak references *can* be resolved to archive members... + * if the reference itself is also in the archive. *) + ((not ref_is_weak) || ref_and_def_are_in_same_archive) + && ( + ref_is_leftmore + || (ref_and_def_are_in_same_archive + || ref_is_in_group_with_def) + ) + else + true + ) + in + let eligible_defs = (List.filter def_is_eligible defs_and_linkables_with_matching_name) + in + let (maybe_target_def_idx, maybe_target_def, maybe_target_def_linkable) = ((match eligible_defs with + [] -> (None, None, None) + | [(def_idx, def, def_linkable)] -> (Some def_idx, Some def, Some def_linkable) + | (d_idx, d, d_l) :: more_pairs -> + (* Break ties by + * - putting defs in relocs (or --defsym or linker script, a.k.a. command line) ahead of defs in archives; + * - else whichever definition appeared first in the left-to-right order. + *) + let sorted = (insertSortBy (fun (d_idx1, d1, (_, (_, _, (_, d_l1_coords)), _)) -> (fun (d_idx2, d2, (_, (_, _, (_, d_l2_coords)), _)) -> + (match (d_l1_coords, d_l2_coords) with + (InCommandLine(_) :: _, InCommandLine(_) :: _) -> Nat_big_num.less d_idx1 d_idx2 + | (InCommandLine(_) :: _, _) -> (* command-line wins *) true + | (_, InCommandLine(_) :: _) -> (* command-line wins *) false + | (_, _) -> Nat_big_num.less d_idx1 d_idx2 + ))) eligible_defs) + in + (match sorted with + (first_d_idx, first_d, first_d_l) :: _ -> (Some first_d_idx, Some first_d, Some first_d_l) + | _ -> failwith "impossible: sorted list is shorter than original" + ) + )) + in + let refstr = ("`" + ^ (ref1.ref_symname ^ ("' (" ^ + ((if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string ref1.ref_syment.elf64_st_shndx)) shn_undef then "UND" else "defined") ^ + (" symbol at index " ^ ((Nat_big_num.to_string ref1.ref_sym_idx) ^ (" in symtab " + ^ ((Nat_big_num.to_string ref1.ref_sym_scn) ^ (" in " ^ (ref_fname + ^ ")")))))))))) + in + (*let _ = Missing_pervasives.errs ("Bound a reference from " ^ refstr ^ " to ") + in*) + (match (maybe_target_def_idx, maybe_target_def, maybe_target_def_linkable) with + (Some target_def_idx, Some target_def, Some target_def_linkable) -> + (*let _ = Missing_pervasives.errln (" a definition in "^ (show (target_def_linkable))) + in*) + Some(target_def_idx, target_def, target_def_linkable) + | (None, None, None) -> + (*let _ = Missing_pervasives.errln " no definition" + in*) + if ref_is_weak (* || a.symbol_is_generated_by_linker ref.ref_symname *) then None + else (* failwith ("undefined symbol: " ^ refstr) *) None + (* FIXME: do a check, *after* the linker script has been interpreted, + * that all remaining undefined symbols are permitted by the ABI/policy. *) + | _ -> failwith "impossible: non-matching maybes for target_def_idx and target_def" + )) + +(*val resolve_all : + linkable_list + -> Map.map string (list (natural * symbol_definition * linkable_item)) (* all definitions *) + -> binding_oracle + -> list (natural * symbol_reference * linkable_item) + -> list ((natural * symbol_reference * linkable_item) * maybe (natural * symbol_definition * linkable_item))*) +let resolve_all linkables all_defs oracle refs:((Nat_big_num.num*symbol_reference*(linkable_object*input_item*input_options))*(Nat_big_num.num*symbol_definition*linkable_item)option)list= + (Lem_list.map (fun (ref_idx, ref1, ref_linkable) -> ((ref_idx, ref1, ref_linkable), (oracle linkables all_defs (ref_idx, ref1, ref_linkable)))) refs) + +(* To accumulate which inputs are needed, we work with a list of undefineds, starting with those + * in the forced-output objects. We then iteratively build a list of all needed symbol definitions, + * pulling in the objects that contain them, until we reach a fixed point. *) +(*val resolve_undefs_in_one_object : + linkable_list + -> Map.map string (list (natural * symbol_definition * linkable_item)) (* all definitions *) + -> binding_oracle + -> natural + -> list ((natural * symbol_reference * linkable_item) * maybe (natural * symbol_definition * linkable_item))*) +let resolve_undefs_in_one_object linkables all_defs oracle idx1:((Nat_big_num.num*symbol_reference*linkable_item)*(Nat_big_num.num*symbol_definition*linkable_item)option)list= +( + (* Get this object's list of references *)let item = ((match Lem_list.list_index linkables (Nat_big_num.to_int idx1) with + Some it -> it + | None -> failwith "impossible: linkable not in list of linkables" + )) + in + let img2 = (image_of_linkable_item item) + in + let (all_ref_tags, all_ref_ranges) + = (List.split (Multimap.lookupBy0 + (Memory_image_orderings.instance_Basic_classes_Ord_Memory_image_range_tag_dict + Abis.instance_Basic_classes_Ord_Abis_any_abi_feature_dict) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (Memory_image_orderings.tagEquiv + Abis.instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict) (SymbolRef(null_symbol_reference_and_reloc_site)) img2.by_tag)) + in + (* By using SymbolRef, we are extracting and binding each relocation site individually. + * since there might be more than one relocation site referencing the same symbol name, + * in a given object. + * + * We are also binding SymbolRefs that have no relocation, which occur when there's + * an UND symbol which is not actually used by a relocation site, but is nevertheless + * in need of being resolved. + * + * We don't (for the moment) want to make different decisions for different reloc sites + * in the same object referencing the same symbol. So we dedup from a list to a set. + *) + let all_refs = (Pset.from_list compare (Lem_list.map (fun tag -> (match tag with + SymbolRef(r) -> r.ref + | _ -> failwith "matched tag not a relocation site" + )) all_ref_tags)) + in + let ref_triples = (let x2 =(Pset.from_list (tripleCompare Nat_big_num.compare compare (tripleCompare compare (tripleCompare compare compare (pairCompare compare (lexicographic_compare compare))) compare)) + []) in Pset.fold + (fun ref1 x2 -> if true then Pset.add (idx1, ref1, item) x2 else x2) + all_refs x2) + in + (*let _ = Missing_pervasives.errln ("object " ^ (show item) ^ " has " ^ + (show (Set.size ref_triples)) ^ " reloc references (symname, sym_scn, sym_idx, st_shndx) (" ^ + (show (List.map (fun x -> ("\"" ^ x.ref_symname ^ "\"", x.ref_sym_scn, x.ref_sym_idx, natural_of_elf64_half x.ref_syment.elf64_st_shndx)) (Set_extra.toList all_refs))) ^ ")") + in*) + let und_ref_triples = (let x2 =(Pset.from_list (tripleCompare Nat_big_num.compare compare (tripleCompare compare (tripleCompare compare compare (pairCompare compare (lexicographic_compare compare))) compare)) + []) in Pset.fold + (fun(idx1, ref1, ref_item) x2 -> + if Nat_big_num.equal + (Nat_big_num.of_string + (Uint32.to_string ref1.ref_syment.elf64_st_shndx)) shn_undef then + Pset.add (idx1, ref1, ref_item) x2 else x2) ref_triples x2) + in + (*let _ = Missing_pervasives.errln ("... of which " ^ + (show (Set.size und_ref_triples)) ^ " are to undefined symbols: (symname, sym_scn, sym_idx, st_shndx) (" ^ + (show (List.map (fun (idx, x, _) -> ("\"" ^ x.ref_symname ^ "\"", x.ref_sym_scn, x.ref_sym_idx, natural_of_elf64_half x.ref_syment.elf64_st_shndx)) (Set_extra.toList und_ref_triples))) ^ ")") + in*) + resolve_all linkables all_defs oracle (Pset.elements ref_triples)) + +(*val accumulate_bindings_bf : forall 'abifeature. + abi 'abifeature + -> linkable_list + -> Map.map string (list (natural * symbol_definition * linkable_item)) (* all definitions *) + -> set natural (* inputs fully-bound so far *) + -> list natural (* ordered list of inputs to bind next *) + -> list ((natural * symbol_reference * linkable_item) * maybe (natural * symbol_definition * linkable_item)) (* bindings made so far *) + -> list ((natural * symbol_reference * linkable_item) * maybe (natural * symbol_definition * linkable_item))*) (* all accumulated bindings bindings *) +let rec accumulate_bindings_bf a linkables all_defs fully_bound to_bind bindings_accum:((Nat_big_num.num*symbol_reference*linkable_item)*(Nat_big_num.num*symbol_definition*linkable_item)option)list= +( + (* This is like foldl, except that each stage + * can add stuff to the work list *)(match to_bind with + [] -> bindings_accum (* termination *) + | l_idx :: more_idx -> + (* Get the new bindings for this object *) + let new_bindings = (resolve_undefs_in_one_object + linkables + all_defs + (resolve_one_reference_default a) + l_idx) + in + let new_fully_bound = (Pset.add l_idx fully_bound) + in + (* Which of the new bindings are to objects + * not yet fully bound or not yet in the to-bind list? *) + let new_bindings_def_idx = (list_concat_map (fun (ref1, maybe_def_and_idx_and_linkable) -> + (match maybe_def_and_idx_and_linkable with + Some (def_idx, def, def_linkable) -> [def_idx] + | None -> [] + ) + ) new_bindings) + in + let new_bindings_def_idx_set = (Pset.from_list Nat_big_num.compare new_bindings_def_idx) + in + let included_linkables_idx = (Pset.(union) fully_bound ((Pset.from_list Nat_big_num.compare to_bind))) + in + let new_l_idx = (Pset.diff new_bindings_def_idx_set included_linkables_idx) + in + let new_l_idx_list = (Pset.elements new_l_idx) + in + (*let _ = Missing_pervasives.errln ( + if List.null new_l_idx_list + then + "Fully bound references in " ^ (show (List.index linkables (natFromNatural l_idx))) + ^ " using only already-included linkables (" + ^ (show (List.map (fun i -> List.index linkables (natFromNatural i)) (Set_extra.toList included_linkables_idx))) + else + "Including additional linkables " + ^ (show (List.mapMaybe (fun i -> List.index linkables (natFromNatural i)) new_l_idx_list)) + ) + in*) + accumulate_bindings_bf + a + linkables + all_defs + new_fully_bound + ( List.rev_append (List.rev more_idx) new_l_idx_list) + ( List.rev_append (List.rev bindings_accum) new_bindings) + )) + +(* We need a generalised kind of depth-first search in which there are multiple start points. + * Also, we always work one object at a time, not one edge at a time; when we pull in an object, + * we resolve *all* the references therein. + *) +(*val accumulate_bindings_objectwise_df : forall 'abifeature. + abi 'abifeature + -> linkable_list + -> Map.map string (list (natural * symbol_definition * linkable_item)) (* all definitions *) + + -> list ((natural * symbol_reference * linkable_item) * maybe (natural * symbol_definition * linkable_item)) (* bindings made so far *) + -> set natural (* inputs fully-bound so far -- these are "black" *) + -> list natural (* inputs scheduled for binding -- these include + any "grey" (in-progress) nodes *and* + any nodes that we have committed to exploring + (the "start nodes"). + Because we're depth-first, we prepend our adjacent + nodes to this list, making them grey, then we + recurse by taking from the head. We must always + filter out the prepended nodes from the existing list, + to ensure we don't recurse infinitely. *) + -> list ((natural * symbol_reference * linkable_item) * maybe (natural * symbol_definition * linkable_item))*) (* all accumulated bindings bindings *) +let rec accumulate_bindings_objectwise_df a linkables all_defs bindings_accum blacks greys:((Nat_big_num.num*symbol_reference*linkable_item)*(Nat_big_num.num*symbol_definition*linkable_item)option)list= + ((match greys with + [] -> bindings_accum (* termination *) + | l_idx :: more_idx -> + (* Get the new bindings for this object *) + let new_bindings = (resolve_undefs_in_one_object + linkables + all_defs + (resolve_one_reference_default a) + l_idx) + in + (* We pull in the whole object at a time ("objectwise"), so by definition, + * we have created bindings for everything in this object; it's now black. *) + let new_fully_bound = (Pset.add l_idx blacks) + in + (* Which of the new bindings are to objects + * not yet fully bound or not yet in the to-bind list? *) + let new_bindings_def_idx = (list_concat_map (fun (ref1, maybe_def_and_idx_and_linkable) -> + (match maybe_def_and_idx_and_linkable with + Some (def_idx, def, def_linkable) -> [def_idx] + | None -> [] + ) + ) new_bindings) + in + let new_bindings_def_idx_set = (Pset.from_list Nat_big_num.compare new_bindings_def_idx) + in + (* this is the "black or grey" set. *) + let included_linkables_idx = (Pset.(union) blacks ((Pset.from_list Nat_big_num.compare greys))) + in + (* these are the white ones that we're adjacent to *) + let new_l_idx = (Pset.diff new_bindings_def_idx_set included_linkables_idx) + in + let new_l_idx_list = (Pset.elements new_l_idx) + in + (* What is the new grey-alike list? (This is the list we tail-recurse down.) + * It's + * - the existing grey-alike list + * - with any new (were-white) objects prepended + * - ... and filtered to *remove* these from the existing list (avoid duplication). + *) + let new_grey_list = (List.rev_append (List.rev new_l_idx_list) (List.filter (fun x -> not ( Pset.mem x new_l_idx)) more_idx)) + in + (* whether or not we've not uncovered any new white nodes, we tail-recurse *) + (*let _ = (if List.null new_l_idx_list then + Missing_pervasives.errln ("Fully bound references in " ^ (show (List.index linkables (natFromNatural l_idx))) + ^ " using only already-included linkables (" + ^ (show (List.map (fun i -> List.index linkables (natFromNatural i)) (Set_extra.toList included_linkables_idx))) + ) else Missing_pervasives.errln ("Including additional linkables " + ^ (show (List.mapMaybe (fun i -> List.index linkables (natFromNatural i)) new_l_idx_list)))) + in*) + accumulate_bindings_objectwise_df + a + linkables + all_defs + ( List.rev_append (List.rev bindings_accum) new_bindings) + (new_fully_bound : Nat_big_num.num Pset.set) + (new_grey_list : Nat_big_num.num list) + )) + +(* Rather than recursively expanding the link by searching for definitions of undefs, + * the GNU linker works by recursing/looping along the list of *linkables*, testing whether + * any of the defs satisfies a currently-undef'd thing. On adding a new undef'd thing, + * we re-search only from the current archive, not from the beginning (i.e. the + * "def_is_leftmore or def_in_same_archive" logic). + * + * Why is this not the same as depth-first? One example is if we pull in a new object + * which happens to have two undefs: one satisfied by the *first* element in the current archive, + * and one satisfied by the last. + * + * In the GNU algorithm, we'll pull in the first archive element immediately afterwards, because + * we'll re-traverse the archive and find it's needed. + * + * In the depth-first algorithm, it depends entirely on the ordering of the new bindings, i.e. + * the symtab ordering of the two undefs. If the later-in-archive def was bound *first*, we'll + * recurse down *that* object's dependencies first. + * + * So if we sort the new grey list + * so that bindings formed in order of *current archive def pos*, + * will we get the same behaviour? + * We can't really do this, because we have no "current archive". + * + * Need to rewrite the algorithm to fold along the list of linkables. + *) diff --git a/lib/ocaml_rts/linksem/linker_script.ml b/lib/ocaml_rts/linksem/linker_script.ml new file mode 100644 index 00000000..535d9037 --- /dev/null +++ b/lib/ocaml_rts/linksem/linker_script.ml @@ -0,0 +1,2783 @@ +(*Generated by Lem from linker_script.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_num +open Lem_maybe +open Lem_assert_extra +open Lem_set +(*import Map*) + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show + +open Elf_header +open Elf_file +open Elf_interpreted_section + +open Abis +open Command_line +open Input_list +open Linkable_list +open Memory_image +open Elf_memory_image (* HMM -- ideally we'd be ELF-agnostic in this file. + But Abstract_abi is now merged into Elf_memory_image, so never mind. *) +open Elf_memory_image_of_elf64_file +open Elf_relocation +open Elf_symbol_table +open Elf_section_header_table +open Elf_types_native_uint +open Memory_image_orderings + +(* We model two kinds of linker script: "implicit scripts", which are supplied + * on the command line as input objects, and "control scripts" of which there + * is exactly one per link job. The abstract syntax of each script comes from the + * same grammar. + * + * We define the control script as a bunch of functions, to allow for + * link jobs where we don't have an AST and the script behaviour is hard-coded. + *) + +(* Input sections come from individual (relocatable) ELF files. + * The name of this file is important! + * + * Each input "section" is always an identified section or common symbol + * *within* some ELF memory image. *) + +type input_section_rec = { + idx : Nat_big_num.num (* linkable idx *) +; fname : string +; img : elf_memory_image +; shndx : Nat_big_num.num +; secname: string +; isec : elf64_interpreted_section +} + +type input_spec + = Common of (Nat_big_num.num * string * elf_memory_image * symbol_definition) (* string is symbol name -- must be a COMMON symbol *) + | InputSection of input_section_rec + +(* A control script defines + * - output sections + * - a mapping from output sections to (ordered) input sections + * - extra symbols + * - output format etc. (skip this for now) + *) + +(* We will have to deal with merging etc. at some point, somewhere + * (maybe here, maybe not); for now we just produce an ordered list + * of sections. + *) + +(* We can't model linker scripts as plain Lem functions without writing + * them to a very different structure than that of scripts. The reason is that + * certain features of the script language necessitate multiple passes + * over the script structure. For example, to figure out how big an + * output section is, hence where to begin the next section, you need to + * know which of the input sections are marked for KEEP. For that, you need + * a def-use graph over input sections. But for that, you also need to account + * for *all* symbol definitions, and the script itself is allowed to add new + * ones (right in among its input sections). So we have to do one pass to + * enumerate the symbol additions, and another pass to eliminate sections + * that we don't want to KEEP. + * + * Other gotchas include: + * + * - symbol provision and address advancement can occur in among the input + * section queries, but also outside any output section. + * + * - semantics of DATA_SEGMENT_ALIGN depend on future script contents + * + * - ONLY_IF_RO and ONLY_IF_RW are tricky: need to evaluate the input section + * queries + * + * - semantics of empty sections are subtle (". = ." will force an empty section + * to be emitted, but ". = . + 0" will not do so). + * + * Our approach is to define an interpreter for (at present) most of the script + * language. + *) + +type symbol_def_policy = AlwaysDefine + | ProvideIfUsed + +type input_selector = input_spec list -> input_spec list + +type address_expr = Memory_image.expr + +type output_guard = AlwaysOutput + | OnlyIfRo + | OnlyIfRw + +type symbol_spec = (Nat_big_num.num * Uint32.uint32 * Uint32.uint32) (* size, info, other *) + +type retain_policy + = DefaultKeep + | KeepEvenWhenGC + +type address_expr_fn_ref = Nat_big_num.num +type 'a address_expr_fn_map = (address_expr_fn_ref, (Nat_big_num.num -> 'a -> Nat_big_num.num)) Pmap.map +(* 'a = allocated_sections_map *) + +type output_section_composition_element + = IncludeInputSection of (retain_policy * input_section_rec) + | IncludeCommonSymbol of (retain_policy * string (* file *) * Nat_big_num.num (* linkable_idx *) * symbol_definition * elf_memory_image) + | Hole of address_expr_fn (* compute the next addr to continue layout at *) + | ProvideSymbol of (symbol_def_policy * string * symbol_spec) +and +sort_policy + = DefaultSort (* Use command line sort option, else "seen" order *) + | SeenOrder (* Always use "seen" order *) + | ByName + | ByNameThenAlignment + | ByAlignment + | ByAlignmentThenName + | ByInitPriority +and +(* This mirrors the OutputSection constructor, except that the script elements have become + * output_section_composition_elements, and we might store the size here. *) +output_section_spec = + OutputSectionSpec of (output_guard * Nat_big_num.num option * string * ( output_section_composition_element list)) +and +allocated_sections_map = + AllocatedSectionsMap of (string, (output_section_spec (* OutputSection element idx *) * Nat_big_num.num)) Pmap.map +and +address_expr_fn + = AddressExprFn of address_expr_fn_ref + +type script_element = + DefineSymbol of (symbol_def_policy * string * symbol_spec) +| AdvanceAddress of address_expr_fn +| MarkAndAlignDataSegment of (Nat_big_num.num * Nat_big_num.num) (* maxpagesize, commonpagesize *) +| MarkDataSegmentEnd +| MarkDataSegmentRelroEnd (*of (allocated_sections_map -> (natural * (natural -> natural))) DPM: commented out because of positivity constrains in Isabelle *) +| OutputSection of (output_guard * ( (* address_expr *) address_expr_fn option) * string * script_element list) +| DiscardInput of input_selector + (* Input queries can only occur within an output section. + Output sections may not nest within other output sections. + (Ideally we would use something like polymorphic variants to encode this.) + *) +| InputQuery of (retain_policy * sort_policy * input_selector) + +(* A linker control script is a function from inputs to output elements. + * We can define them in syntax (using an interpreter) + * or in Lem directly (as functions). *) +type linker_control_script = script_element list +type labelled_linker_control_script = (script_element * Nat_big_num.num) list + +(*val all_suffixes : list char -> list (list char)*) +let rec all_suffixes chars:((char)list)list= + ((match chars with + [] -> [[]] + | c :: morecs -> chars :: (all_suffixes morecs) + )) + +(*val glob_match : list char -> list char -> bool*) +let rec glob_match pat str:bool= + ((match (pat, str) with + ([], []) -> true + | ('?':: morepat, _ :: morestr) -> glob_match morepat morestr + | ('*':: morepat, _) -> + (* if any suffix of the remaining string matches + * the remaining pattern, we've matched the pattern + * from '*' onwards. *) + let or_suffix_match = (fun matched -> (fun newlist -> + matched || glob_match morepat newlist)) + in + List.fold_left (or_suffix_match) false (all_suffixes str) + | (patc :: morepat, c :: morestr) -> (patc = c) && glob_match morepat morestr + | ([], _) -> (* ran out of pattern *) false + | (_, []) -> (* ran out of str *) false + )) + +(*val default_symbol_spec : symbol_spec*) +let default_symbol_spec:Nat_big_num.num*Uint32.uint32*Uint32.uint32= (Nat_big_num.of_int 0, Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)), Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) +(*val hidden_symbol_spec : symbol_spec*) +let hidden_symbol_spec:Nat_big_num.num*Uint32.uint32*Uint32.uint32= (Nat_big_num.of_int 0, Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0)), Uint32.of_string (Nat_big_num.to_string stv_hidden)) + +(* These Lem functions replicate linker script functions or builtin behaviours. *) + +(*val only_sections : input_selector*) +let only_sections inputs:(input_spec)list= (Lem_list.mapMaybe + (fun i -> (match i with + | InputSection(_) -> Some(i) + | _ -> None + )) inputs) + +(*val filter_and_concat : (input_spec -> bool) -> input_selector*) (* a.k.a. list input_spec -> list input_spec *) +let filter_and_concat p inputs:(input_spec)list= (List.filter p inputs) + +(*val name_matches : string -> input_spec -> bool*) +let name_matches pat input:bool= + ((match input with + InputSection(inp) -> + (*let _ = errln ("Does section name `" ^ inp.secname ^ "' match glob pattern `" ^ pat ^ "'? ") in + let result = *)glob_match (Xstring.explode pat) (Xstring.explode inp.secname) (*in + let _ = errln (if result then "yes" else "no") + in result*) + | _ -> false + )) + +(*val file_matches : string -> input_spec -> bool*) +let file_matches pat input:bool= + ((match input with + InputSection(inp) -> glob_match (Xstring.explode pat) (Xstring.explode inp.fname) + | _ -> false + )) + +let compareInputSpecByNameThenAlignment i1 i2:int= + (let toPair = (fun is -> ((match is with + Common(idx1, fname1, img2, def) -> ("COMMON" (* FIXME: is this right? *), Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_value) + | InputSection(isrec) -> (isrec.isec.elf64_section_name_as_string, isrec.isec.elf64_section_align) + ))) + in (pairCompare compare Nat_big_num.compare (toPair i1) (toPair i2))) + +let compareInputSpecByAlignment i1 i2:int= + (let toNatural = (fun is -> ((match is with + Common(idx1, fname1, img2, def) -> Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_value + | InputSection(isrec) -> isrec.isec.elf64_section_align + ))) + in Nat_big_num.compare (toNatural i1) (toNatural i2)) + +let compareInputSpecByName i1 i2:int= + (let toString = (fun is -> ((match is with + Common(idx1, fname1, img2, def) -> "COMMON" + | InputSection(isrec) -> isrec.isec.elf64_section_name_as_string + ))) + in compare (toString i1) (toString i2)) + +let compareInputSpecByAlignmentThenName i1 i2:int= + (let toPair = (fun is -> ((match is with + Common(idx1, fname1, img2, def) -> (Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_value, + "COMMON" (* FIXME: is this right? *)) + | InputSection(isrec) -> (isrec.isec.elf64_section_align, isrec.isec.elf64_section_name_as_string) + ))) + in (pairCompare Nat_big_num.compare compare (toPair i1) (toPair i2))) + +let compareInputSpecByInitPriority i1 i2:int= 0 (* FIXME *) + +(* DATA_SEGMENT_ALIGN is defined by two formulae + * (over pos and commonpagesize/maxpagesize) + * "... depending on whether the latter uses fewer COMMONPAGESIZE sized + pages for the data segment (area between the result of this + expression and `DATA_SEGMENT_END') than the former or not. If the + latter form is used, it means COMMONPAGESIZE bytes of runtime + memory will be saved at the expense of up to COMMONPAGESIZE wasted + bytes in the on-disk file." + + So the amount of padding that gets inserted here depends on the location + of something that comes *later*, namely DATA_SEGMENT_END. + So, we can't model it as a function of the current position. + Instead, we add MarkDataSegmentEnd and friends + to the script_element ADT. + *) + +let has_writability:'a ->input_spec ->bool= (fun writable -> (fun input_sec -> ( + (match input_sec with + Common(_, _, _, _) + -> (* all common symbols are potentially writable *) true + | InputSection(inp) + -> let (flags : Nat_big_num.num) = ((match elf_memory_image_section_by_index inp.shndx inp.img with + Some x -> x.elf64_section_flags + | None -> failwith ("impossible: no such section" (*(index " ^ (show inp.shndx) ^ ")""*)) + )) + in + flag_is_set shf_write flags + ) +))) + +(* LARGE_COMMON seems to have been defined in this patch set: + https://sourceware.org/ml/binutils/2005-07/txt00014.txt + and at the time was "only for x86-64". It seems to be analogous + to ".lbss", i.e. "large bss". libbfd defines SHF_X86_64_LARGE. + The best comment seems to be in llvm's Support/ELF.h: + +0814 // If an object file section does not have this flag set, then it may not hold +0815 // more than 2GB and can be freely referred to in objects using smaller code +0816 // models. Otherwise, only objects using larger code models can refer to them. +0817 // For example, a medium code model object can refer to data in a section that +0818 // sets this flag besides being able to refer to data in a section that does +0819 // not set it; likewise, a small code model object can refer only to code in a +0820 // section that does not set this flag. + + *) + +(*val address_zero : natural -> address_expr_fn_map allocated_sections_map -> + (natural * address_expr_fn_map allocated_sections_map * address_expr_fn)*) +let address_zero fresh alloc_map:Nat_big_num.num*((Nat_big_num.num),(Nat_big_num.num ->allocated_sections_map ->Nat_big_num.num))Pmap.map*address_expr_fn= + (let alloc_map' = (Pmap.add fresh (fun pos -> (fun secs ->Nat_big_num.of_int 0)) alloc_map) in + let fresh' = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + (fresh', alloc_map', AddressExprFn fresh)) + +(* +val output_sec_composition_size : list output_section_composition_element -> natural +let output_sec_composition_size comp = List.foldl (+) 0 (List.map size_of_output_section_composition_element comp) +*) +(*val do_output_section_layout_starting_at_addr : natural -> allocated_sections_map -> list output_section_composition_element -> (natural * list natural)*) +let do_output_section_layout_starting_at_addr start_addr (AllocatedSectionsMap secs) comps:Nat_big_num.num*(Nat_big_num.num)list= +( + (* map out where we plumb in each section, accounting for their alignment *)List.fold_left (fun (next_free_addr, addr_list) -> (fun comp_el -> (match comp_el with + IncludeInputSection(retain_pol, irec (* fname, linkable_idx, shndx, isec, img *)) -> + let aligned_next_free = (align_up_to irec.isec.elf64_section_align next_free_addr) + in + (*let _ = errln ("Aligned start address up to 0x" ^ hex_string_of_natural aligned_next_free ^ + " (align 0x" ^ (hex_string_of_natural irec.isec.elf64_section_align) ^ + ") for included output section `" ^ + irec.isec.elf64_section_name_as_string ^ "' from file `" ^ irec.fname ^ "'") + in*) + ( Nat_big_num.add aligned_next_free irec.isec.elf64_section_size, List.rev_append (List.rev addr_list) [aligned_next_free]) + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> + let aligned_next_free = (align_up_to (Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_value) next_free_addr) + in + ( Nat_big_num.add aligned_next_free (Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_size), List.rev_append (List.rev addr_list) [aligned_next_free]) + (*| Hole(AddressExprFn f) -> (f next_free_addr secs, addr_list ++ [next_free_addr])*) + | ProvideSymbol(pol, name1, spec) -> (next_free_addr, List.rev_append (List.rev addr_list) [next_free_addr]) + ) + )) (start_addr, []) comps) + +(*val output_sec_composition_size_given_start_addr : natural -> allocated_sections_map -> list output_section_composition_element -> natural*) +let output_sec_composition_size_given_start_addr start_addr secs comp:Nat_big_num.num= + (let (end_addr, comp_addrs) = (do_output_section_layout_starting_at_addr start_addr secs comp) + in Nat_big_num.sub_nat + end_addr start_addr) + +(*val sizeof : string -> allocated_sections_map -> natural*) +let sizeof secname1 (AllocatedSectionsMap secs):Nat_big_num.num= + ((match Pmap.lookup secname1 secs with + Some(OutputSectionSpec (_, maybe_addr, _, comp), _) -> (match maybe_addr with + Some addr -> output_sec_composition_size_given_start_addr addr (AllocatedSectionsMap secs) comp + | None -> failwith ("error: sizeof applied to section without defined start address") + ) + | None -> failwith ("error: sizeof applied to non-existent section name " ^ secname1) + )) + +(*val alignof_output_section_composition_element : output_section_composition_element -> natural*) +let alignof_output_section_composition_element comp:Nat_big_num.num= + ((match comp with + IncludeInputSection(_, irec) -> irec.isec.elf64_section_align + | IncludeCommonSymbol(_, _, _, def, _) -> Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_value + | _ ->Nat_big_num.of_int 1 (* CHECK *) + )) + +(*val alignof_output_section : list output_section_composition_element -> natural*) +let alignof_output_section comps:Nat_big_num.num= + (let aligns = (Lem_list.map alignof_output_section_composition_element comps) + in + List.fold_left (fun acc_lcm -> fun next -> lcm acc_lcm next)(Nat_big_num.of_int 1) aligns) + +(*val default_linker_control_script : natural -> address_expr_fn_map allocated_sections_map -> + abi any_abi_feature -> maybe natural -> maybe natural -> maybe natural -> + natural -> (natural * address_expr_fn_map allocated_sections_map * linker_control_script)*) +let default_linker_control_script fresh alloc_map a user_text_segment_start user_data_segment_start user_rodata_segment_start elf_headers_size:Nat_big_num.num*((Nat_big_num.num),(Nat_big_num.num ->allocated_sections_map ->Nat_big_num.num))Pmap.map*(script_element)list= + (let segment_start name1 default= ((match name1 with + "ldata-segment" -> (match user_data_segment_start with + None -> default + | Some addr -> (* fun _ -> *) addr + ) + | "text-segment" -> (match user_text_segment_start with + None -> default + | Some addr -> (* fun _ -> *) addr + ) + )) + in + let is_large_common = (fun inp -> (* FIXME: treat large commons separately *) false + ) + in + let is_common = (fun isec1 -> (match isec1 with + Common(idx1, fname1, img2, def) -> (*let _ = errln ("Common or large-common symbol: " ^ def.def_symname) in *) + not (is_large_common isec1) + | _ -> false + )) + in + let alloc_fn1 = (fun _ -> (fun _ -> Nat_big_num.add (segment_start "text-segment" ( Nat_big_num.mul(Nat_big_num.of_int 4)(Nat_big_num.of_int 1048576))) elf_headers_size)) in + let alloc_fn1_ref = fresh in + let alloc_map = (Pmap.add alloc_fn1_ref alloc_fn1 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn2 = (fun addr -> (fun _ -> Nat_big_num.sub_nat + (* (align_up_to a.maxpagesize addr) - (natural_land (a.maxpagesize - addr) (a.maxpagesize - 1)) *) + (* + FIXME: understand the intention of this assignment. + Evaluating a simple example of this (from true-static-uClibc) + + (ALIGN (0x200000) - ((0x200000 - .) & 0x1fffff)) + + starting from 0x00000000004017dc + means + 0x600000 - ((0x200000 - 0x4017dc) & 0x1fffff) + i.e. + 0x600000 - (((-0x2017dc)) & 0x1fffff) + i.e. + 0x600000 - ( -0x2017dc + & 0x1fffff ) + + which really does come to (according to bash) 0x4017dc + i.e. we subtract 0x1fe824 from 0x600000 + and end up back where we started. + + What does ANDing a negative number mean? + It doesn't seem to work for us. + Well, to take the negation we flip every bit and add one. + So if we don't want to do a subtraction that might go negative, + we can instead add the complement. + *) + (align_up_to a.maxpagesize addr) (Nat_big_num.bitwise_and ( Nat_big_num.add a.maxpagesize (compl64 addr)) ( Nat_big_num.sub_nat a.maxpagesize(Nat_big_num.of_int 1))))) in + let (fresh, alloc_map, (address_zero_fn : address_expr_fn)) = (address_zero fresh alloc_map) in + let alloc_fn2_ref = fresh in + let alloc_map = (Pmap.add alloc_fn2_ref alloc_fn2 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn3 = (fun pos -> (fun secs -> align_up_to (if Nat_big_num.equal pos(Nat_big_num.of_int 0) then (Nat_big_num.div(Nat_big_num.of_int 64)(Nat_big_num.of_int 8)) else Nat_big_num.of_int 1) pos)) in + let alloc_fn3_ref = fresh in + let alloc_map = (Pmap.add alloc_fn3_ref alloc_fn3 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn4 = (fun pos -> (fun secs -> align_up_to (Nat_big_num.div(Nat_big_num.of_int 64)(Nat_big_num.of_int 8)) pos)) in + let alloc_fn4_ref = fresh in + let alloc_map = (Pmap.add alloc_fn4_ref alloc_fn4 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn5 = (fun pos -> (fun secs -> segment_start "ldata-segment" pos)) in + let alloc_fn5_ref = fresh in + let alloc_map = (Pmap.add alloc_fn5_ref alloc_fn5 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn6 = (fun pos -> fun secs -> align_up_to ( Nat_big_num.add a.maxpagesize ( Nat_big_num.sub_nat(Nat_big_num.bitwise_and pos a.maxpagesize)(Nat_big_num.of_int 1))) pos) in + let alloc_fn6_ref = fresh in + let alloc_map = (Pmap.add alloc_fn6_ref alloc_fn6 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn7 = (fun pos -> (fun secs -> (if not (Nat_big_num.equal pos(Nat_big_num.of_int 0)) then Nat_big_num.div(Nat_big_num.of_int 64)(Nat_big_num.of_int 8) else Nat_big_num.of_int 1))) in + let alloc_fn7_ref = fresh in + let alloc_map = (Pmap.add alloc_fn7_ref alloc_fn7 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + let alloc_fn8 = (fun pos -> (fun secs -> align_up_to (Nat_big_num.div(Nat_big_num.of_int 64)(Nat_big_num.of_int 8)) pos)) in + let alloc_fn8_ref = fresh in + let alloc_map = (Pmap.add alloc_fn8_ref alloc_fn8 alloc_map) in + let fresh = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + (fresh, alloc_map, [ + (* For now, we base our script on the GNU bfd linker's scripts. + Here's the static -z combreloc one. + +/* Script for -z combreloc: combine and sort reloc sections */ +/* Copyright (C) 2014 Free Software Foundation, Inc. + Copying and distribution of this script, with or without modification, + are permitted in any medium without royalty provided the copyright + notice and this notice are preserved. */ +OUTPUT_FORMAT("elf64-x86-64", "elf64-x86-64", + "elf64-x86-64") +OUTPUT_ARCH(i386:x86-64) +ENTRY(_start) +SEARCH_DIR("=/usr/x86_64-linux-gnu/lib64"); SEARCH_DIR("=/usr/local/lib/x86_64-linux-gnu"); SEARCH_DIR("=/usr/local/lib64"); SEARCH_DIR("=/lib/x86_64-linux-gnu"); SEARCH_DIR("=/lib64"); SEARCH_DIR("=/usr/lib/x86_64-linux-gnu"); SEARCH_DIR("=/usr/lib64"); SEARCH_DIR("=/usr/x86_64-linux-gnu/lib"); SEARCH_DIR("=/usr/local/lib"); SEARCH_DIR("=/lib"); SEARCH_DIR("=/usr/lib"); +SECTIONS +{ + /* Read-only sections, merged into text segment: */ + PROVIDE (__executable_start = SEGMENT_START("text-segment", 0x400000)); . = SEGMENT_START("text-segment", 0x400000) + SIZEOF_HEADERS; + .interp : { *(.interp) } + .note.gnu.build-id : { *(.note.gnu.build-id) } + .hash : { *(.hash) } + .gnu.hash : { *(.gnu.hash) } + .dynsym : { *(.dynsym) } + .dynstr : { *(.dynstr) } + .gnu.version : { *(.gnu.version) } + .gnu.version_d : { *(.gnu.version_d) } + .gnu.version_r : { *(.gnu.version_r) } + .rela.dyn : + { + *(.rela.init) + *(.rela.text .rela.text.* .rela.gnu.linkonce.t.* ) + *(.rela.fini) + *(.rela.rodata .rela.rodata.* .rela.gnu.linkonce.r.* ) + *(.rela.data .rela.data.* .rela.gnu.linkonce.d.* ) + *(.rela.tdata .rela.tdata.* .rela.gnu.linkonce.td.* ) + *(.rela.tbss .rela.tbss.* .rela.gnu.linkonce.tb.* ) + *(.rela.ctors) + *(.rela.dtors) + *(.rela.got) + *(.rela.bss .rela.bss.* .rela.gnu.linkonce.b.* ) + *(.rela.ldata .rela.ldata.* .rela.gnu.linkonce.l.* ) + *(.rela.lbss .rela.lbss.* .rela.gnu.linkonce.lb.* ) + *(.rela.lrodata .rela.lrodata.* .rela.gnu.linkonce.lr.* ) + *(.rela.ifunc) + } + .rela.plt : + { + *(.rela.plt) + PROVIDE_HIDDEN (__rela_iplt_start = .); + *(.rela.iplt) + PROVIDE_HIDDEN (__rela_iplt_end = .); + } + .init : + { + KEEP ( *(SORT_NONE(.init))) + } + .plt : { *(.plt) *(.iplt) } + .plt.bnd : { *(.plt.bnd) } + .text : + { + *(.text.unlikely .text.*_unlikely .text.unlikely.* ) + *(.text.exit .text.exit.* ) + *(.text.startup .text.startup.* ) + *(.text.hot .text.hot.* ) + *(.text .stub .text.* .gnu.linkonce.t.* ) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + } + .fini : + { + KEEP ( *(SORT_NONE(.fini))) + } + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.* ) } + .rodata1 : { *(.rodata1) } + .eh_frame_hdr : { *(.eh_frame_hdr) } + .eh_frame : ONLY_IF_RO { KEEP ( *(.eh_frame)) } + .gcc_except_table : ONLY_IF_RO { *(.gcc_except_table + .gcc_except_table.* ) } + /* These sections are generated by the Sun/Oracle C++ compiler. */ + .exception_ranges : ONLY_IF_RO { *(.exception_ranges + .exception_ranges* ) } + /* Adjust the address for the data segment. We want to adjust up to + the same address within the page on the next page up. */ + . = ALIGN (CONSTANT (MAXPAGESIZE)) - ((CONSTANT (MAXPAGESIZE) - .) & (CONSTANT (MAXPAGESIZE) - 1)); . = DATA_SEGMENT_ALIGN (CONSTANT (MAXPAGESIZE), CONSTANT (COMMONPAGESIZE)); + /* Exception handling */ + .eh_frame : ONLY_IF_RW { KEEP ( *(.eh_frame)) } + .gcc_except_table : ONLY_IF_RW { *(.gcc_except_table .gcc_except_table.* ) } + .exception_ranges : ONLY_IF_RW { *(.exception_ranges .exception_ranges* ) } + /* Thread Local Storage sections */ + .tdata : { *(.tdata .tdata.* .gnu.linkonce.td.* ) } + .tbss : { *(.tbss .tbss.* .gnu.linkonce.tb.* ) *(.tcommon) } + .preinit_array : + { + PROVIDE_HIDDEN (__preinit_array_start = .); + KEEP ( *(.preinit_array)) + PROVIDE_HIDDEN (__preinit_array_end = .); + } + .init_array : + { + PROVIDE_HIDDEN (__init_array_start = .); + KEEP ( *(SORT_BY_INIT_PRIORITY(.init_array.* ) SORT_BY_INIT_PRIORITY(.ctors.* ))) + KEEP ( *(.init_array EXCLUDE_FILE ( *crtbegin.o *crtbegin?.o *crtend.o *crtend?.o ) .ctors)) + PROVIDE_HIDDEN (__init_array_end = .); + } + .fini_array : + { + PROVIDE_HIDDEN (__fini_array_start = .); + KEEP ( *(SORT_BY_INIT_PRIORITY(.fini_array.* ) SORT_BY_INIT_PRIORITY(.dtors.* ))) + KEEP ( *(.fini_array EXCLUDE_FILE ( *crtbegin.o *crtbegin?.o *crtend.o *crtend?.o ) .dtors)) + PROVIDE_HIDDEN (__fini_array_end = .); + } + .ctors : + { + /* gcc uses crtbegin.o to find the start of + the constructors, so we make sure it is + first. Because this is a wildcard, it + doesn't matter if the user does not + actually link against crtbegin.o; the + linker won't look for a file to match a + wildcard. The wildcard also means that it + doesn't matter which directory crtbegin.o + is in. */ + KEEP ( *crtbegin.o(.ctors)) + KEEP ( *crtbegin?.o(.ctors)) + /* We don't want to include the .ctor section from + the crtend.o file until after the sorted ctors. + The .ctor section from the crtend file contains the + end of ctors marker and it must be last */ + KEEP ( *(EXCLUDE_FILE ( *crtend.o *crtend?.o ) .ctors)) + KEEP ( *(SORT(.ctors.* ))) + KEEP ( *(.ctors)) + } + .dtors : + { + KEEP ( *crtbegin.o(.dtors)) + KEEP ( *crtbegin?.o(.dtors)) + KEEP ( *(EXCLUDE_FILE ( *crtend.o *crtend?.o ) .dtors)) + KEEP ( *(SORT(.dtors.* ))) + KEEP ( *(.dtors)) + } + .jcr : { KEEP ( *(.jcr)) } + .data.rel.ro : { *(.data.rel.ro.local* .gnu.linkonce.d.rel.ro.local.* ) *(.data.rel.ro .data.rel.ro.* .gnu.linkonce.d.rel.ro.* ) } + .dynamic : { *(.dynamic) } + .got : { *(.got) *(.igot) } + . = DATA_SEGMENT_RELRO_END (SIZEOF (.got.plt) >= 24 ? 24 : 0, .); + .got.plt : { *(.got.plt) *(.igot.plt) } + .data : + { + *(.data .data.* .gnu.linkonce.d.* ) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + _edata = .; PROVIDE (edata = .); + . = .; + __bss_start = .; + .bss : + { + *(.dynbss) + *(.bss .bss.* .gnu.linkonce.b.* ) + *(COMMON) + /* Align here to ensure that the .bss section occupies space up to + _end. Align after .bss to ensure correct alignment even if the + .bss section disappears because there are no input sections. + FIXME: Why do we need it? When there is no .bss section, we don't + pad the .data section. */ + . = ALIGN(. != 0 ? 64 / 8 : 1); + } + .lbss : + { + *(.dynlbss) + *(.lbss .lbss.* .gnu.linkonce.lb.* ) + *(LARGE_COMMON) + } + . = ALIGN(64 / 8); + . = SEGMENT_START("ldata-segment", .); + .lrodata ALIGN(CONSTANT (MAXPAGESIZE)) + (. & (CONSTANT (MAXPAGESIZE) - 1)) : + { + *(.lrodata .lrodata.* .gnu.linkonce.lr.* ) + } + .ldata ALIGN(CONSTANT (MAXPAGESIZE)) + (. & (CONSTANT (MAXPAGESIZE) - 1)) : + { + *(.ldata .ldata.* .gnu.linkonce.l.* ) + . = ALIGN(. != 0 ? 64 / 8 : 1); + } + . = ALIGN(64 / 8); + _end = .; PROVIDE (end = .); + . = DATA_SEGMENT_END (.); + /* Stabs debugging sections. */ + .stab 0 : { *(.stab) } + .stabstr 0 : { *(.stabstr) } + .stab.excl 0 : { *(.stab.excl) } + .stab.exclstr 0 : { *(.stab.exclstr) } + .stab.index 0 : { *(.stab.index) } + .stab.indexstr 0 : { *(.stab.indexstr) } + .comment 0 : { *(.comment) } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section so we begin them at 0. */ + /* DWARF 1 */ + .debug 0 : { *(.debug) } + .line 0 : { *(.line) } + /* GNU DWARF 1 extensions */ + .debug_srcinfo 0 : { *(.debug_srcinfo) } + .debug_sfnames 0 : { *(.debug_sfnames) } + /* DWARF 1.1 and DWARF 2 */ + .debug_aranges 0 : { *(.debug_aranges) } + .debug_pubnames 0 : { *(.debug_pubnames) } + /* DWARF 2 */ + .debug_info 0 : { *(.debug_info .gnu.linkonce.wi.* ) } + .debug_abbrev 0 : { *(.debug_abbrev) } + .debug_line 0 : { *(.debug_line .debug_line.* .debug_line_end ) } + .debug_frame 0 : { *(.debug_frame) } + .debug_str 0 : { *(.debug_str) } + .debug_loc 0 : { *(.debug_loc) } + .debug_macinfo 0 : { *(.debug_macinfo) } + /* SGI/MIPS DWARF 2 extensions */ + .debug_weaknames 0 : { *(.debug_weaknames) } + .debug_funcnames 0 : { *(.debug_funcnames) } + .debug_typenames 0 : { *(.debug_typenames) } + .debug_varnames 0 : { *(.debug_varnames) } + /* DWARF 3 */ + .debug_pubtypes 0 : { *(.debug_pubtypes) } + .debug_ranges 0 : { *(.debug_ranges) } + /* DWARF Extension. */ + .debug_macro 0 : { *(.debug_macro) } + .gnu.attributes 0 : { KEEP ( *(.gnu.attributes)) } + /DISCARD/ : { *(.note.GNU-stack) *(.gnu_debuglink) *(.gnu.lto_* ) } +} + *) + + (* function from + inputs and configuration + to + output sections-with-address-and-policy, output symbols-with-address-and-attributes, + discards, orphans + BUT + 1. policy is not a property of output sections, but of *inputs within outputs* + i.e. KEEP( *(.init)) + + what's helpful for writing such functions? + + e.g. only_if_ro (input_query) (output ): + + i.e. ++ only_if_ro OutputSection(AlwaysOutput, Nothing, ".eh_frame", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".eh_frame"))]) + + want to take a bunch of outputs + and return a bunch of outputs? + + if so, need to return a "current address" + + *) + (DefineSymbol(ProvideIfUsed, "__executable_start", default_symbol_spec)) + ; AdvanceAddress(AddressExprFn alloc_fn1_ref) + ; OutputSection(AlwaysOutput, None, ".interp", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".interp"))]) + ; OutputSection(AlwaysOutput, None, ".note.gnu.build-id", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".note.gnu.build-id"))]) + ; OutputSection(AlwaysOutput, None, ".hash", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".hash"))]) + ; OutputSection(AlwaysOutput, None, ".gnu.hash", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".gnu.hash"))]) + ; OutputSection(AlwaysOutput, None, ".dynsym", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".dynsym"))]) + ; OutputSection(AlwaysOutput, None, ".dynstr", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".dynstr"))]) + ; OutputSection(AlwaysOutput, None, ".gnu.version", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".gnu.version"))]) + ; OutputSection(AlwaysOutput, None, ".gnu.version_d", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".gnu.version_d"))]) + ; OutputSection(AlwaysOutput, None, ".gnu.version_r", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".gnu.version_r"))]) + ; OutputSection(AlwaysOutput, None, ".rela.dyn", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".rela.init")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.text" s || (name_matches ".rela.text.*" s || name_matches ".rela.gnu.linkonce.t.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.rodata" s || (name_matches ".rela.rodata.*" s || name_matches ".rela.gnu.linkonce.r.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.data" s || (name_matches ".rela.data.*" s || name_matches ".rela.gnu.linkonce.d.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.tdata" s || (name_matches ".rela.tdata.*" s || name_matches ".rela.gnu.linkonce.td.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.tbss" s || (name_matches ".rela.tbss.*" s || name_matches ".rela.gnu.linkonce.tb.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".rela.ctors")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".rela.got")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.bss" s || (name_matches ".rela.bss.*" s || name_matches ".rela.gnu.linkonce.b.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.ldata" s || (name_matches ".rela.ldata.*" s || name_matches ".rela.gnu.linkonce.l.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rela.lbss" s || (name_matches ".rela.lbss.*" s || name_matches ".rela.gnu.linkonce.lb.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".rela.ifunc")) + ]) + ; OutputSection(AlwaysOutput, None, ".rela.plt", [ + InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".rela.plt")) + ; DefineSymbol(ProvideIfUsed, "__rela_iplt_start", (Nat_big_num.of_int 0, make_symbol_info stb_local stt_notype (* FIXME *), make_symbol_other stv_hidden)) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".rela.iplt")) + ; DefineSymbol(ProvideIfUsed, "__rela_iplt_end", (Nat_big_num.of_int 0, make_symbol_info stb_local stt_notype (* FIXME *), make_symbol_other stv_hidden)) + ]) + ; OutputSection(AlwaysOutput, None, ".init", [ + InputQuery(KeepEvenWhenGC, SeenOrder, filter_and_concat (name_matches ".init")) + ]) + ; OutputSection(AlwaysOutput, None, ".plt", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".plt")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".iplt")) + ]) + ; OutputSection(AlwaysOutput, None, ".plt.bnd", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".plt.bnd"))]) + ; OutputSection(AlwaysOutput, None, ".text", [ + InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".text.unlikely" s || (name_matches ".text.*_unlikely" s || name_matches ".text.unlikely.*" s) + )) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".text.exit" s || name_matches ".text.exit.*" s)) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".text.startup" s || name_matches ".text.startup.*" s)) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".text.hot" s || name_matches ".text.hot.*" s)) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".text" s || (name_matches ".stub" s || (name_matches ".text.*" s || name_matches ".gnu.linkonce.t.*" s)))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + (* ".gnu.warning sections are handled specially by elf32.em." + * GAH. That means that what we specify here is not (completely) what + * needs to happen with these sections. *) + fun s -> name_matches ".gnu_warning" s)) + ]) + ; OutputSection(AlwaysOutput, None, ".fini", [ + InputQuery(KeepEvenWhenGC, SeenOrder, filter_and_concat (name_matches ".fini")) + ]) + ; DefineSymbol(ProvideIfUsed, "__etext", default_symbol_spec) + ; DefineSymbol(ProvideIfUsed, "_etext", default_symbol_spec) + ; DefineSymbol(ProvideIfUsed, "etext", default_symbol_spec) + ; OutputSection(AlwaysOutput, None, ".rodata", [ + InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".rodata" s || (name_matches ".rodata.*" s || name_matches ".gnu.linkonce.r.*" s) + ))]) + ; OutputSection(AlwaysOutput, None, ".eh_frame_hdr", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".eh_frame_hdr")) ]) + ; OutputSection(OnlyIfRo, None, ".eh_frame", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".eh_frame"))]) + ; OutputSection(OnlyIfRo, None, ".gcc_except_table", [InputQuery(DefaultKeep, DefaultSort, + filter_and_concat (fun s -> name_matches ".gcc_except_table" s || name_matches ".gcc_except_table.*" s))]) + ; OutputSection(OnlyIfRo, None, ".exception_ranges", [InputQuery(DefaultKeep, DefaultSort, + filter_and_concat (fun s -> name_matches ".exception_ranges" s || name_matches ".exception_ranges*" s))]) + ; AdvanceAddress(AddressExprFn alloc_fn2_ref) + ; MarkAndAlignDataSegment( Nat_big_num.mul (Nat_big_num.mul(Nat_big_num.of_int (* a.maxpagesize *)2)(Nat_big_num.of_int 1024))(Nat_big_num.of_int 1024) (* <-- for some reason binutils assumes 2MB max page size, + even if ABI says smaller *), a.commonpagesize) + ; OutputSection(OnlyIfRw, None, ".eh_frame", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".eh_frame"))]) + ; OutputSection(OnlyIfRw, None, ".gcc_except_table", [InputQuery(DefaultKeep, DefaultSort, + filter_and_concat (fun s -> name_matches ".gcc_except_table" s || name_matches ".gcc_except_table.*" s))]) + ; OutputSection(OnlyIfRw, None, ".exception_ranges", [InputQuery(DefaultKeep, DefaultSort, + filter_and_concat (fun s -> name_matches ".exception_ranges" s || name_matches ".exception_ranges*" s))]) + ; OutputSection(AlwaysOutput, None, ".tdata", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat + (fun s -> name_matches ".tdata" s || (name_matches ".tdata.*" s || name_matches ".gnu.linkonce.td.*" s)))]) + ; OutputSection(AlwaysOutput, None, ".tbss", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat + (fun s -> name_matches ".tbss" s || (name_matches ".tbss.*" s || name_matches ".gnu.linkonce.tb.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".tcommon"))]) + ; OutputSection(AlwaysOutput, None, ".preinit_array", [ + DefineSymbol(ProvideIfUsed, "__preinit_array_start", default_symbol_spec) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (fun s -> name_matches ".preinit_array" s)) + ; DefineSymbol(ProvideIfUsed, "__preinit_array_end", default_symbol_spec) + ]) + ; OutputSection(AlwaysOutput, None, ".init_array", [ + DefineSymbol(ProvideIfUsed, "__init_array_start", default_symbol_spec) + ; InputQuery(KeepEvenWhenGC, ByInitPriority, filter_and_concat (fun s -> name_matches ".init_array.*" s)) + ; InputQuery(KeepEvenWhenGC, ByInitPriority, filter_and_concat (fun s -> name_matches ".ctors.*" s)) + ; InputQuery(KeepEvenWhenGC, ByInitPriority, filter_and_concat + (fun s -> name_matches ".init_array" s + || (name_matches ".ctors" s && not (file_matches "*crtbegin.o" s || (file_matches "*crtbegin?.o" s + || (file_matches "*crtend.o" s || file_matches "*crtend?.o " s))))) + ) + ; DefineSymbol(ProvideIfUsed, "__init_array_end", default_symbol_spec) + ]) + ; OutputSection(AlwaysOutput, None, ".fini_array", [ + DefineSymbol(ProvideIfUsed, "__fini_array_start", default_symbol_spec) + ; InputQuery(KeepEvenWhenGC, ByInitPriority, filter_and_concat (fun s -> name_matches ".fini_array.*" s)) + ; InputQuery(KeepEvenWhenGC, ByInitPriority, filter_and_concat (fun s -> name_matches ".dtors.*" s)) + ; InputQuery(KeepEvenWhenGC, ByInitPriority, filter_and_concat + (fun s -> name_matches ".fini_array" s + || (name_matches ".dtors" s && not (file_matches "*crtbegin.o" s || (file_matches "*crtbegin?.o" s + || (file_matches "*crtend.o" s || file_matches "*crtend?.o " s))))) + ) + ; DefineSymbol(ProvideIfUsed, "__fini_array_end", default_symbol_spec) + ]) + ; OutputSection(AlwaysOutput, None, ".ctors", [ + InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (fun s -> file_matches "*crtbegin.o" s && name_matches ".ctors" s)) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (fun s -> file_matches "*crtbegin?.o" s && name_matches ".ctors" s)) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat + (fun s -> not (file_matches "*crtend.o" s || file_matches "*crtend?.o" s) && name_matches ".ctors" s)) + ; InputQuery(KeepEvenWhenGC, ByName, filter_and_concat (fun s -> name_matches ".ctors.*" s)) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat + (fun s -> (file_matches "*crtend.o" s || file_matches "*crtend?.o" s) && name_matches ".ctors" s)) + (* NOTE: this exclusion is implicit in the usual linker script, + * because it won't match an input section more than once. We should + * just replicate this behaviour, since other parts of the script might rely on it + * less obviously. *) + ]) + ; OutputSection(AlwaysOutput, None, ".dtors", [ + InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (fun s -> file_matches "*crtbegin.o" s && name_matches ".dtors" s)) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (fun s -> file_matches "*crtbegin?.o" s && name_matches ".dtors" s)) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat + (fun s -> not (file_matches "*crtend.o" s || file_matches "*crtend?.o" s) && name_matches ".dtors" s)) + ; InputQuery(KeepEvenWhenGC, ByName, filter_and_concat (fun s -> name_matches ".dtors.*" s)) + ; InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat + (fun s -> (file_matches "*crtend.o" s || file_matches "*crtend?.o" s) && name_matches ".dtors" s)) + ]) + ; OutputSection(AlwaysOutput, None, ".jcr", [InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (name_matches ".jcr"))]) + ; OutputSection(AlwaysOutput, None, ".data.rel.ro", [ + InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".data.rel.ro.local*" s || name_matches ".gnu.linkonce.d.rel.ro.local.*" s + )); + InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".data.rel.ro" s || (name_matches ".data.rel.ro.*" s || name_matches ".gnu.linkonce.d.rel.ro.*" s) + )) + ]) + ; OutputSection(AlwaysOutput, None, ".dynamic", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".dynamic"))]) + ; OutputSection(AlwaysOutput, None, ".got", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".got")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".igot")) + ]) + ; MarkDataSegmentRelroEnd (*(fun secs -> (if (sizeof ".got.plt" secs) >= 24 then 24 else 0, (fun pos -> pos)))*) + ; OutputSection(AlwaysOutput, None, ".got.plt", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".got.plt")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".igot.plt")) + ]) + ; OutputSection(AlwaysOutput, None, ".data", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".data" s || (name_matches ".data.*" s || name_matches ".gnu.linkonce.d.*" s))) + (* the script also has SORT(CONSTRUCTORS) here, but it has no effect for ELF (I think) *) + ]) + ; OutputSection(AlwaysOutput, None, ".data1", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".data1"))]) + ; DefineSymbol(AlwaysDefine, "_edata", default_symbol_spec) + ; DefineSymbol(ProvideIfUsed, "edata", default_symbol_spec) + ; (* . = .; <-- does this do anything? YES! It forces an output section to be emitted. + Since it occurs *outside* any output section, + it is assumed to start + *) + DefineSymbol(AlwaysDefine, "__bss_start", default_symbol_spec) + ; OutputSection(AlwaysOutput, None, ".bss", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".dynbss")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".bss" s || (name_matches ".bss.*" s || name_matches ".gnu.linkonce.b.*" s))) + ; InputQuery(DefaultKeep, DefaultSort, (fun inputlist -> + (*let _ = errln "Looking for commons" in *) + let result = (filter_and_concat is_common inputlist) + in + (*let _ = errln ("Got " ^ (show (length (result))) ^ " commons; sanity check: input list contains " ^ + (show (length inputlist)) ^ " of which " ^ + (show (length (List.filter (fun inp -> match inp with + Common _ -> true + | _ -> false + end) inputlist))) ^ " are commons." + ) + in*) result) + ) + ]) + ; AdvanceAddress(AddressExprFn alloc_fn3_ref) + ; OutputSection(AlwaysOutput, None, ".lbss", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".dynlbss")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".dynlbss")) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".lbss" s || (name_matches ".lbss.*" s || name_matches ".gnu.linkonce.lb.*" s) + )) + ; InputQuery(DefaultKeep, DefaultSort, filter_and_concat (is_large_common)) + ]) + ; AdvanceAddress(AddressExprFn alloc_fn4_ref) + ; AdvanceAddress(AddressExprFn alloc_fn5_ref) + ; OutputSection(AlwaysOutput, Some (AddressExprFn alloc_fn6_ref), + ".lrodata", + [InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".lrodata" s || (name_matches ".lrodata.*" s || name_matches ".gnu.linkonce.lr.*" s) + )) + ; AdvanceAddress(AddressExprFn alloc_fn7_ref) + ]) + ; AdvanceAddress(AddressExprFn alloc_fn8_ref) + ; DefineSymbol(AlwaysDefine, "_end", default_symbol_spec) + ; DefineSymbol(ProvideIfUsed, "end", default_symbol_spec) + ; MarkDataSegmentEnd + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".stab", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".stab"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".stabstr", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".stabstr"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".stab.excl", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".stab.excl"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".stab.exclstr", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".stab.exclstr"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".stab.index", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".stab.index"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".stab.indexstr", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".stab.indexstr"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".comment", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".comment"))]) + (* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section so we begin them at 0. *) + (* DWARF 1 *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".line", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".line"))]) + (* GNU DWARF 1 extensions *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_srcinfo", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_srcinfo"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_sfnames", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_sfname"))]) + (* DWARF 1.1 and DWARF 2 *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_aranges", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_aranges"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_pubnames", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_pubnames"))]) + (* DWARF 2 *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_info", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".debug_info" s || name_matches ".gnu.linkonce.wi.*" s))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_abbrev", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_abbrev"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_line", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat ( + fun s -> name_matches ".debug_line" s || (name_matches ".debug_line.*" s || name_matches ".debug_line_end" s)))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_frame", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_frame"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_str", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_str"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_loc", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_loc"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_macinfo", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_macinfo"))]) + (* SGI/MIPS DWARF 2 extensions *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_weaknames", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_weaknames"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_funcnames", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_funcnames"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_typenames", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_typenames"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_varnames", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_varnames"))]) + (* DWARF 3 *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_pubtypes", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_pubtypes"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_ranges", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_ranges"))]) + (* DWARF Extension. *) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".debug_macro", [InputQuery(DefaultKeep, DefaultSort, filter_and_concat (name_matches ".debug_macro"))]) + ; OutputSection(AlwaysOutput, Some address_zero_fn, ".gnu.attributes", [InputQuery(KeepEvenWhenGC, DefaultSort, filter_and_concat (name_matches ".gnu.attributes"))]) + ; DiscardInput(filter_and_concat (fun s -> name_matches ".note.GNU-stack" s || (name_matches ".gnu_debuglink" s || name_matches ".gnu.lto_*" s))) + (* NOTE: orphan sections are dealt with in the core linking logic, + not the script. *) + ])) + +let interpret_guard guard comp name1:bool= + ((match guard with + always0 -> true + | OnlyIfRo -> + let v = (List.for_all (fun comp_el -> (match comp_el with + IncludeInputSection(retainpol, (* fname, linkable_idx, shndx, isec, img *) irec) -> Nat_big_num.equal(Nat_big_num.of_int + (* is this section read-only? if it doesn't have shf_write, yes *)0) (Nat_big_num.bitwise_and irec.isec.elf64_section_flags shf_write) + | _ -> (* holes, common symbols and provided symbols shouldn't prevent ONLY_IF_RO *) true + )) comp) + in (*let _ = errln ("only_if_ro evaluated " ^ (show v) ^ " for output section " ^ name) + in*) v + | OnlyIfRw -> + let v = (List.for_all (fun comp_el -> (match comp_el with + IncludeInputSection(retainpol, (* fname, linkable_idx, shndx, isec, img *) irec) -> not (Nat_big_num.equal(Nat_big_num.of_int + (* is this section read-only? if it doesn't have shf_write, yes *)0) (Nat_big_num.bitwise_and irec.isec.elf64_section_flags shf_write)) + | _ -> (* holes etc. shouldn't prevent ONLY_IF_RW *) true + )) comp) + in (*let _ = errln ("only_if_rw evaluated " ^ (show v) ^ " for output section " ^ name) + in *)v + )) + +(* Passes over the script: + * + * 1. assign input sections to output sections (or discard) and define symbols. + * + * 2. compute def-use and optionally GC, removing unwanted sections and symbols + * + * 3. build image, assigning addresses as we go. + * + * Some passes require matching/retrieving what a previous pass on the same node did. + * So we give each script element a natural "idx" label. + *) +(*val label_script_aux : natural -> linker_control_script -> labelled_linker_control_script*) +let label_script_aux start script1:(script_element*Nat_big_num.num)list= + (mapi (fun i -> fun el -> (el, ( Nat_big_num.add start (Nat_big_num.of_int i)))) script1) + +(*val label_script : linker_control_script -> labelled_linker_control_script*) +let label_script script1:(script_element*Nat_big_num.num)list= (label_script_aux(Nat_big_num.of_int 0) script1) + +type input_output_assignment = ( input_spec list * (output_section_spec * Nat_big_num.num) list) + +(*val assign_inputs_to_output_sections : + input_output_assignment -> (* accumulator: list of discards, list of output compositions (these include symbols) *) + set (natural * natural) -> (* used sections *) + set (natural * natural * natural) -> (* used commons *) + list input_spec -> (* remaining inputs *) + maybe (output_section_spec * natural) -> (* cur_sec -- the current output section spec and its OutputSection script item idx *) + maybe input_spec -> (* last input section to be output -- might not have one *) + (input_spec -> input_spec -> Basic_classes.ordering) (* "seen ordering" *) -> + labelled_linker_control_script -> + input_output_assignment*) (* accumulated result *) +let rec assign_inputs_to_output_sections acc used_sections used_commons inputs (cur_output_sec : (output_section_spec * Nat_big_num.num)option) last_input_sec seen_ordering script1:(input_spec)list*(output_section_spec*Nat_big_num.num)list= + (let (rev_discards, rev_outputs) = acc in + let flush_output_sec + = (fun maybe_output_sec_and_idx -> (match (maybe_output_sec_and_idx : (output_section_spec * Nat_big_num.num)option) with + Some (OutputSectionSpec (guard, addr, name1, comp), script_idx) -> + (*let _ = errln ("Guardedly flushing output section named " ^ name ^ " with " ^ ( + match addr with Nothing -> "no address yet" | Just a -> "address 0x" ^ (hex_string_of_natural a) end + ) ^ " and composed of " ^ (show (length comp)) ^ " constituents.") + in*) + (* evaluate the guard *) + if interpret_guard guard comp name1 + then (* do it *) (rev_discards, (((OutputSectionSpec (guard, addr, name1, comp)), script_idx) :: rev_outputs)) + else (* ignore it *) acc + | None -> (* for convenience, make this a no-op rather than error *) + (* failwith "internal error: flushing output section with no current output section" *) + acc + )) + in + (match script1 with + [] -> flush_output_sec cur_output_sec + | (element1, idx1) :: more_elements_and_idx -> + let do_nothing = (acc, used_sections, used_commons, cur_output_sec, last_input_sec) + in + let (new_acc, new_used_sections, new_used_commons, (new_cur_output_sec : (output_section_spec * Nat_big_num.num)option), new_last_input_sec) + = ((match element1 with + DefineSymbol(symdefpol, name1, (symsize, syminfo, symother)) -> + (* Label the current section in the image + * with a new symbol definition. If there isn't + * a current section, use the ABS section (what is that labelling?). *) + (acc, + used_sections, + used_commons, + (match (cur_output_sec : (output_section_spec * Nat_big_num.num)option) with + None -> (*let _ = errln ("FIXME: for defining `" ^ name ^ "': ABS symbol defs not yet supported") in*) None + | Some ((OutputSectionSpec (guard, maybe_addr, secname1, comp)), output_script_idx) -> + (*let _ = errln ("Including a symbol named `" ^ name ^ " in composition of output section `" ^ secname ^ "'") in*) + Some ((OutputSectionSpec (guard, maybe_addr, secname1, + List.rev_append (List.rev comp) [ProvideSymbol(symdefpol, name1, (symsize, syminfo, symother))])) + , output_script_idx) + ), + last_input_sec) + | AdvanceAddress(AddressExprFn advance_fn) -> + (* If we're inside a section, insert a hole, + * else just update the logical address *) + (*let _ = errln ("Advancing location counter") in*) + (match cur_output_sec with + None -> do_nothing + (* This assignment is setting a new LMA. *) + (* (acc, *) + | Some (sec, idx1) -> do_nothing + ) + | MarkAndAlignDataSegment(maxpagesize1, commonpagesize1) -> + (* The "data segment end" is a distinguished label, + * so we can encode the whole thing into a conditional. *) + (*let _ = errln ("Mark/aligning data segment") in*) + do_nothing + | MarkDataSegmentEnd -> + (*let _ = errln ("Marking data segment end") in*) + do_nothing + | MarkDataSegmentRelroEnd(*(fun_from_secs_to_something)*) -> + (*let _ = errln ("Marking data segment relro end") in*) + do_nothing + | OutputSection(outputguard, maybe_expr, name1, sub_elements) -> + (* If we have a current output section, finish it and add it to the image. + * Q. Where do guards ("ONLY_IF_RO" etc) get evaluated? + * A. Inside flush_output_sec. *) + (*let _ = errln ("Recursively composing a new output section `" ^ name ^ "'...") in*) + let acc_with_output_sec = (flush_output_sec cur_output_sec) + in + let new_cur_output_sec = (Some((OutputSectionSpec(outputguard, (* maybe_expr pos secs *) None, name1, [])), idx1)) + in + (* Recurse down the list of input queries, assigning them to this output sec + * Note that output sections may not nest within other output sections. + * At the end of the list of sub_elements, we will flush the section we built up. + *) + let final_acc + = (assign_inputs_to_output_sections acc used_sections used_commons inputs new_cur_output_sec last_input_sec seen_ordering (label_script sub_elements)) + in + (* NOTE that this sub-accumulation will never add a new output section + * because output sections can't nest. *) + (final_acc, used_sections, used_commons, (* cur_output_sec *) None, last_input_sec) + | DiscardInput(selector) -> + let selected = (selector inputs) + in + let (rev_discards, rev_outputs) = acc in + (*let _ = Missing_pervasives.errln ("Processing discard rule; selected " ^ (show (length selected)) + ^ " inputs.") + in*) + (( List.rev_append (List.rev (List.rev (let x2 = + ([]) in List.fold_right (fun i x2 -> if true then i :: x2 else x2) selected x2))) rev_discards, rev_outputs), used_sections, used_commons, cur_output_sec, last_input_sec) + | InputQuery(retainpol, sortpol, selector) -> + (* Input queries can only occur within an output section. *) + (match cur_output_sec with + None -> failwith "linker script error: input query without output section" + | Some ((OutputSectionSpec (output_guard1, output_sec_addr, output_sec_name, output_composition)), output_script_idx) -> + (* Add them to the current output spec. We have to be careful about ordering: + * according to the GNU ld manual (and observed behaviour), by default + * "the linker will place files and sections matched by wildcards in the order + * in which they are seen during the link". For .o files on the command line, + * this means the command line order. But for members of archives, it means + * the order in which they were "pulled in" during input enumeration. We + * actually don't compute this here; it is passed in from our caller in link.lem. *) + let sortfun = ((match sortpol with + DefaultSort -> List.sort seen_ordering (* FIXME: pay attention to command line *) + | SeenOrder -> List.sort seen_ordering + | ByName -> List.sort compareInputSpecByName + | ByNameThenAlignment -> List.sort compareInputSpecByNameThenAlignment + | ByAlignment -> List.sort compareInputSpecByAlignment + | ByAlignmentThenName -> List.sort compareInputSpecByAlignmentThenName + | ByInitPriority -> List.sort compareInputSpecByInitPriority + )) + in + let selected = (selector inputs) + in + let selected_deduplicated = (List.filter (fun inp -> (match inp with + InputSection(irec) -> not ( Pset.mem(irec.idx, irec.shndx) used_sections) + | Common(idx1, fname1, img2, def) -> not ( Pset.mem(idx1, def.def_sym_scn, def.def_sym_idx) used_commons) + )) selected) + in + (*let _ = errln ("Evaluated an input query, yielding " ^ + (show (length selected)) ^ " undeduplicated and " ^ + (show (length selected_deduplicated)) ^ + " deduplicated results, to be added to composition currently of " ^ + (show (length output_composition)) ^ " items.") in*) + (* Search input memory images for matching sections. *) + let sorted_selected_inputs = (sortfun selected_deduplicated) + in + let (sectionMatchList : input_section_rec list) = (Lem_list.mapMaybe (fun inp -> + (match inp with + InputSection(x) -> + (*let _ = errln ("Matched an input section named " ^ x.isec.elf64_section_name_as_string ^ + " in a file " ^ x.fname ^ " with first 20 bytes " ^ (show (take 20 + (let maybe_elname = elf_memory_image_element_coextensive_with_section x.shndx x.img + in + match maybe_elname with + Nothing -> failwith ("impossible: no such element (matching shndx " ^ (show x.shndx) ^ ")") + | Just idstr -> + match Map.lookup idstr x.img.elements with + Just el -> el.contents + | Nothing -> failwith "no such element" + end + end + )))) + in*) + Some x + | _ -> None + )) sorted_selected_inputs) + in + let commonMatchList = (Lem_list.mapMaybe (fun inp -> + (match inp with + | Common(idx1, fname1, img2, def) -> Some(idx1, fname1, img2, def) + | _ -> None + )) sorted_selected_inputs) + in + + (acc, + Pset.(union) used_sections (let x2 =(Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) + []) in List.fold_right + (fun irec x2 -> if true then Pset.add (irec.idx, irec.shndx) x2 else x2) + sectionMatchList x2), + Pset.(union) used_commons (let x2 =(Pset.from_list (tripleCompare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare) + []) in List.fold_right + (fun(idx1, fname1, img2, def) x2 -> + if true then Pset.add (idx1, def.def_sym_scn, def.def_sym_idx) x2 else x2) + commonMatchList x2), + (* new_cur_output_spec *) Some ( + (OutputSectionSpec(output_guard1, output_sec_addr, output_sec_name, + List.rev_append (List.rev (List.rev_append (List.rev output_composition) (let x2 = + ([]) in List.fold_right + (fun input_sec x2 -> + if true then + IncludeInputSection + (retainpol, (* input_sec.fname, input_sec.idx, input_sec.shndx, input_sec.isec, input_sec.img *) input_sec) + :: x2 else x2) sectionMatchList x2))) (let x2 = ([]) in List.fold_right + (fun(idx1, fname1, img2, def) x2 -> + if true then + IncludeCommonSymbol (DefaultKeep, fname1, idx1, def, img2) :: x2 else + x2) commonMatchList x2) + )), output_script_idx), + last_input_sec + ) + ) + )) + in + (*let _ = match new_cur_output_sec with + Just (OutputSectionSpec (guard, addr, name, comp), script_idx) -> + errln ("Now output section `" ^ name ^ "' is composed of " ^ (show (length comp)) ^ " elements.") + | Nothing -> () + end in*) + assign_inputs_to_output_sections new_acc new_used_sections new_used_commons + (inputs : input_spec list) + (new_cur_output_sec) + (new_last_input_sec : input_spec option) + seen_ordering + (more_elements_and_idx : labelled_linker_control_script) + )) + +(* NOTE: this is also responsible for deleting any PROVIDEd symbols that + * were not actually referenced. BUT HOW, if we haven't built the image and + * hence haven't added the symbols yet? Symbols affect reachability, so + * we're going to have to figure this out. Really we want a memory image that + * does not yet have addresses assigned, but does have the symbols inserted. + * BUT even that is not right, because we want to be able to remove some + * sections (GC them). So the section composition is not yet fixed. So we have + * a problem. + * + * Note that the only symbols we have to remove are ones that were PROVIDEd + * in our output composition. So doing the GC on output compositions seems + * sane. We can get the graph's edge list by inspecting the constituent memory + * images from which each output section composition element is drawn. + * Collecting sections and collecting symbols seems fair. Note that symbols + * can never be placed mid-section (I don't think?? they can use arbitrary + * expressions, but not that depend on whether an input section is included + * or not) so removing a section should never imply the removal of a symbol. + * + * So that implies we need not yet build a memory image. + *) +(*val compute_def_use_and_gc : allocated_sections_map -> allocated_sections_map*) +let compute_def_use_and_gc outputs_by_name:allocated_sections_map= outputs_by_name (* FIXME: implement GC *) + +let output_section_type comp:Nat_big_num.num= +( + (* are we composed entirely of nobits sections and common symbols? *)let all_nobits = (List.for_all (fun comp_el -> + (match comp_el with + IncludeInputSection(retain_pol,(* fname, linkable_idx, shndx, isec, img *) irec) -> Nat_big_num.equal + irec.isec.elf64_section_type sht_nobits + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> true + | _ -> (* padding and symdefs can be nobits *) true + )) comp) + in + if all_nobits then sht_nobits else sht_progbits) + +let output_section_flags comp:Nat_big_num.num= + (let writable = (List.exists (fun comp_el -> + (match comp_el with + IncludeInputSection(retain_pol, (* fname, linkable_idx, shndx, isec, img *) irec) -> + flag_is_set shf_write irec.isec.elf64_section_flags + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> + (* assume common symbols are writable *) true + | _ -> (* padding and symdefs do not make a section writable *) false + )) comp) + in + let executable = (List.exists (fun comp_el -> + (match comp_el with + IncludeInputSection(retain_pol,(* fname, linkable_idx, shndx, isec, img *) irec) -> + flag_is_set shf_execinstr irec.isec.elf64_section_flags + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> + (* assume common symbols are not executable, since they're zeroed *) false + | _ -> (* padding and symdefs do not make a section executable -- HMM *) false + )) comp) + in + let alloc = (List.exists (fun comp_el -> + (match comp_el with + IncludeInputSection(retain_pol, (* fname, linkable_idx, shndx, isec, img *) irec) -> + flag_is_set shf_alloc irec.isec.elf64_section_flags + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> + (* common symbols are allocatable *) true + | ProvideSymbol(pol, name1, spec) -> + (* symbols make a section allocatable? HMM *) true + | _ -> (* padding does not make a section allocatable *) false + )) comp) + in + let is_thread_local_yesnomaybe = (fun comp_el -> + (match comp_el with + IncludeInputSection(retain_pol, (* fname, linkable_idx, shndx, isec, img *) irec) -> + Some(flag_is_set shf_tls irec.isec.elf64_section_flags) + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> + (* FIXME: support tcommon *) Some(false) + | ProvideSymbol(pol, name1, spec) -> + (* linker script symbols shouldn't be defined here, unless they can be declared thread-local (FIXME: can they?) *) + Some false + | _ -> (* padding does not make a section thread-local, or non-. *) None + ) + ) + in + let thread_local = ( + (* Is any element positively thread-local? *) + let v = (List.fold_left (fun acc_ynm -> fun comp_el -> + let new_ynm = (is_thread_local_yesnomaybe comp_el) + in + (match (acc_ynm, new_ynm) with + (None, None) -> None + | (None, Some x) -> Some x + | (Some x, None) -> Some x + | (Some true, Some false) -> Some true + | (Some true, Some true) -> Some true + | (Some false, Some false) -> Some false + | (Some true, Some false) -> Some true + )) None comp) + in + if (Lem.option_equal (=) v (Some(true))) && not ( (Lem.option_equal (=)(Some(true)) (* are *all* either don't-care or positively thread-local? *) + (List.fold_left (fun acc_ynm -> fun comp_el -> + let new_ynm = (is_thread_local_yesnomaybe comp_el) + in + (match (acc_ynm, new_ynm) with + (None, None) -> None + | (None, Some x) -> Some x + | (Some x, None) -> Some x + | (Some true, Some false) -> Some false + | (Some true, Some true) -> Some true + | (Some false, Some false) -> Some false + | (Some true, Some false) -> Some false + )) None comp))) then failwith "error: section mixes thread-local and non-thread-local inputs" + else (match v with + None -> false + | Some x -> x + ) + ) + in + Nat_big_num.bitwise_or + (if thread_local then shf_tls else Nat_big_num.of_int 0) + (Nat_big_num.bitwise_or + (if executable then shf_execinstr else Nat_big_num.of_int 0) + (Nat_big_num.bitwise_or + (if writable then shf_write else Nat_big_num.of_int 0) + (if alloc then shf_alloc else Nat_big_num.of_int 0) + ) + )) + +let symbol_def_for_provide_symbol name1 size2 info other control_script_linkable_idx:symbol_definition= + ({ + def_symname = (*let _ = errln ("Linker script is defining symbol called `" ^ name ^ "'") in*) name1 + ; def_syment = ({ + elf64_st_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* ignored *) + ; elf64_st_info = info + ; elf64_st_other = other + ; elf64_st_shndx = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_value = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* ignored *) + ; elf64_st_size = (Uint64.of_string (Nat_big_num.to_string size2)) + }) + ; def_sym_scn =(Nat_big_num.of_int 0) + ; def_sym_idx =(Nat_big_num.of_int 0) + ; def_linkable_idx = control_script_linkable_idx + }) + +(*val assign_dot_to_itself : natural -> address_expr_fn_map allocated_sections_map -> (natural * address_expr_fn_map allocated_sections_map * address_expr_fn)*) +let assign_dot_to_itself fresh alloc_map:Nat_big_num.num*((Nat_big_num.num),(Nat_big_num.num ->allocated_sections_map ->Nat_big_num.num))Pmap.map*address_expr_fn= + (let fn = (fun dot -> fun _ -> dot) in + let alloc_map' = (Pmap.add fresh fn alloc_map) in + let fresh' = (Nat_big_num.add(Nat_big_num.of_int 1) fresh) in + (fresh', alloc_map', AddressExprFn fresh)) + +(*val build_image : + address_expr_fn_map allocated_sections_map -> (* global dictionary of address_expr_fn_ref -> address_expr_fn *) + elf_memory_image -> (* accumulator *) + natural -> (* location counter *) + allocated_sections_map -> (* outputs constructed earlier *) + (Map.map string (list (natural * binding))) -> (* bindings_by_name *) + labelled_linker_control_script -> + natural -> (* control_script_linkable_idx *) + (Map.map string (list symbol_definition)) -> (* linker_defs_by_name *) + (elf_memory_image * allocated_sections_map)*) (* accumulated result *) +let rec build_image alloc_map acc pos (AllocatedSectionsMap outputs_by_name) bindings_by_name script1 control_script_linkable_idx linker_defs_by_name:(any_abi_feature)annotated_memory_image*allocated_sections_map= + (let (add_output_section : (Nat_big_num.num * elf_memory_image) -> output_section_spec -> (Nat_big_num.num * elf_memory_image * Nat_big_num.num * output_section_spec)) + = (fun ((*scn_idx, *)pos, acc_img) -> + (fun (OutputSectionSpec (guard, addr, secname1, comp)) -> + (*let _ = errln ("Computing composition of output section `" ^ secname ^ "' from " ^ (show (length comp)) ^ " elements") + in*) + let unaligned_start_addr = ((match addr with + Some a -> failwith ("internal error: section " ^ (secname1 ^ ": did not expect address to be assigned yet")) + | None -> pos + )) + in + let align = (alignof_output_section comp) + in + (*let _ = errln ("Aligning start of output section " ^ secname ^ " up to a " ^ (show align) ^ "-byte address boundary") + in*) + let output_section_start_addr = (align_up_to align unaligned_start_addr) + in + let (end_addr, comp_addrs) = (do_output_section_layout_starting_at_addr output_section_start_addr (AllocatedSectionsMap outputs_by_name) comp) + in + let size2 = (Nat_big_num.sub_nat end_addr output_section_start_addr) + in + (*let _ = Missing_pervasives.outln ( + if List.null comp then secname else ( + ((space_padded_and_maybe_newline 16 secname) ^ + ("0x" ^ (left_zero_padded_to 16 (hex_string_of_natural output_section_start_addr))) ^ " " ^ + (left_space_padded_to 10 ("0x" ^ (hex_string_of_natural size)))) + ) + ) + in*) + let (concatenated_content, final_addr, new_range_tag_pairs) = (List.fold_left (fun (accum_pat, accum_current_addr, accum_meta) -> (fun (comp_el, comp_addr) -> + (*let _ = errln ("Adding an element to composition of output section `" ^ secname ^ "', current address 0x" ^ (hex_string_of_natural accum_current_addr)) + in*) + let make_line = (fun namestr -> (fun addrstr -> (fun szstr -> (fun rhs -> ( + (space_padded_and_maybe_newline(Nat_big_num.of_int 16) (" " ^ namestr)) ^ + (("0x" ^ (left_zero_padded_to(Nat_big_num.of_int 16) addrstr)) ^ (" " ^ + ((left_space_padded_to(Nat_big_num.of_int 10) ("0x" ^ szstr)) ^ (" " ^ rhs)))) + ))))) + in + let (sz, comp_el_pat, this_el_meta) = ((match comp_el with + | IncludeInputSection(retainpolicy, (* fname, linkable_idx, shndx, isec, img *) irec) -> + (* We want to get the input section as a byte pattern *) + (*let _ = errln ("Processing inclusion of input section `" ^ irec.isec.elf64_section_name_as_string + ^ "' from file `" ^ irec.fname + ^ "' into output section `" ^ secname + ^ "'") + in*) + let maybe_secname = (elf_memory_image_element_coextensive_with_section irec.shndx irec.img) + in + (match maybe_secname with + None -> failwith ("impossible: no such section" (*(matching irec.shndx " ^ (show irec.shndx) ^ ")""*)) + | Some idstr -> + (*let _ = errln ("Found element named " ^ idstr ^ " coextensive with section named " ^ + irec.isec.elf64_section_name_as_string ^ " in file " ^ irec.fname) + in*) + (match Pmap.lookup idstr irec.img.elements with + Some el -> + (*let _ = Missing_pervasives.outln (make_line irec.isec.elf64_section_name_as_string + (hex_string_of_natural comp_addr) (hex_string_of_natural irec.isec.elf64_section_size) + irec.fname) + in*) + let section_el_name = (get_unique_name_for_section_from_index irec.shndx irec.isec irec.img) + in + (*let _ = errln ("Copying metadata for output section `" ^ section_el_name ^ "'") in*) + let range_or_sym_is_in_this_sec = (fun maybe_range -> (fun tag -> + (* is it within the section we're outputting? + * first we needs its element name. *) + (* filter out ones that don't overlap *) + (match maybe_range with + Some(el_name, (start, len)) -> + (* img and shndx came as a unit, so they're definitely + * talking about the same file *) + (* shndx = sym_shndx *) + section_el_name = el_name + | None -> + (* ABS symbols have this property *) + (match tag with + SymbolDef(def) -> + (* don't match section symbols, or we'll be inundated *) + let sym_shndx = (Nat_big_num.of_string (Uint32.to_string def.def_syment.elf64_st_shndx)) + in + if not (Nat_big_num.equal sym_shndx shn_abs) || ( not (Nat_big_num.equal (get_elf64_symbol_type def.def_syment) stt_section)) then false + else ( + let abs_address = (Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_value) + in + (* check it against our section *) + let section_end_addr = (Nat_big_num.add accum_current_addr irec.isec.elf64_section_size) + in + ( Nat_big_num.greater_equal abs_address accum_current_addr + && Nat_big_num.less abs_address section_end_addr) + (* FIXME: argument that this should be <=, i.e. can mark end addr *) + (* PROBLEM: this is all very well, but there's no reason why + * ABS symbols need to point at an address within some output + * section. They can just be arbitrary values. This is a bit of an + * abuse if we do it within the C language (to get the value, you + * have to do "(int) &sym", i.e. create a meaningless pointer + * intermediate) but arguably is okay in an impl-def way. + * + * WHAT to do? well, just always output the ABS symbols, for now. + * + * The example that provoked this is in glibc's + * locale/lc-address.c, which compiles down to create + * the following ABS symbol: + * + * 0000000000000001 g *ABS* 0000000000000000 _nl_current_LC_ADDRESS_used + * + * ... i.e. the _nl_current_LC_ADDRESS_used appears to be just a flag. + * + * Where can we handle this? We don't see ABS symbols since they + * aren't associated with sections. We simply need to copy over + * all the ABS symbols appearing in included input objects. + * That means there's no point doing anything with them here + * while we're fiddling with sections. Do it later in a whole- + * -image pass. + *) + && false (* ... at least until we see a better way *) + ) + | _ -> false + ) + ) + )) + in + let ranges_and_tags = (let x2 = + ([]) in List.fold_right + (fun(maybe_range, tag) x2 -> + if range_or_sym_is_in_this_sec maybe_range tag then + (maybe_range, tag) :: x2 else x2) (Pset.elements irec.img.by_range) + x2) + in + let included_defs = (let x2 = + ([]) in List.fold_right + (fun(maybe_range, def) x2 -> + if range_or_sym_is_in_this_sec maybe_range (SymbolDef (def)) then + def :: x2 else x2) + (elf_memory_image_defined_symbols_and_ranges irec.img) x2) + in + let included_global_defs = (let x2 = + ([]) in List.fold_right + (fun def x2 -> + if not + (Nat_big_num.equal + ( + (* filter out locals *) get_elf64_symbol_binding def.def_syment) + stb_local) then def :: x2 else x2) included_defs x2) + in + (* What symbol defs are being included? *) + (* For each global symbol defined in the section, output a line. *) + (*let _ = Missing_pervasives.outs (List.foldl (^) "" ( + List.map (fun def -> (make_line "" + (hex_string_of_natural (comp_addr + (natural_of_elf64_addr def.def_syment.elf64_st_value))) + (hex_string_of_natural (natural_of_elf64_xword def.def_syment.elf64_st_size)) + (" " ^ def.def_symname)) ^ "\n" + ) included_global_defs + )) + in*) + let (new_ranges_and_tags : (( element_range option) * ( any_abi_feature range_tag)) Pset.set) + = (Lem_set.setMapMaybe + (instance_Basic_classes_SetType_tup2_dict + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) + instance_Basic_classes_SetType_var_dict) (instance_Basic_classes_SetType_tup2_dict + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) + instance_Basic_classes_SetType_var_dict) (fun (maybe_range, tag) -> + (* How do we update existing metadata? In general, + * we get a new range. *) + let new_range = ((match maybe_range with + None -> None + | Some(el_name, (start, len)) -> + Some(secname1, +( (* FIXME: pass this through a section-to-element gensym. + We can just (for now) define output element names + to equal the section names, since we have no unnamed + output sections and no output common symbols. *)let new_start_off = (Nat_big_num.add start ( Nat_big_num.sub_nat comp_addr output_section_start_addr)) + in + (*let _ = errln ("Calculated element offset 0x" ^ (hex_string_of_natural new_start_off) ^ + " in element " ^ secname ^ " for tag at address 0x" ^ (hex_string_of_natural accum_current_addr) ^ + " , start offset 0x" ^ (hex_string_of_natural start) ^ ", output section start addr 0x" ^ + (hex_string_of_natural output_section_start_addr) ^ ", comp_addr 0x" ^ (hex_string_of_natural comp_addr)) + in*) + (new_start_off, + len))) + )) + in + (match tag with + (* If it's a section, we discard it. + * We will add a new section record at the end. (FIXME) *) + | FileFeature(ElfSection(idx1, isec1)) -> None + (* If it's a symbol def, we propagate it. + * We record its linkable idx, so we can + * match it later with the bindings we formed + * earlier. + * FIXME: this is a bit nasty. Perhaps we + * should replace syment with a minimal structure + * that avoids duplication. Same for isecs. *) + | SymbolDef(def) -> + (* if get_elf64_symbol_type def.def_syment = stt_section + then Nothing FIXME: also re-create the section symbol when we create the ElfSection + else *) (* This doesn't work -- some refs might be bound to this symbol. + Instead, strip the symbol when we generate the output symtab (FIXME). *) + (*let _ = errln ("Copying symbol named `" ^ def.def_symname ^ "'") + in*) + Some(new_range, SymbolDef({ + def_symname = (def.def_symname) + ; def_syment = (def.def_syment) + ; def_sym_scn = (def.def_sym_scn) + ; def_sym_idx = (def.def_sym_idx) + ; def_linkable_idx = (irec.idx) + })) + | AbiFeature(x) -> Some(new_range, AbiFeature(x)) + (* If it's a symbol ref with no reloc site, we discard it? *) + | SymbolRef(r) -> + (*let _ = if r.ref.ref_symname = "_start" then errln ("Saw ref to _start, " + ^ "in section " ^ irec.isec.elf64_section_name_as_string ^ " of linkable " ^ (show irec.idx)) + else () + in*) + let get_binding_for_ref = (fun symref -> (fun linkable_idx -> (fun fname1 -> + let name_matches1 = ((match Pmap.lookup symref.ref_symname bindings_by_name with Some x -> x | None -> [] )) + in + (match List.filter (fun (bi, ((r_idx, r, r_item), m_d)) -> Nat_big_num.equal r_idx linkable_idx && (r = symref)) name_matches1 with + [(b_idx, b)] -> (b_idx, b) + | [] -> failwith "no binding found" + | _ -> failwith ("ambiguous binding found for symbol `" ^ (symref.ref_symname ^ ("' in file " ^ fname1))) + ) + ))) + in + let (bi, b) = (get_binding_for_ref r.ref irec.idx irec.fname) + in + let ((ref_idx, ref1, ref_linkable), maybe_def) = b + in + (match r.maybe_reloc with + None -> None + (* If it's a reloc site, we need to somehow point it + * at the *definition* that it was bound to. YES. + * reloc_sites are + + type reloc_site = <| + ref_relent : elf64_relocation_a + ; ref_rel_scn : natural --the relocation section idx + ; ref_rel_idx : natural --the index of the relocation rec + ; ref_src_scn : natural --the section *from which* the reference logically comes + |> + + type elfNN_relocation_a = + <| elfNN_ra_offset : elf32_addr --Address at which to relocate + ; elfNN_ra_info : elf32_word --Symbol table index/type of relocation to apply + ; elfNN_ra_addend : elf32_sword --Addend used to compute value to be stored + |> + + * ... of which ref_src_scn, ref_rel_idx, + * ref_rel_scn and elfNN_ra_offset can be ignored. + * + * What *is* important is that we somehow point at + * the symbol definition (or perhaps *un*definition, + * if we're generating a shared library) that it + * refers to. + * + * For that, we update ra_info use the 1 + binding_idx, + * i.e. consider that there is a fresh symbol table + * and that it has a distinct entry for each binding. + * + * FIXME: we also need to account for + * reloc decisions -- MakePIC etc. + *) + | Some(rs) -> Some(new_range, SymbolRef( + { ref = ({ + (* This is not the place to be fixing up + * symbol references. We can't yet patch the element content, + * because we haven't yet decided on the address of everything. + * + * That said, we *do* need to represent the old ref in the new + * linked-image context. That's *all* we should be doing, right now. + * + *) + ref_symname = (ref1.ref_symname) + ; ref_syment = + ({ elf64_st_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* unused *) + ; elf64_st_info = (ref1.ref_syment.elf64_st_info) + ; elf64_st_other = (ref1.ref_syment.elf64_st_other) + ; elf64_st_shndx = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int (* shn_abs *)0))) + ; elf64_st_value = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_size = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + ; ref_sym_scn =(Nat_big_num.of_int 0) + ; ref_sym_idx =(Nat_big_num.of_int 0) + (* match maybe_def with Just _ -> 1+bi | Nothing -> 0 end *) + }) + ; maybe_reloc = (Some { + ref_relent = ({ + elf64_ra_offset = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) (* ignored *) + ; elf64_ra_info = (Uint64.logor + (* HACK: use bi as the symbol index. *) + (Uint64.of_string (Nat_big_num.to_string (get_elf64_relocation_a_type rs.ref_relent))) + (Uint64.shift_left + (* ... actually, don't, now we have maybe_def_bound_to *) + (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int (* (1+bi) *)0)))( 32) + ) + ) + ; elf64_ra_addend = (rs.ref_relent.elf64_ra_addend) + }) + ; ref_rel_scn =(Nat_big_num.of_int 0) + ; ref_rel_idx =(Nat_big_num.of_int 0) + ; ref_src_scn =(Nat_big_num.of_int 0) + }) + ; maybe_def_bound_to = +( + (* Re-search the bindings list for a match, because we might have + * re-bound this symbol since we created the image. FIXME: since + * we do this, is there anything gained from populating this field + * earlier? Probably best not to. *)let (possible_bindings : (Nat_big_num.num * binding) list) + = ((match Pmap.lookup ref1.ref_symname bindings_by_name with + Some l -> if ref1.ref_symname = "__fini_array_end" then + (*let _ = errln ("Found " ^ (show (length l)) ^ " bindings for __fini_array_end, of which " ^ + (show (length (List.filter (fun (bi, (r, maybe_d)) -> maybe_d <> Nothing) l))) ^ + " are with definition") + in*) l + else l + | None -> [] + )) + in + (* what's the actual binding? *) + (match r.maybe_def_bound_to with + None -> failwith ("at this stage, all references must have a decision: `" ^ (ref1.ref_symname ^ "'")) + | Some(decision, _) -> + (* Search the list of bindings for a possibly-updated + * binding for this reference. *) + let matching_possibles = (List.filter (fun (bi, ((ref_idx, ref1, ref_item), maybe_d)) -> + (match maybe_d with + None -> false + | Some (def_idx, def, def_item) -> Nat_big_num.equal + (* match the *reference*, whose linkable we're processing now *) + irec.idx ref_idx + && (Nat_big_num.equal r.ref.ref_sym_scn ref1.ref_sym_scn + && Nat_big_num.equal r.ref.ref_sym_idx ref1.ref_sym_idx) + + (* + def.def_syment = sd.def_syment + && def.def_sym_scn = sd.def_sym_scn + && def.def_sym_idx = sd.def_sym_idx + && def_idx = sd.def_linkable_idx *) + ) + ) possible_bindings) + in + (*let _ = errln ("For a ref to `" ^ ref.ref_symname ^ + "', possibles list is: " ^ ( + List.foldl (fun x -> fun y -> x ^ ", " ^ y) "" (List.map (fun (bi, ((_, _, _), maybe_d)) -> + match maybe_d with + Just(def_idx, def, def_item) -> + "`" ^ def.def_symname ^ "' " ^ + "in linkable " ^ (show def_idx) ^ + ", section " ^ (show def.def_sym_scn) ^ + ", sym idx " ^ (show def.def_sym_idx) + | _ -> failwith "impossible: just filtered out no-def bindings" + end + ) matching_possibles) + )) + in*) + let new_bound_to = ((match matching_possibles with + [] -> Some(ApplyReloc, None) + | [(bi, ((rl, r, ri), maybe_d))] -> + Some(decision, + (match maybe_d with + Some (def_idx, def, def_item) -> Some { + def_symname = (def.def_symname) + ; def_syment = (def.def_syment) + ; def_sym_scn = (def.def_sym_scn) + ; def_sym_idx = (def.def_sym_idx) + ; def_linkable_idx = def_idx + } + | None -> None + )) + | _ -> failwith ("After linker script, ambiguous bindings for `" ^ (ref1.ref_symname ^ "'")) + )) + in + if not ((Lem.option_equal (Lem.pair_equal (=) (Lem.option_equal (=))) new_bound_to r.maybe_def_bound_to)) then + (*let _ = errln ("Changed binding for reference to `" ^ ref.ref_symname ^ + "' in linkable " ^ (show irec.idx)) + in*) + new_bound_to + else if (Lem.option_equal (Lem.pair_equal (=) (Lem.option_equal (=))) new_bound_to None) then failwith "really need a decision by now" + else new_bound_to + )) + + (* if irec.fname = "libc.a(__uClibc_main.os)" + && irec.isec.elf64_section_name_as_string = ".data.rel.local" + then + let _ = errln ("Saw the bugger: " ^ (match r.maybe_def_bound_to with + Just(decision, Just(sd)) -> show sd.def_syment + | _ -> "(not complete)" + end)) + in r.maybe_def_bound_to + else r.maybe_def_bound_to + *) + } + )) + ) (* match maybe_reloc *) + ) (* match tag *) + ) ((Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) ranges_and_tags))) (* end mapMaybe fn *) + in + let isec_sz = (irec.isec.elf64_section_size) in + let maybe_el_sz = (el.length1) in + let contents_sz = (length el.contents) in + let (actual_sz, padded_contents) = + ((match maybe_el_sz with + Some el_sz -> + let diff = (Nat_big_num.sub_nat el_sz contents_sz) in + if Nat_big_num.less diff(Nat_big_num.of_int 0) then + (* contents greater than what the el says, so chop the end off *) + (*let _ = Missing_pervasives.errln ("Warning: size mismatch for section " ^ irec.isec.elf64_section_name_as_string ^ + " from " ^ irec.fname) + in*) + (el_sz, take0 el_sz el.contents) + else (el_sz, List.rev_append (List.rev el.contents) (replicate0 diff None)) + | None -> + if not (Nat_big_num.equal (length el.contents) isec_sz) + then failwith "input section size not equal to its content pattern length" + else (isec_sz, el.contents) + )) + in + (*let _ = errln ("Saw first 20 bytes of section " ^ irec.isec.elf64_section_name_as_string ^ + " from " ^ irec.fname ^ " as " ^ (show (take 20 padded_contents))) + in*) + (actual_sz, padded_contents, new_ranges_and_tags) + | _ -> failwith "impossible: no such element" + ) (* match Map.lookup idstr img.elements *) + ) (* match maybe_secname *) + | IncludeCommonSymbol(retain_pol, fname1, linkable_idx, def, img2) -> + (*let _ = errln ("Including common symbol called `" ^ def.def_symname ^ "'") + in*) + (* We want to get the common symbol as a byte pattern *) + let sz = (Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_size) + in + let content = (Missing_pervasives.replicate0 sz (Some(Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 0))))) + in + (*let _ = Missing_pervasives.outln (make_line "COMMON" (hex_string_of_natural comp_addr) + (hex_string_of_natural sz) fname) + in*) + (sz, content,(Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) [(Some(secname1, ( Nat_big_num.sub_nat comp_addr output_section_start_addr, sz)), SymbolDef({ + def_symname = (def.def_symname) + ; def_syment = (def.def_syment) + ; def_sym_scn = (def.def_sym_scn) + ; def_sym_idx = (def.def_sym_idx) + ; def_linkable_idx = linkable_idx + }))])) +(* | Hole(AddressExprFn f) -> + let next_addr = f addr (AllocatedSectionsMap outputs_by_name) + in + let n = next_addr - addr + in + let content = Missing_pervasives.replicate n Nothing + in + let _ = Missing_pervasives.outln (make_line "*fill*" (hex_string_of_natural comp_addr) + (hex_string_of_natural n) + "") + in + (next_addr - addr, content, {}) *) + | ProvideSymbol(pol, name1, (size2, info, other)) -> + (*let _ = errln ("Creating symbol definition named `" ^ name ^ "' in output section `" ^ secname ^ "'") + in*) + let symaddr = accum_current_addr (* FIXME: support others *) + in + (*let _ = Missing_pervasives.outln (make_line "" (hex_string_of_natural symaddr) "" ("PROVIDE (" ^ name ^ ", .)")) + in*) + (Nat_big_num.of_int (* sz *)0, (* comp_el_pat *) [],(Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) [( + Some(secname1, (( Nat_big_num.sub_nat symaddr output_section_start_addr),Nat_big_num.of_int 0)), + SymbolDef(symbol_def_for_provide_symbol name1 size2 info other control_script_linkable_idx) + )]) + ) + )) (* match comp_el_pat *) + in + (*let _ = errln ("Appending byte pattern to section " ^ secname ^ ", first 20 bytes: " ^ + (show (take 20 comp_el_pat))) + in*) + let new_content = (append_to_byte_pattern_at_offset ( Nat_big_num.sub_nat comp_addr output_section_start_addr) accum_pat comp_el_pat) + in + let new_addr = (Nat_big_num.add comp_addr sz) + in + let new_meta = (Pset.(union) accum_meta this_el_meta) + in + (new_content, new_addr, new_meta) + )) ([], output_section_start_addr,(Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) [])) (list_combine comp comp_addrs)) + in + let concat_sec_el = ({ + Memory_image.startpos = (Some(output_section_start_addr)) + ; Memory_image.length1 = (Some(size2)) + ; Memory_image.contents = concatenated_content + }) + in + (*let _ = Missing_pervasives.outln "" in*) + (* Make a new element in the image, also transferring metadata from input elements + * as appropriate. *) + let new_by_range_list = + ((Some(secname1, (Nat_big_num.of_int 0, size2)), FileFeature(ElfSection(Nat_big_num.of_int (* We don't yet konw where this'll come in the output file, so ... *) (* scn_idx *)0, + { elf64_section_name =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_type = (output_section_type comp) + ; elf64_section_flags = (output_section_flags comp) + ; elf64_section_addr =(Nat_big_num.of_int 0) (* ignored -- covered by element *) + ; elf64_section_offset =(Nat_big_num.of_int 0) (* ignored -- will be replaced when file offsets are assigned *) + ; elf64_section_size =(Nat_big_num.of_int 0) (* ignored *) + ; elf64_section_link =(Nat_big_num.of_int 0) (* HMM *) + ; elf64_section_info =(Nat_big_num.of_int 0) (* HMM *) + ; elf64_section_align = (alignof_output_section comp) + ; elf64_section_entsize =(Nat_big_num.of_int 0) (* HMM *) + ; elf64_section_body = Byte_sequence.empty (* ignored *) + ; elf64_section_name_as_string = secname1 (* can't rely on this being ignored *) + } + ))) :: Pset.elements new_range_tag_pairs) + in + (*let _ = errln ("Metadata for new section " ^ secname ^ " consists of " ^ (show (length new_by_range_list)) ^ " tags.") + in*) + let new_by_range = (List.fold_left (fun m -> fun (maybe_range, tag) -> + let new_s = (Pset.add (maybe_range, tag) m) + in + (* let _ = errln ("Inserting an element into by_range; before: " ^ (show (Set.size m)) ^ "; after: " ^ (show (Set.size new_s))) + in *) + new_s + ) acc_img.by_range new_by_range_list) + in + let new_by_tag = (by_tag_from_by_range + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) instance_Basic_classes_SetType_var_dict new_by_range) + in + let _ = + (let section_tags_bare = (List.filter (fun (maybe_range, tag) -> + (match tag with + | FileFeature(ElfSection(idx1, isec1)) -> true + | _ -> false + )) (Pset.elements new_by_range)) + in + (* errln ("Total metadata now includes " ^ (show (length section_tags_bare)) ^ " sections; are by_range and " + ^ "by_tag consistent? " ^ (show (new_by_tag = by_tag_from_by_range new_by_range))) *) ()) + in + (* this expression is the return value of add_output_section *) + ( Nat_big_num.add + (* new_pos *) output_section_start_addr size2, + (* new_acc *) { + elements = (Pmap.add secname1 concat_sec_el acc_img.elements) + (* tag it as a section, and transfer any tags *) + ; by_range = (* let _ = errln ("Returning from add_output_section a by_range with " ^ + (show (Set.size new_by_range))) in *) new_by_range + ; by_tag = new_by_tag + }, + (* sec_sz *) size2, + (* replacement_output_sec *) (OutputSectionSpec (guard, Some(output_section_start_addr), secname1, comp)) + ) + )) (* end add_output_section *) + in + (match script1 with + [] -> (acc, (AllocatedSectionsMap outputs_by_name)) + | (element1, el_idx) :: more_elements_and_idx -> + let do_nothing = (acc, pos, (AllocatedSectionsMap outputs_by_name)) in + let (new_acc, new_pos, new_outputs_by_name) = + ((match element1 with + DefineSymbol(symdefpol, name1, (symsize, syminfo, symother)) -> + (* We've already added this to the output composition. *) + do_nothing + | AdvanceAddress(AddressExprFn advance_fn_ref) -> + let advance_fn = +((match Pmap.lookup advance_fn_ref alloc_map with + | Some m -> m + | None -> failwith "alloc_map invariant failure" + )) + in + let new_pos = (advance_fn pos (AllocatedSectionsMap outputs_by_name)) + in + (acc, new_pos, (AllocatedSectionsMap outputs_by_name)) + (* FIXME: the allocated sections map is the subset of the outputs_by_name map + * that has been allocated -- meaning *both* sized *and* placed. + * Since we're a multi-pass interpreter, we've sized everything already, but + * only a subset has been placed. So we need to weed out all elements from + * outputs_by_name that don't correspond to a section in the accumulated image. + * We should probably include the section's range_tag in the allocated_sections_map, + * which would force us to do this, but at the moment neither of these is done. *) + | MarkAndAlignDataSegment(maxpagesize1, commonpagesize1) -> + (* GNU linker manual says: + + "DATA_SEGMENT_ALIGN(MAXPAGESIZE, COMMONPAGESIZE) + is equivalent to either + (ALIGN(MAXPAGESIZE) + (. & (MAXPAGESIZE - 1))) + or + (ALIGN(MAXPAGESIZE) + (. & (MAXPAGESIZE - COMMONPAGESIZE))) + depending on whether the latter uses fewer COMMONPAGESIZE sized + pages for the data segment (area between the result of this + expression and `DATA_SEGMENT_END') than the former or not. If the + latter form is used, it means COMMONPAGESIZE bytes of runtime + memory will be saved at the expense of up to COMMONPAGESIZE wasted + bytes in the on-disk file." + + In other words, we're marking the beginning of the data segment + by aligning our position upwards by an amount that + + - guarantees we're on a new page... + + - ... but (option 1) at an address that's congruent, modulo the max page size + (e.g. for 64kB maxpage, 4kB commonpage, we AND with 0xffff) + + - ... (option 2) at an offset that's at the commonpagesize boundary + immediately preceding the lowest congruent address + (e.g. for 64kB maxpage, 4kB commonpage, we AND with 0xf000, + so if we're at pos 0x1234, we bump up to 0x11000). + + FIXME: + + The GNU linker seems to bump up to 0x12000 here, not 0x11000. + Specifically, + + DATA_SEGMENT_ALIGN (0x200000, 0x1000) + + bumps 0x4017dc up to 0x602000. + + This is indeed better, because it allows the next section + to be output without a big gap in the file. + + LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 + 0x00000000000017dc 0x00000000000017dc R E 200000 + LOAD 0x0000000000002000 0x0000000000602000 0x0000000000602000 + 0x0000000000000120 0x0000000000000ce8 RW 200000 + + ... whereas if the second LOAD began at address 0x601000, + the file offset of its first section would have to be 0x11000. + + So what *should* the formula be? + It needs to calculate the next address which + + - is a commonpagesize boundary; + + - is minimally >= the current address, modulo the commonpagesize + + - is minimally >= the current address, modulo the maxpagesize. + + The AND operation gives us something that is minimally *below* + the commonpagesize boundary. I think we need to add COMMONPAGESIZE. + + The code does this (in ldexp.c around line 478 as of binutils 2.25): + + expld.result.value = align_n (expld.dot, maxpage); + /* omit relro phase */ + if (expld.dataseg.phase == exp_dataseg_adjust) + { + if (commonpage < maxpage) + expld.result.value += ((expld.dot + commonpage - 1) + & (maxpage - commonpage)); + } + else + { + expld.result.value += expld.dot & (maxpage - 1); + + Which amounts to: + + 1. first, align up to maxpage. So for our example, we're now 0x10000. + or for our real example, we're now 0x600000 + + THEN since the first phase (expld_dataseg_none) + hits the final "else" case, + we immediately restore the modulus of the address, + giving 0x60188c. + or 0x6019ac the second time around (FIXME: why two?) + + 2. next, on the relevant phase (pass) of the script interpreter, + i.e. OPTION 2 + if commonpage < maxpage, + bump up the *non-maxpage-aligned non-modulo-restored* address + by + (. + commonpage - 1) & (maxpage - commonpage) + + i.e. for our example earlier + (0x01234 + 0x1000 - 1) & (0xf000) + = + 0x02233 & 0xf000 + = + 0x02000 + + i.e. for our real example + (0x4019ac + 0x1000 - 1) & (0x1ff000) + = + 0x4019ac + 0x1000 - 1) & 0x1ff000 + = + 0x002000 + + 3. OPTION 1 is implemented by the trailing "else {" + -- it restores the modulus. + + So the problem with our original logic (below) was that + it did what the manual says, not what the code does. + Specifically, the code for option 2 does + + (. + commonpagesize - 1) & (maxpagesize - commonpagesize) + + and NOT simply + + . & (maxpagesize - commonpagesize). + + FIXME: report this bug. + + + Note that intervening commands can do arbitrary things to the location + counter, so we can't do any short-cut arithmetic based on section sizes; + we actually have to run the layout procedure til we hit the end of the + data segment, and then see how we do. + + We run this function *forward* with the first option on a subset + of the script ending with the end of the data segment. + We then see what comes back. + + *) + (* let num_pages_used *) + (*let _ = errln ("Option 1 congruence add-in from pos 0x" ^ (hex_string_of_natural pos) ^ ", maxpagesize 0x" ^ + (hex_string_of_natural maxpagesize) ^ " is 0x" ^ (hex_string_of_natural (natural_land pos (maxpagesize - 1)))) + in*) + let option1 = (Nat_big_num.add (align_up_to maxpagesize1 pos) (Nat_big_num.bitwise_and pos ( Nat_big_num.sub_nat maxpagesize1(Nat_big_num.of_int 1)))) + in + (*let _ = errln ("Mark/align data segment: option 1 is to bump pos to 0x" ^ (hex_string_of_natural option1)) + in*) + let option2 = (Nat_big_num.add (align_up_to maxpagesize1 pos) (Nat_big_num.bitwise_and ( Nat_big_num.sub_nat (Nat_big_num.add pos commonpagesize1)(Nat_big_num.of_int 1)) ( Nat_big_num.sub_nat maxpagesize1 commonpagesize1))) + in + (*let _ = errln ("Mark/align data segment: option 2 is to bump pos to 0x" ^ (hex_string_of_natural option2)) + in*) + let data_segment_endpos = (fun startpos1 -> + (* run forward from here until MarkDataSegmentEnd, + * accumulating the actually-made outputs by name and their sizes *) + let (endpos, _) = (List.fold_left (fun (curpos, seen_end) -> fun (new_script_item, new_script_item_idx) -> + (*let _ = errln ("Folding at pos 0x" ^ (hex_string_of_natural curpos)) + in*) + if seen_end + then (curpos, true) + else let (newpos, new_seen) = ((match new_script_item with + | MarkDataSegmentEnd -> + (*let _ = errln "data segment end" + in*) + (* break the loop early here *) + (curpos, true) + | OutputSection(outputguard, maybe_expr, name1, sub_elements) -> + (*let _ = errln ("output section " ^ name) + in*) + let maybe_found = (Pmap.lookup name1 outputs_by_name) + in + let (OutputSectionSpec (guard, addr, secname1, comp), seen_script_el_idx) = ((match maybe_found with + Some (f, seen_script_el_idx) -> (f, seen_script_el_idx) + | None -> failwith "internal error: output section not found" + )) + in + (* Sometimes a given output section name, say .eh_frame, can come from multiple + * script elements with disjoint guard conditions (only_if_ro and only_if_rw, say). + * Only one of them will actually be selected when the guard is being evaluated. + * So when we "replay" the sections' output here, we want to skip the ones whose + * guards were false. The way we implement this is to store the originating script + * element idx in the allocated_output_sections map. We can test that against our + * current script element_idx here *) + let replay_output = ( Nat_big_num.equal seen_script_el_idx el_idx) + in + if replay_output + then ( + let unaligned_start_addr = curpos + in + let start_addr = (align_up_to (alignof_output_section comp) unaligned_start_addr) + in + let (end_addr, comp_addrs) = (do_output_section_layout_starting_at_addr start_addr (AllocatedSectionsMap outputs_by_name) comp) + in + let size2 = (Nat_big_num.sub_nat end_addr start_addr) + in + (end_addr, (* seen_end *) false) + ) + else (curpos, (* seen_end *) false) + | AdvanceAddress(AddressExprFn advance_fn_ref) -> + (*let _ = errln "Advance address" + in*) + let advance_fn = +((match Pmap.lookup advance_fn_ref alloc_map with + | Some m -> m + | None -> failwith "alloc_map invariant failed" + )) + in + let new_pos = (advance_fn curpos (AllocatedSectionsMap outputs_by_name)) + in + (new_pos, false) + | _ -> (curpos, seen_end) + )) + in + if Nat_big_num.less newpos curpos then failwith "went backwards" else (newpos, new_seen) + ) (startpos1, false) more_elements_and_idx) + in endpos + ) + in + let endpos_option1 = (data_segment_endpos option1) + in + let endpos_option2 = (data_segment_endpos option2) + in + (*let _ = errln ("Mark/align data segment: option 1 gives an endpos of 0x" ^ (hex_string_of_natural endpos_option1)) + in*) + (*let _ = errln ("Mark/align data segment: option 2 gives an endpos of 0x" ^ (hex_string_of_natural endpos_option2)) + in*) + let npages = (fun startpos1 -> (fun endpos -> Nat_big_num.div + ( Nat_big_num.sub_nat(align_up_to commonpagesize1 endpos) + (round_down_to commonpagesize1 startpos1)) commonpagesize1 + )) + in + let npages_option1 = (npages option1 endpos_option1) + in + let npages_option2 = (npages option2 endpos_option1) + in + (*let _ = errln ("Mark/align data segment: option 1 uses " ^ (show npages_option1) ^ " COMMONPAGESIZE-sized pages") + in*) + (*let _ = errln ("Mark/align data segment: option 2 uses " ^ (show npages_option2) ^ " COMMONPAGESIZE-sized pages") + in*) + if Nat_big_num.less npages_option1 npages_option2 + then (*let _ = errln "Choosing option 1" in*) (acc, option1, (AllocatedSectionsMap outputs_by_name)) + else (*let _ = errln "Choosing option 2" in*) (acc, option2, (AllocatedSectionsMap outputs_by_name)) + | MarkDataSegmentEnd -> do_nothing + | MarkDataSegmentRelroEnd(*(fun_from_secs_to_something)*) -> do_nothing + | OutputSection(outputguard, maybe_expr, name1, sub_elements) -> + (* Get the composition we computed earlier, and actually put it in + * the image, assigning an address to it. *) + let maybe_found = (Pmap.lookup name1 outputs_by_name) + in + let (found, seen_script_el_idx) = ((match maybe_found with + Some (f, saved_idx) -> (f, saved_idx) + | None -> failwith "internal error: output section not found" + )) + in + let (OutputSectionSpec (guard, addr, secname1, comp)) = found + in + (* let next_free_section_idx = 1 + naturalFromNat (Map.size outputs_by_name) + in *) + let count_sections_in_image = (fun img2 -> ( + let (section_tags, section_ranges) = (elf_memory_image_section_ranges img2) + in + let section_tags_bare = (Lem_list.map (fun tag -> + (match tag with + | FileFeature(ElfSection(idx1, isec1)) -> true + | _ -> false + )) section_tags) + in + length section_tags_bare + )) + in + (* Do we actually want to add an output section? Skip empty sections. + * CARE: we actually want to heed the proper ld semantics for empty sections + * (e.g. ". = ." will force output). From the GNU ld manual: + + The linker will not normally create output sections with no contents. + This is for convenience when referring to input sections that may or + may not be present in any of the input files. For example: + .foo : { *(.foo) } + will only create a `.foo' section in the output file if there is a + `.foo' section in at least one input file, and if the input sections + are not all empty. Other link script directives that allocate space in + an output section will also create the output section. So too will + assignments to dot even if the assignment does not create space, except + for `. = 0', `. = . + 0', `. = sym', `. = . + sym' and `. = ALIGN (. != + 0, expr, 1)' when `sym' is an absolute symbol of value 0 defined in the + script. This allows you to force output of an empty section with `. = + .'. + + The linker will ignore address assignments ( *note Output Section + Address::) on discarded output sections, except when the linker script + defines symbols in the output section. In that case the linker will + obey the address assignments, possibly advancing dot even though the + section is discarded. + + * It follows that we might discard the output section, + * but *retain* the symbol definitions within it, + * and keep the dot-advancements that + * In other words, we care about two things: + * + * -- whether there are any non-empty input sections, *or* + * non-excluded assignments to dot, inside the composition: + * this controls whether the section is output + + * -- whether the script defines symbols in the section; if so + * then *even if the section is discarded* + * we must honour the address assignments, + * which means using the ending address of do_output_section_layout_starting_at_addr, + * *and* + * we must retain the symbol definitions (which now could + * end up going in some other section? HMM...) + *) + let comp_element_allocates_space = (fun comp_el -> (match comp_el with + IncludeInputSection(_, irec) -> Nat_big_num.greater + (*let _ = errln ("Saw an input section named `" ^ irec.isec.elf64_section_name_as_string ^ + "' of size " ^ (show irec.isec.elf64_section_size)) + in*) + irec.isec.elf64_section_size(Nat_big_num.of_int 0) + | IncludeCommonSymbol(retain_pol, fname1, idx1, def, img2) -> Nat_big_num.greater +(Ml_bindings.nat_big_num_of_uint64 def.def_syment.elf64_st_size)(Nat_big_num.of_int 0) + | ProvideSymbol(pol, name1, spec) -> true (* HACK: what else makes sense here? *) + | Hole(AddressExprFn(address_fn_ref)) -> + let address_fn = +((match Pmap.lookup address_fn_ref alloc_map with + | Some m -> m + | None -> failwith "alloc_map invariant failed" + )) + in + let assignment_is_excluded = (fun f -> + (* really makes you wish you were programming in Lisp *) + let always_gives_0 = + ( Nat_big_num.equal(f(Nat_big_num.of_int 0) (AllocatedSectionsMap outputs_by_name))(Nat_big_num.of_int 0) + && Nat_big_num.equal (f(Nat_big_num.of_int 42) (AllocatedSectionsMap outputs_by_name))(Nat_big_num.of_int 0)) (* FIXME: this is wrong *) + in + let always_gives_dot = + ( Nat_big_num.equal(f(Nat_big_num.of_int 0) (AllocatedSectionsMap outputs_by_name))(Nat_big_num.of_int 0) + && Nat_big_num.equal (f(Nat_big_num.of_int 42) (AllocatedSectionsMap outputs_by_name))(Nat_big_num.of_int 42)) (* FIXME: this is wrong *) + in + (* FIXME: what are the semantics of function equality in Lem? *) + always_gives_0 || (always_gives_dot (*&& (AddressExprFn(f)) <> assign_dot_to_itself*) (* FIXME DPM: almost certainly not what is meant... *))) + in + not (assignment_is_excluded address_fn) + )) + in + let section_contains_non_empty_inputs = +(List.exists comp_element_allocates_space comp) + in + (* See note in MarkDataSegmentEnd case about script element idx. Short version: + * multiple output section stanzas, for a given section name, may be in the script, + * but only one was activated by the section composition pass. Ignore the others. *) + let do_output = (( Nat_big_num.equal seen_script_el_idx el_idx) && section_contains_non_empty_inputs) + in + if not do_output then + (*let _ = errln ("At pos 0x" ^ (hex_string_of_natural pos) ^ ", skipping output section " ^ name ^ + " because " ^ (if not section_contains_non_empty_inputs + then "it contains no non-empty inputs" + else "it was excluded by its output guard")) + in*) + (acc, pos, (AllocatedSectionsMap outputs_by_name)) + else ( + (* let _ = errln ("Before adding output section, we have " ^ (show (count_sections_in_image acc)) + ^ " sections.") + in *) + let (new_pos, new_acc, sec_sz, replacement_output_sec) + = (add_output_section ((* next_free_section_idx, *) pos, acc) found) + in + (*let _ = errln ("At pos 0x" ^ (hex_string_of_natural pos) ^ ", adding output section " ^ name ^ + " composed of " ^ (show (length comp)) ^ " items, new pos is 0x" ^ (hex_string_of_natural new_pos)) + in*) + (* let _ = errln ("Received from add_output_section a by_range with " ^ (show (Set.size new_acc.by_range)) + ^ " metadata records of which " ^ (show (Set.size { + (r, t) + | forall ((r, t) IN new_acc.by_range) + | match t with FileFeature(ElfSection(x)) -> true | _ -> false end + } + )) ^ " are ELF sections; one more time: " ^ (show (Set.size { + (t, r) + | forall ((t, r) IN new_acc.by_tag) + | match t with FileFeature(ElfSection(x)) -> true | _ -> false end + } + )) ^ "; count_sections_in_image says " ^ (show ( + length (Multimap.lookupBy Memory_image_orderings.tagEquiv (FileFeature(ElfSection(0, null_elf64_interpreted_section))) new_acc.by_tag) + )) + ) + in *) + (* let _ = errln ("After adding output section, we have " ^ (show (count_sections_in_image new_acc)) + ^ " sections.") + in *) + (new_acc, new_pos, (AllocatedSectionsMap (Pmap.add name1 (replacement_output_sec, el_idx) (Pmap.remove name1 outputs_by_name)))) + ) + | DiscardInput(selector) -> do_nothing + | InputQuery(retainpol, sortpol, selector) -> do_nothing + )) + in + (* recurse *) + build_image alloc_map new_acc new_pos new_outputs_by_name bindings_by_name more_elements_and_idx control_script_linkable_idx linker_defs_by_name + )) + +(* +let rec consecutive_commons rev_acc l = + match l with + [] -> reverse rev_acc + | IncludeCommonSymbol(pol, fname, def, img) :: rest -> + consecutive_commons ((pol, fname, def, img) :: rev_acc) rest + | _ -> reverse rev_acc +end +*) + +(*val default_place_orphans : input_output_assignment -> list input_spec -> input_output_assignment*) +let default_place_orphans (discards, outputs) inputs:(input_spec)list*(output_section_spec*Nat_big_num.num)list= +( + (* Try to emulate the GNU linker. + * Its docs say: + + "It attempts to place orphan sections after + non-orphan sections of the same attribute, such as code vs data, + loadable vs non-loadable, etc. If there is not enough room to do this + then it places at the end of the file. + + + For ELF targets, the attribute of the section includes section type + as well as section flag." + + * It places the .tm_clone_table orphan + + [ 9] .tm_clone_table PROGBITS 0000000000000000 00000160 + 0000000000000000 0000000000000000 WA 0 0 8 + + as + + .data 0x0000000000602120 0x0 crtend.o + .data 0x0000000000602120 0x0 crtn.o + + .tm_clone_table + 0x0000000000602120 0x0 + .tm_clone_table + 0x0000000000602120 0x0 crtbeginT.o + .tm_clone_table + 0x0000000000602120 0x0 crtend.o + + .data1 + *(.data1) + 0x0000000000602120 _edata = . + + i.e. between .data and .data1. In the script: + + .got.plt : { *(.got.plt) *(.igot.plt) } + .data : + { + *(.data .data.* .gnu.linkonce.d.* ) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + _edata = .; PROVIDE (edata = .); + . = .; + __bss_start = .; + + i.e. no clear reason for why between .data and .data1. In the code: + + (see elf32em.c line 1787 in binutils 2.25) + + ... the key bit of code is as follows. + + place = NULL; + if ((s->flags & (SEC_ALLOC | SEC_DEBUGGING)) == 0) + place = &hold[orphan_nonalloc]; + else if ((s->flags & SEC_ALLOC) == 0) + ; + else if ((s->flags & SEC_LOAD) != 0 + && ((iself && sh_type == SHT_NOTE) + || (!iself && CONST_STRNEQ (secname, ".note")))) + place = &hold[orphan_interp]; + else if ((s->flags & (SEC_LOAD | SEC_HAS_CONTENTS | SEC_THREAD_LOCAL)) == 0) + place = &hold[orphan_bss]; + else if ((s->flags & SEC_SMALL_DATA) != 0) + place = &hold[orphan_sdata]; + else if ((s->flags & SEC_THREAD_LOCAL) != 0) + place = &hold[orphan_tdata]; + else if ((s->flags & SEC_READONLY) == 0) + place = &hold[orphan_data]; + else if (((iself && (sh_type == SHT_RELA || sh_type == SHT_REL)) + || (!iself && CONST_STRNEQ (secname, ".rel"))) + && (s->flags & SEC_LOAD) != 0) + place = &hold[orphan_rel]; + else if ((s->flags & SEC_CODE) == 0) + place = &hold[orphan_rodata]; + else + place = &hold[orphan_text]; + + + .. we replicate it here. + *)let output_irecs = (List.fold_left (fun acc -> fun outp -> ((match outp with + (OutputSectionSpec(guard, maybe_addr, name1, comp), script_el_idx) -> + let all_irecs = (List.fold_left (fun inner_acc -> fun comp_el -> (match comp_el with + IncludeInputSection(_, irec) -> Pset.add irec inner_acc + | _ -> inner_acc + ))(Pset.from_list compare []) comp) + in + Pset.(union) all_irecs acc + | _ -> acc + )))(Pset.from_list compare []) outputs) + in + let (orphans : input_spec list) = (List.filter (fun inp -> (match inp with + InputSection(irec) -> let v = (not ( Pset.mem irec output_irecs)) + in (*let _ = if v then errln ("Saw an orphan input section: " ^ + irec.secname ^ " in " ^ irec.fname) else () + in*) v + | _ -> false + )) inputs) + in + let place_one_orphan = (fun acc -> fun input -> ( + let irec = ((match input with + InputSection(irec) -> irec + | _ -> failwith "impossible: orphan section is not a section" + )) + in + let (discards, outputs) = acc in + let find_output = (fun maybe_name -> fun maybe_type -> fun flags_must_have -> fun flags_must_not_have -> ( + Missing_pervasives.find_index0 (fun (OutputSectionSpec (guard, maybe_addr, name1, comp), script_el_idx) -> + let flags = (output_section_flags comp) in + (match maybe_name with Some n -> n = name1 | None -> true ) + && ((match maybe_type with Some t -> Nat_big_num.equal (output_section_type comp) t | None -> true ) + && (Pset.for_all (fun x -> flag_is_set x flags) flags_must_have + && Pset.for_all (fun x -> not (flag_is_set x flags)) flags_must_not_have)) + ) outputs + )) + in + let place_after_nonalloc = (find_output None None(Pset.from_list Nat_big_num.compare [])(Pset.from_list Nat_big_num.compare [ shf_alloc ])) in + let place_after_interp = (find_output (Some(".interp")) (Some(sht_progbits))(Pset.from_list Nat_big_num.compare [ shf_alloc ])(Pset.from_list Nat_big_num.compare [])) in + let place_after_bss = (find_output (Some(".bss")) (Some(sht_nobits))(Pset.from_list Nat_big_num.compare [ shf_alloc; shf_write])(Pset.from_list Nat_big_num.compare [])) in + let place_after_rodata = (find_output (Some(".rodata")) (Some(sht_progbits))(Pset.from_list Nat_big_num.compare [ shf_alloc ])(Pset.from_list Nat_big_num.compare [ shf_write ])) in + let place_after_rel = (find_output (Some(".rela.dyn")) (Some(sht_rela))(Pset.from_list Nat_big_num.compare [])(Pset.from_list Nat_big_num.compare [])) in + let place_after_data = (find_output (Some(".data")) (Some(sht_progbits))(Pset.from_list Nat_big_num.compare [ shf_alloc; shf_write ])(Pset.from_list Nat_big_num.compare [])) in + let place_after_text = (find_output (Some(".text")) (Some(sht_progbits))(Pset.from_list Nat_big_num.compare [ shf_alloc; shf_execinstr ])(Pset.from_list Nat_big_num.compare [])) in + let (place_after : Nat_big_num.num option) = ((match input with + InputSection(irec) -> + (* HACK: simulates GNU linker, but this logic ought to go elsewhere *) + if irec.isec.elf64_section_name_as_string = ".note.GNU-stack" then None + else + if not (flag_is_set shf_alloc irec.isec.elf64_section_flags) + && (* not flag_is_set shf_alloc irec.isec.elf64_section_flags *) (* no debugging, for now *) true + then place_after_nonalloc + else (* FIXME: reinstate alloc-debugging case *) + if Nat_big_num.equal irec.isec.elf64_section_type sht_note (* FIXME: replicate iself logic *) + || (irec.isec.elf64_section_name_as_string = ".note") + then place_after_interp + else if Nat_big_num.equal irec.isec.elf64_section_type sht_nobits + then place_after_bss + else (* FIXME: implement thread-local case *) + if not (flag_is_set shf_write irec.isec.elf64_section_flags) + && not (flag_is_set shf_execinstr irec.isec.elf64_section_flags) + then place_after_rodata + else if flag_is_set shf_write irec.isec.elf64_section_flags + && not (flag_is_set shf_execinstr irec.isec.elf64_section_flags) + then place_after_data + else place_after_text + )) + in + let (discards, outputs) = acc in + (match place_after with + Some idx1 -> (* The section exists and has the flags we expected, and is at output idx *) + (discards, mapi (fun i -> fun output -> + (* FIXME: also fix up flags, alignment etc. *) + let (OutputSectionSpec (guard, maybe_addr, name1, comp), script_el_idx) = output in + if Nat_big_num.equal (Nat_big_num.of_int i) idx1 then (OutputSectionSpec(guard, maybe_addr, name1, List.rev_append (List.rev comp) [IncludeInputSection(DefaultKeep, irec)]), script_el_idx) else output + ) outputs + ) + | None -> + (*let _ = errln ("Warning: discarding orphan section `" ^ irec.isec.elf64_section_name_as_string + ^ "' from file `" ^ irec.fname ^ "'") + in*) + ( List.rev_append (List.rev discards) [input], outputs) + ) + )) + in + List.fold_left place_one_orphan (discards, outputs) orphans) + +(*val interpret_linker_control_script : + address_expr_fn_map allocated_sections_map -> + linker_control_script + -> linkable_list + -> natural (* control_script_linkable_idx *) + -> abi any_abi_feature + -> list input_spec + -> (input_spec -> input_spec -> ordering) (* seen ordering *) + -> (input_output_assignment -> list input_spec -> input_output_assignment) (* place orphans *) + -> (Map.map string (list (natural * binding))) (* initial_bindings_by_name *) + -> (elf_memory_image * Map.map string (list (natural * binding)))*) +let interpret_linker_control_script alloc_map script1 linkables control_script_linkable_idx a inputs seen_ordering place_orphans initial_bindings_by_name:(any_abi_feature)annotated_memory_image*((string),((Nat_big_num.num*binding)list))Pmap.map= + (let labelled_script = (label_script script1) + in + (*let _ = List.mapi (fun i -> fun input -> + errln ("Input " ^ (show i) ^ " is " ^ + match input with + InputSection(inp) -> + "input section, name `" ^ inp.secname ^ + "', from file `" ^ inp.fname ^ "' (linkable idx " ^ (show inp.idx) ^ ")" + | Common(idx, symname, img, def) -> + "common symbol `" ^ symname ^ "'" + end + ) + ) inputs + in*) + let (discards_before_orphans, outputs_before_orphans) + = (assign_inputs_to_output_sections ([], [])(Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [])(Pset.from_list (tripleCompare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare) []) inputs None None seen_ordering labelled_script) + in + (* place orphans *) + let (discards, outputs) = (place_orphans (discards_before_orphans, outputs_before_orphans) inputs) + in + (* In assigning inputs to outputs, we may also have defined some symbols. These affect the + * bindings that are formed. So, we rewrite the bindings here. Note that we have to do so here, + * not in the caller, because these extra bindings can affect the reachability calculation + * during GC. *) + let (linker_defs_by_name, (bindings_by_name : ( (string, ( (Nat_big_num.num * binding)list))Pmap.map))) = ( + let (script_defs_by_name : (string, ( (symbol_definition * symbol_def_policy)list)) Pmap.map) + = (List.fold_left (fun acc -> (fun ((OutputSectionSpec (guard, maybe_addr, secname1, comp)), script_el_idx) -> + List.fold_left (fun inner_acc -> fun comp_el -> ( + (match comp_el with + ProvideSymbol(pol, name1, (size2, info, other)) -> + (*let _ = errln ("Linker script defining symbol `" ^ name ^ "'") + in*) + let def = (symbol_def_for_provide_symbol name1 size2 info other control_script_linkable_idx) + in + let v = ((match Pmap.lookup name1 inner_acc with + None -> [(def, pol)] + | Some l -> (def, pol) :: l + )) + in + Pmap.add name1 v inner_acc + | _ -> inner_acc + ) + )) (acc : (string, ( (symbol_definition * symbol_def_policy)list)) Pmap.map) comp + )) (Pmap.empty compare) outputs) + in + (* Now that we've made these definitions, what bindings are affected? + * We also use this opportunity to bind references to linker-generated symbols, + * such as _GLOBAL_OFFSET_TABLE_, since any definitions of these should now be merged + * into our inputs. *) + (* bit of a HACK: reconstruct the linkable img and idx from the input items *) + let idx_to_img = (List.fold_left (fun acc_m -> fun item -> + (match item with + Common(idx1, _, img2, symdef) -> Pmap.add idx1 img2 (Pmap.remove idx1 acc_m) + | InputSection(irec) -> Pmap.add irec.idx irec.img (Pmap.remove irec.idx acc_m) + ) + ) (Pmap.empty Nat_big_num.compare) inputs) + in + let (lowest_idx : Nat_big_num.num) = ((match Pset.min_elt_opt (Pmap.domain idx_to_img) + with Some x -> x + | None -> failwith "internal error: no linkable items" + )) + in + let first_linkable_item = ((match linkables with x :: more -> x | _ -> failwith "internal error: no linkables" )) + in + let (control_script_input_item : input_item) = ( + "(built-in control script)", + ControlScript, + (BuiltinControlScript, [Builtin]) + ) + in + let (control_script_linkable_item : linkable_item) = ( + ControlScriptDefs, control_script_input_item, + { item_fmt = "" + ; item_check_sections = false + ; item_copy_dt_needed = false + ; item_force_output = true + } + ) + in + let updated_bindings_and_new_defs = (Pmap.map (fun b_list_initial -> + Lem_list.map (fun (b_idx, b_initial) -> + let ((iref_idx, iref, iref_item), maybe_idef) = b_initial + in + (*let _ = errln ("Looking for linker script or linker-generated defs of symbol `" ^ iref.ref_symname ^ "'") + in*) + let possible_script_defs = ((match Pmap.lookup iref.ref_symname script_defs_by_name with + Some l -> l + | None -> [] + )) + in + let (possible_linker_generated_def : symbol_definition option) = + (if a.symbol_is_generated_by_linker iref.ref_symname + then (* can we find a definition by this name? *) + ((match Pmap.lookup lowest_idx idx_to_img with + None -> failwith "no lowest idx found" + | Some img2 -> + (match List.filter (fun def -> def.def_symname = iref.ref_symname) (defined_symbols + instance_Basic_classes_Ord_Abis_any_abi_feature_dict instance_Abi_classes_AbiFeatureTagEquiv_Abis_any_abi_feature_dict img2) with + [] -> None + | [def] -> Some(def) + | _ -> failwith ("first linkable has multiple defs of name `" ^ (iref.ref_symname ^ "'")) + ) + )) + else None) + in + (* If the binding has no def, we always use the def we have. + * If the binding has a def, we use our def only if the policy is AlwaysDefine. *) + (*let _ = errs ("Do we override binding " ^ (show b_idx) ^ ", symbol named `" ^ + iref.ref_symname ^ "'? ") + in*) + (* FIXME: check real semantics of defining symbols like '_GLOBAL_OFFSET_TABLE_' in linker script or input objects. + * This is really just a guess. *) + let new_b_and_maybe_new_def = ((match (maybe_idef, possible_script_defs, possible_linker_generated_def) with + | (_, [], None) -> (*let _ = errln "no" in *) + (((iref_idx, iref, iref_item), maybe_idef), None) + | (None, [], Some(def)) -> (*let _ = errln "yes (was undefined)" in*) + (((iref_idx, iref, iref_item), Some(lowest_idx, def, first_linkable_item)), Some(def)) + | (_, [(def, AlwaysDefine)], _) -> (*let _ = errln "yes (linker script provides unconditional def)" in*) + (((iref_idx, iref, iref_item), Some (control_script_linkable_idx, def, control_script_linkable_item)), Some(def)) + | (Some existing_def, ([(def, ProvideIfUsed)]), _) -> (*let _ = errln "no" in*) + (((iref_idx, iref, iref_item), Some existing_def), None) + | (None, [(def, ProvideIfUsed)], _) -> (*let _ = errln "yes (linker script provides if-used def)" in*) + (((iref_idx, iref, iref_item), Some (control_script_linkable_idx, def, control_script_linkable_item)), Some(def)) + | (_, pair1 :: pair2 :: more, _) -> (*let _ = errln "error" in*) + failwith "ambiguous symbol binding in linker control script" + )) + in + (b_idx, new_b_and_maybe_new_def) + ) b_list_initial + ) initial_bindings_by_name) + in + let (new_symbol_defs_map : (string, ( ( symbol_definition option)list)) Pmap.map) + = (Pmap.map (fun b_pair_list -> Lem_list.map (fun (b_idx, (new_b, maybe_new_def)) -> maybe_new_def) b_pair_list) updated_bindings_and_new_defs) + in + let (new_symbol_defs_by_name : (string, ( symbol_definition list)) Pmap.map) = (Pmap.map + (fun v -> Lem_list.mapMaybe id0 v) new_symbol_defs_map) + in + (* { List.mapMaybe id maybe_def_list | forall ((_, maybe_def_list) IN (Map.toSet new_symbol_defs_map)) | true } + in*) + (*let new_symbol_defs = List.concat (Set_extra.toList new_symbol_def_list_set) + in*) + let updated_bindings = (Pmap.map (fun b_pair_list -> Lem_list.map (fun (b_idx, (new_b, maybe_new_def)) -> (b_idx, new_b)) b_pair_list) updated_bindings_and_new_defs) + in + (new_symbol_defs_by_name, updated_bindings) + ) + in + (*let _ = errln ("For __fini_array_end, we have " ^ + (let all_bs = match Map.lookup "__fini_array_end" bindings_by_name with + Just l -> l + | Nothing -> [] + end + in + ((show (length all_bs)) ^ + " bindings, of which " ^ + (show (length (List.filter (fun (bi, ((ref_idx, ref, ref_item), maybe_def)) -> + match maybe_def with + Just _ -> true + | _ -> false + end + ) all_bs))) ^ " have defs"))) + in*) + let outputs_by_name = + (let insert_fun = (fun m -> (fun (OutputSectionSpec(guard, maybe_addr, name1, compos), script_idx) -> Pmap.add name1 ((OutputSectionSpec (guard, maybe_addr, name1, compos)), script_idx) m)) + in + List.fold_left insert_fun (Pmap.empty compare) outputs) + in + (* Print the link map's "discarded input sections" output. *) + (*let _ = Missing_pervasives.outln "\nDiscarded input sections\n" + in*) + let discard_line = (fun i -> ((match i with + InputSection(s) -> + let lpadded_secname = (" " ^ s.secname) + in + lpadded_secname ^ ((space_padding_and_maybe_newline(Nat_big_num.of_int 16) lpadded_secname) ^ ("0x0000000000000000" (* FIXME *) + ^ (" 0x" ^ ((hex_string_of_natural s.isec.elf64_section_size) ^ (" " + ^ (s.fname ^ "\n")))))) + | Common(idx1, fname1, img2, def) -> "" (* don't print discard lines for discarded commons *) + ))) + in + (*let _ = Missing_pervasives.outs (List.foldl (fun str -> (fun input -> (str ^ (discard_line input)))) "" (reverse discards)) + in*) + let outputs_by_name_after_gc = (compute_def_use_and_gc (AllocatedSectionsMap outputs_by_name)) + in + (*let _ = Missing_pervasives.outs "\nMemory Configuration\n\nName Origin Length Attributes\n*default* 0x0000000000000000 0xffffffffffffffff\n" + in + let _ = Missing_pervasives.outln "\nLinker script and memory map\n" + in*) + (* FIXME: print LOAD and START_GROUP trace *) + let (img2, outputs_by_name_with_position) + = (build_image alloc_map empty_elf_memory_image(Nat_big_num.of_int 0) outputs_by_name_after_gc bindings_by_name labelled_script control_script_linkable_idx linker_defs_by_name) + in + (*let _ = errln ("Final image has " ^ (show (Map.size img.elements)) ^ " elements and " + ^ (show (Set.size img.by_tag)) ^ " metadata tags, of which " ^ ( + let (section_tags, section_ranges) = elf_memory_image_section_ranges img + in + let section_tags_bare = List.map (fun tag -> + match tag with + | FileFeature(ElfSection(idx, isec)) -> (idx, isec) + | _ -> failwith "not section tag" + end) section_tags + in + show (length section_tags_bare) + ) ^ " are sections.") + in*) + (* The link map output for the section/address assignment basically mirrors our notion of + * output section composition. In the following: + + 0x0000000000400000 PROVIDE (__executable_start, 0x400000) + 0x0000000000400190 . = (0x400000 + SIZEOF_HEADERS) + +.interp + *(.interp) + +.note.ABI-tag 0x0000000000400190 0x20 + .note.ABI-tag 0x0000000000400190 0x20 crt1.o + +.note.gnu.build-id + 0x00000000004001b0 0x24 + *(.note.gnu.build-id) + .note.gnu.build-id + 0x00000000004001b0 0x24 crt1.o + +.hash + *(.hash) + +.gnu.hash + *(.gnu.hash) + +... we can see that + + - symbol provision, holes and output sections all get lines + + - each output section appears with its name left-aligned, and its address, + if any, appearing afterwards; if so, the section's total size also follows. + + - each input query is printed verbatim, e.g. "*(.note.gnu.build-id)" + + - underneath this, a line is printed for each input section that was included, + with its address and size. This can spill onto a second line in the usual way. + + - holes are shown as "*fill*" + + - provided symbols are shown as in the linker script source. + + PROBLEM: we don't have the script in source form, so we can't print the queries verbatim. + I should really annotate each query with its source form; when the script is parsed from source, + this can be inserted automatically. For the moment, what to do? I could annotate each script + element manually. For the moment, for diffing purposes, filter out lines with asterisks. + + *) + (img2, bindings_by_name)) diff --git a/lib/ocaml_rts/linksem/main_elf.ml b/lib/ocaml_rts/linksem/main_elf.ml new file mode 100644 index 00000000..c5a31ebe --- /dev/null +++ b/lib/ocaml_rts/linksem/main_elf.ml @@ -0,0 +1,374 @@ +(*Generated by Lem from main_elf.lem.*) +(** [main_elf], the main module for the test program of the ELF development. + * Run like so: + * ./main_elf.opt --FLAG BINARY + * where: + * BINARY is an ELF binary + * FLAG is in the set { file-header, program-headers, section-headers, + * dynamic, relocs, symbols } + * + *) + +open Lem_basic_classes +open Lem_function +open Lem_maybe +open Lem_list +open Lem_num +open Lem_string +open Lem_tuple + +open Byte_sequence +open Default_printing +open Error +open Hex_printing +open Missing_pervasives +open Show +open Lem_assert_extra + +open Endianness + +open Elf_dynamic +open Elf_header +open Elf_file +open Elf_program_header_table +open Elf_section_header_table +open Elf_types_native_uint + +open Harness_interface +open Sail_interface + +open Abi_aarch64_relocation + +open Abi_amd64_elf_header +open Abi_amd64_relocation +open Abi_amd64_serialisation + +open Abi_power64_dynamic + +open Abi_x86_relocation + +open Abi_power64_relocation + +open Gnu_ext_dynamic +open Gnu_ext_program_header_table +open Gnu_ext_section_header_table + +open Dwarf + +let default_hdr_bdl:('a ->string)*('b ->string)= + (default_os_specific_print, default_proc_specific_print) + +let default_pht_bdl:('a ->string)*('b ->string)= + (default_os_specific_print, default_proc_specific_print) + +let default_sht_bdl:('b ->string)*('a ->string)*('c ->string)= + (default_os_specific_print, default_proc_specific_print, default_user_specific_print) + + +(* unrolled and made tail recursive for efficiency on large ELF files...*) +(*val chunks : list string -> list (list string) -> list (list string) * nat*) +let rec chunks (ss : string list) (accum : ( string list) list):((string)list)list*int= + ((match ss with + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::s11::s12::s13::s14::s15::s16::ss -> + chunks ss ([(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9);(s12^s11);(s14^s13);(s16^s15)]::accum) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::s11::s12::s13::s14::s15::[] -> + let buff = ([(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9);(s12^s11);(s14^s13);("00"^s15)]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 15) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::s11::s12::s13::s14::ss -> + let bits = (replicate0(Nat_big_num.of_int 1) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9);(s12^s11);(s14^s13)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 14) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::s11::s12::s13::[] -> + let bits = (replicate0(Nat_big_num.of_int 1) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9);(s12^s11);("00"^s13)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 13) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::s11::s12::[] -> + let bits = (replicate0(Nat_big_num.of_int 2) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9);(s12^s11)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 12) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::s11::[] -> + let bits = (replicate0(Nat_big_num.of_int 2) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9);("00"^s11)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 11) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::s10::[] -> + let bits = (replicate0(Nat_big_num.of_int 3) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7);(s10^s9)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 10) + | s1::s2::s3::s4::s5::s6::s7::s8::s9::[] -> + let bits = (replicate0(Nat_big_num.of_int 3) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7);("00"^s9)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 9) + | s1::s2::s3::s4::s5::s6::s7::s8::[] -> + let bits = (replicate0(Nat_big_num.of_int 4) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);(s8^s7)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 8) + | s1::s2::s3::s4::s5::s6::s7::[] -> + let bits = (replicate0(Nat_big_num.of_int 4) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5);("00"^s7)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 7) + | s1::s2::s3::s4::s5::s6::[] -> + let bits = (replicate0(Nat_big_num.of_int 5) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);(s6^s5)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 6) + | s1::s2::s3::s4::s5::[] -> + let bits = (replicate0(Nat_big_num.of_int 5) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3);("00"^s5)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 5) + | s1::s2::s3::s4::[] -> + let bits = (replicate0(Nat_big_num.of_int 6) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);(s4^s3)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 4) + | s1::s2::s3::[] -> + let bits = (replicate0(Nat_big_num.of_int 6) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1);("00"^s3)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 3) + | s1::s2::[] -> + let bits = (replicate0(Nat_big_num.of_int 7) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [(s2^s1)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 2) + | s1::[] -> + let bits = (replicate0(Nat_big_num.of_int 7) " ") in + let fixed = (intercalate " " bits) in + let buff = (List.rev_append (List.rev [("00"^s1)]) [concatS fixed]) in + ( List.rev_append (List.rev (List.rev accum)) [buff], 1) + | [] -> (List.rev accum, 0) + )) + +(*val provide_offsets : (list (list string) * nat) -> list (string * list string)*) +let provide_offsets (ss, ed):(string*(string)list)list= + + (List.rev_append (List.rev (Lem_list.mapi (fun i x -> + let hx = (unsafe_hex_string_of_natural( 7) ( Nat_big_num.mul(Nat_big_num.of_int i)(Nat_big_num.of_int 16))) in + (hx, x)) ss)) (if ed = 0 then + [(unsafe_hex_string_of_natural( 7) ( Nat_big_num.mul(Nat_big_num.of_int (List.length ss))(Nat_big_num.of_int 16)), [])] + else + [(unsafe_hex_string_of_natural( 7) ( Nat_big_num.add( Nat_big_num.mul(Nat_big_num.of_int ( Nat_num.nat_monus(List.length ss)( 1)))(Nat_big_num.of_int 16)) (Nat_big_num.of_int ed)), [])])) + +(*val create_chunks : byte_sequence -> list (string * list string)*) +let create_chunks bs0:(string*(string)list)list= + (let ss = (Lem_list.map (fun x -> + unsafe_hex_string_of_natural( 2) (natural_of_byte x)) + (Byte_sequence.byte_list_of_byte_sequence bs0)) + in + provide_offsets (chunks ss [])) + +(*val print_chunk : string * list string -> string*) +let print_chunk (off, ss):string= + ((match ss with + | [] -> off + | _ -> off ^ (" " ^ concatS (intercalate " " ss)) + )) + +(*val obtain_abi_specific_string_of_reloc_type : natural -> (natural -> string)*) +let obtain_abi_specific_string_of_reloc_type mach:Nat_big_num.num ->string= + (if Nat_big_num.equal mach elf_ma_ppc64 then + string_of_ppc64_relocation_type + else if Nat_big_num.equal mach elf_ma_386 then + string_of_x86_relocation_type + else if Nat_big_num.equal mach elf_ma_aarch64 then + string_of_aarch64_relocation_type + else if Nat_big_num.equal mach elf_ma_x86_64 then + string_of_amd64_relocation_type + (*else if mach = elf_ma_mips then + string_of_mips64_relocation_type*) + else + (fun y->"Cannot deduce ABI")) + +let ( _:unit) = +(let res = +(let (flag, arg) = +((match Ml_bindings.argv_list with + | progname::flag::fname1::more -> (flag, fname1) + | _ -> failwith "usage: main_elf <flag> <fname>" + )) + in + Byte_sequence.acquire arg >>= (fun bs0 -> + repeatM' Elf_header.ei_nident bs0 (read_unsigned_char Endianness.default_endianness) >>= (fun (ident, bs) -> + (match Lem_list.list_index ident( 4) with + | None -> failwith "ELF ident transcription error" + | Some c -> + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_32 then + let ret = +(if flag = "--file-header" then + Elf_header.read_elf32_header bs0 >>= (fun (hdr, _) -> + return (Harness_interface.harness_string_of_elf32_file_header hdr)) + else if flag = "--program-headers" then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + get_elf32_file_section_header_string_table f1 >>= (fun stbl -> + return (Harness_interface.harness_string_of_elf32_program_headers + string_of_gnu_ext_segment_type + (fun x -> + Nat_big_num.to_string x) + f1.elf32_file_header + f1.elf32_file_program_header_table + f1.elf32_file_section_header_table + stbl + bs0))) + else if flag = "--section-headers" then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + get_elf32_file_section_header_string_table f1 >>= (fun stbl -> + return (Harness_interface.harness_string_of_elf32_section_headers + string_of_gnu_ext_section_type + (fun x -> Nat_big_num.to_string x) + (fun x -> Nat_big_num.to_string x) + f1.elf32_file_header + f1.elf32_file_section_header_table + stbl))) + else if flag = "--relocs" then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + let print_reloc = (obtain_abi_specific_string_of_reloc_type (Nat_big_num.of_string (Uint32.to_string f1.elf32_file_header.elf32_machine))) in + return (Harness_interface.harness_string_of_elf32_relocs + f1 + print_reloc + bs0)) +(* else if flag = "--symbols" then + Harness_interface.harness_string_of_elf32_syms + f1 + show + show + bs0 *) + else if flag = "--dynamic" then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + let so = (is_elf32_shared_object_file f1.elf32_file_header) in + return (Harness_interface.harness_string_of_elf32_dynamic_section + f1 + bs0 + gnu_ext_os_additional_ranges + (fun x -> gnu_ext_tag_correspondence_of_tag x) + (fun x -> gnu_ext_tag_correspondence_of_tag x) + (fun x -> string_of_dynamic_tag so x gnu_ext_os_additional_ranges string_of_gnu_ext_dynamic_tag (fun _ -> "proc: from main_elf")) + gnu_ext_elf32_value_of_elf32_dyn + (fun _ _ -> Error.fail "proc: from main_elf"))) + else if flag = "--in-out" then + Elf_file.read_elf32_file bs0 >>= (fun f1 -> + (match Elf_file.bytes_of_elf32_file f1 with + | Fail f -> return f + | Success s -> + let chunks1 = (create_chunks s) in + let lines = (concatS (intercalate "\n" (Lem_list.map print_chunk chunks1))) in + return lines + )) + 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 + 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*) + ))) + else + failwith "Unrecognised flag") + in + ret + else if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string c)) Elf_header.elf_class_64 then + let ret = +(if flag = "--file-header" then + Elf_header.read_elf64_header bs0 >>= (fun (hdr, _) -> + return (Harness_interface.harness_string_of_elf64_file_header hdr)) + else if flag = "--program-headers" then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + get_elf64_file_section_header_string_table f1 >>= (fun stbl -> + return (Harness_interface.harness_string_of_elf64_program_headers + string_of_gnu_ext_segment_type + (fun x -> + Nat_big_num.to_string x) + f1.elf64_file_header + f1.elf64_file_program_header_table + f1.elf64_file_section_header_table + stbl + bs0))) + else if flag = "--section-headers" then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + get_elf64_file_section_header_string_table f1 >>= (fun stbl -> + return (Harness_interface.harness_string_of_elf64_section_headers + string_of_gnu_ext_section_type + (fun x -> Nat_big_num.to_string x) + (fun x -> Nat_big_num.to_string x) + f1.elf64_file_header + f1.elf64_file_section_header_table + stbl))) + else if flag = "--relocs" then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + let print_reloc = (obtain_abi_specific_string_of_reloc_type (Nat_big_num.of_string (Uint32.to_string f1.elf64_file_header.elf64_machine))) in + return (Harness_interface.harness_string_of_elf64_relocs + f1 + print_reloc + bs0)) + (*else if flag = "--symbols" then + Harness_interface.harness_string_of_elf64_syms + f1 + show + show + bs0*) + else if flag = "--dynamic" then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + let so = (is_elf64_shared_object_file f1.elf64_file_header) in + return (Harness_interface.harness_string_of_elf64_dynamic_section + f1 + bs0 + gnu_ext_os_additional_ranges + (fun x -> gnu_ext_tag_correspondence_of_tag x) + (fun x -> abi_power64_tag_correspondence_of_tag x) (* ABI! *) + (fun x -> string_of_dynamic_tag so x gnu_ext_os_additional_ranges string_of_gnu_ext_dynamic_tag string_of_abi_power64_dynamic_tag) + gnu_ext_elf64_value_of_elf64_dyn + abi_power64_elf64_value_of_elf64_dyn)) (* ABI! *) + else if flag = "--in-out" then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + (match Elf_file.bytes_of_elf64_file f1 with + | Fail f -> return f + | Success s -> + let chunks1 = (create_chunks s) in + let lines = (concatS (intercalate "\n" (Lem_list.map print_chunk chunks1))) in + return lines + )) + else if flag = "--debug-dump=info" then + Elf_file.read_elf64_file bs0 >>= (fun f1 -> + get_elf64_file_section_header_string_table f1 >>= (fun stbl -> + return (Dwarf.harness_string_of_elf64_debug_info_section + f1 + bs0 + (*string_of_gnu_ext_section_type + (fun x -> show x) + (fun x -> show x) + f1.elf64_file_header + f1.elf64_file_section_header_table + stbl*) + ))) + else + failwith "Unimplemented (for ELF64) or unrecognised flag") + in + ret + else + failwith "ELF ident transcription error" + )))) + in + (match res with + | Fail err -> prerr_endline ("[!]: " ^ err) + | Success e -> print_endline (string_of_string e) + )) + +(* +let _ = + match Sail_interface.populate_and_obtain_global_symbol_init_info "../test/mixed-binaries/tiny-istatic-with-malloc/tiny-tinystatic-with-malloc" with + | Fail err -> Missing_pervasives.errln ("[!]: " ^ err) + | Success (img, syms) -> Missing_pervasives.outln (Sail_interface.string_of_executable_process_image img) + end +*) diff --git a/lib/ocaml_rts/linksem/main_link.ml b/lib/ocaml_rts/linksem/main_link.ml new file mode 100644 index 00000000..82999d53 --- /dev/null +++ b/lib/ocaml_rts/linksem/main_link.ml @@ -0,0 +1,158 @@ +(*Generated by Lem from main_link.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +(*import Map*) +(*import Set*) +(*import Set_extra*) +open Lem_num +open Lem_maybe +open Lem_assert_extra + +open Byte_sequence +open Default_printing +open Error +open Missing_pervasives +open Show +open Endianness + +open Elf_header +open Elf_file +open Elf_interpreted_section +open Elf_interpreted_segment +open Elf_section_header_table +open Elf_program_header_table +open Elf_types_native_uint +open Elf_relocation +open String_table + +open Abi_amd64_elf_header +open Abi_amd64_serialisation +open Abis +(*import Gnu_ext_abi*) + +open Command_line +open Input_list +open Linkable_list + +open Memory_image +open Elf_memory_image +open Elf_memory_image_of_elf64_file +open Elf64_file_of_elf_memory_image + +open Linker_script +open Link + +(*val images_consistent : elf_memory_image -> elf_memory_image -> bool*) +let images_consistent img1 img2:bool= + (* img1.by_tag = img2.by_tag *) true + +(*val correctly_linked : abi any_abi_feature -> linkable_list -> list string -> set link_option -> elf64_file -> maybe elf_memory_image*) +let correctly_linked a linkables names options eout:((any_abi_feature)annotated_memory_image)option= + (let output_image = (elf_memory_image_of_elf64_file a "(output file)" eout) + in + let (fresh, alloc_map, script1) = (default_linker_control_script(Nat_big_num.of_int 0) (Pmap.empty Nat_big_num.compare) a + (* user_text_segment_start *) ((match Command_line.find_option_matching_tag (TextSegmentStart(Nat_big_num.of_int 0)) options with Some(TextSegmentStart(addr)) -> Some addr | _ -> None )) + (* user_data_segment_start *) None + (* user_rodata_segment_start *) ((match Command_line.find_option_matching_tag (RodataSegmentStart(Nat_big_num.of_int 0)) options with Some(RodataSegmentStart(addr)) -> Some addr | _ -> None )) + (* elf_headers_size *) + ( Nat_big_num.add(Nat_big_num.of_int + (* ELF header size *)64) (Nat_big_num.mul a.max_phnum(Nat_big_num.of_int 56)) (* size of one phdr *) + )) + in + let linked_image = (link alloc_map script1 a options linkables) + in + if images_consistent output_image linked_image then Some linked_image else None) + +(* We need to elaborate the command line to handle objects, archives + * and archive groups appropriately. + * We could imagine a relation between objects such that + * (o1, o2) is in the relation + * iff definitions in o1 might be used to satisfy references in o2. ("o1 supplies o2") + * If o1 is a .o, all other .o files are searched. + * If o1 comes from an archive and is not in a group, it only supplies *preceding* objects (whether from an archive or a .o). + * If o1 comes from an archive in a group, it supplies preceding objects and any objects from the same group. + * + * That doesn't capture the ordering, though: + * for each object, there's an ordered list of other objects + * in which to search for the *first* definition. *) + +let ( _:unit) = +(let res = +(let (input_units1, link_options1) = (command_line ()) + in + let items_and_options = (elaborate_input input_units1) + in + let (input_items, item_options) = (List.split items_and_options) + in + let _ = (prerr_endline ("Got " ^ ((Pervasives.string_of_int (List.length input_items)) ^ (" input items: {" + ^ ((List.fold_left (^) "" (Lem_list.map (fun item -> (string_of_triple + instance_Show_Show_string_dict instance_Show_Show_Input_list_input_blob_dict (instance_Show_Show_tup2_dict instance_Show_Show_Command_line_input_unit_dict + (instance_Show_Show_list_dict + instance_Show_Show_Input_list_origin_coord_dict)) item) ^ ",\n") input_items)) ^ "}"))))) + in + let output_filename = ((match Command_line.find_option_matching_tag (Command_line.OutputFilename("")) link_options1 with + None -> "impossible: no output file specified, despite default value of `a.out'" + | Some (Command_line.OutputFilename(s)) -> s + | _ -> "impossible: bad output filename option returned" + )) + in + Byte_sequence.acquire output_filename >>= (fun out -> + let _ = (prerr_endline ("Successfully opened output file")) in + Elf_file.read_elf64_file out >>= (fun eout -> + let _ = (prerr_endline ("Output file seems to be an ELF file")) in + let guessed_abi = (list_find_opt (fun a -> a.is_valid_elf_header eout.elf64_file_header) all_abis) + in + let a = ((match guessed_abi with + Some a -> if (* get_elf64_osabi eout.elf64_file_header = elf_osabi_gnu *) true + (* The GNU linker does not set the ABI to "GNU", but happily uses GNU extensions. + * FIXME: delegate to a personality function here + *) + then let _ = (prerr_endline "Using GNU-extended ABI") in Gnu_ext_abi.gnu_extend (Abis.tls_extend a) + else (Abis.tls_extend a) + | None -> failwith "output file does not conform to any known ABI" + )) + in + let make_linkable = (fun (it, opts) -> linkable_item_of_input_item_and_options a it opts) + in + let linkable_items_and_options = (Lem_list.map make_linkable items_and_options) + in + let names = (Lem_list.map + (string_of_triple instance_Show_Show_string_dict + instance_Show_Show_Input_list_input_blob_dict + (instance_Show_Show_tup2_dict + instance_Show_Show_Command_line_input_unit_dict + (instance_Show_Show_list_dict + instance_Show_Show_Input_list_origin_coord_dict))) input_items) + in + let maybe_symbolic_image = (correctly_linked a linkable_items_and_options names link_options1 eout) + in + let v = ((match maybe_symbolic_image with + None -> false + | Some img2 -> + (* generate some output, using the symbolic image we just got *) + let our_output_filename = (output_filename ^ ".test-out") + in + let f = (elf64_file_of_elf_memory_image a (fun x -> x) our_output_filename img2) + in + (match + bytes_of_elf64_file f >>= (fun bytes -> + Byte_sequence.serialise our_output_filename bytes) + with + Success _ -> true + | Fail s -> let _ = (print_endline ("error writing output: " ^ s)) in true + ) + )) + in + return (string_of_bool v)))) + in + (match res with + | Fail err -> prerr_endline ("[!]: " ^ err) + | Success e -> prerr_endline e + )) + + diff --git a/lib/ocaml_rts/linksem/memory_image.ml b/lib/ocaml_rts/linksem/memory_image.ml new file mode 100644 index 00000000..fa9d1535 --- /dev/null +++ b/lib/ocaml_rts/linksem/memory_image.ml @@ -0,0 +1,839 @@ +(*Generated by Lem from memory_image.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_map +(*import Map_extra*) +open Lem_set +open Lem_set_extra +open Multimap +open Lem_num +open Lem_maybe +open Lem_assert_extra +open Show + +open Byte_sequence +open Elf_file +open Elf_header +open Elf_interpreted_segment +open Elf_interpreted_section +open Elf_program_header_table +open Elf_section_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation + +open Missing_pervasives + +(* Now we can define memory images *) + +type byte_pattern_element = char option +type byte_pattern = byte_pattern_element list + +(* An element might have an address/offset, and it has some contents. *) +type element = { startpos : Nat_big_num.num option + ; length1 : Nat_big_num.num option + ; contents : byte_pattern + } + +(* HMM -- ideally I want to fold these into the memory image notion + * and the startpos thingy. *) +type allocated_symbols_map = (string, (Nat_big_num.num * Nat_big_num.num)) Pmap.map (* start, length *) + +(* Instead of modelling address calculations (in linker scripts) like so: + +type address_expr = natural -> allocated_symbols_map -> natural + ( pos -> environment -> result address ) + + ... we model it as expressions in terms of CursorPosition. HMM. +*) + +type expr_operand = Var of string + | CursorPosition (* only valid in certain expressions... HMM *) + | Constant of Nat_big_num.num + | UnOp of (expr_unary_operation * expr_operand) + | BinOp of (expr_binary_operation * expr_operand * expr_operand) +and +expr_unary_operation = Neg of expr_operand + | BitwiseInverse of expr_operand +and +expr_binary_operation = Add of (expr_operand * expr_operand) + | Sub of (expr_operand * expr_operand) + | BitwiseAnd of (expr_operand * expr_operand) + | BitwiseOr of (expr_operand * expr_operand) + +type expr_binary_relation = + Lt + | Lte + | Gt + | Gte + | Eq + | Neq + +type expr = + False + | True + | Not of expr + | And of (expr * expr) + | Or of (expr * expr) + | BinRel of (expr_binary_relation * expr_operand) (* LH operand is the expr's value *) + +(* +val cond_expr : expr -> expr -> expr -> expr +let cond_expr expr1 expr2 expr3 = (Or((And(expr1, expr2)), (And((Not(expr1)), expr3)))) +*) + +(* Memory image elements all have identities. For convenience + * we make the identities strings. The string contents are arbitrary, + * and only their equality is relevant, but choosing friendly names + * like "ELF header" is good practice.*) +type memory_image = (string, element) Pmap.map + +type range = Nat_big_num.num * Nat_big_num.num (* start, length *) + +type element_range = string * range + +(* An "element" of an ELF image, in the linking phase, is either a section, + * the ELF header, the section header table or the program header table. + * + * PROBLEM: We'd like to use section names as the identifiers + * for those elements that are sections. + * but we can't, because they are not guaranteed to be unique. + * + * SOLUTION: Names that are unique in the file are used as keys. + * If not unique, the sections are treated as anonymous and given + * gensym'd string ids (FIXME: implement this). + *) + +(* Currently, our elements have unique names, which are strings. + * We *don't* want to encode any meaning onto these strings. + * All meaning should be encoded into labelled ranges. + * We want to be able to look up + * + * - elements + * - ranges within elements + * + * ... by their *labels* -- or sometimes just *part* of their labels. + *) + +(* ELF file features with which we can label ranges of the memory image. *) +type elf_file_feature = + ElfHeader of elf64_header + | ElfSectionHeaderTable of elf64_section_header_table (* do we want to expand these? *) + | ElfProgramHeaderTable of elf64_program_header_table + | ElfSection of (Nat_big_num.num * elf64_interpreted_section) (* SHT idx *) + | ElfSegment of (Nat_big_num.num * elf64_interpreted_segment) (* PHT idx *) + +type symbol_definition + = { def_symname : string + ; def_syment : elf64_symbol_table_entry (* definition's symtab entry *) + ; def_sym_scn : Nat_big_num.num (* symtab section index, to disamiguate dynsym *) + ; def_sym_idx : Nat_big_num.num (* index of symbol into the symtab *) + ; def_linkable_idx : Nat_big_num.num (* used to propagate origin linkable information to linked image *) + } + +let symDefCompare x1 x2:int= +(quintupleCompare compare elf64_symbol_table_entry_compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare (x1.def_symname, x1.def_syment, x1.def_sym_scn, x1.def_sym_idx, x1.def_linkable_idx) + (x2.def_symname, x2.def_syment, x2.def_sym_scn, x2.def_sym_idx, x2.def_linkable_idx)) + +let instance_Basic_classes_Ord_Memory_image_symbol_definition_dict:(symbol_definition)ord_class= ({ + + compare_method = symDefCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(symDefCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (symDefCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(symDefCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (symDefCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +type symbol_reference + = { ref_symname : string (* symbol name *) + ; ref_syment : elf64_symbol_table_entry (* likely-undefined (referencing) symbol *) + ; ref_sym_scn : Nat_big_num.num (* symtab section idx *) + ; ref_sym_idx : Nat_big_num.num (* index into symbol table *) + } + +let symRefCompare x1 x2:int= +(quadrupleCompare compare elf64_symbol_table_entry_compare Nat_big_num.compare Nat_big_num.compare (x1.ref_symname, x1.ref_syment, x1.ref_sym_scn, x1.ref_sym_idx) + (x2.ref_symname, x2.ref_syment, x2.ref_sym_scn, x2.ref_sym_idx)) + +let instance_Basic_classes_Ord_Memory_image_symbol_reference_dict:(symbol_reference)ord_class= ({ + + compare_method = symRefCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(symRefCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (symRefCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(symRefCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (symRefCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +type reloc_site = { + ref_relent : elf64_relocation_a + ; ref_rel_scn : Nat_big_num.num (* the relocation section idx *) + ; ref_rel_idx : Nat_big_num.num (* the index of the relocation rec *) + ; ref_src_scn : Nat_big_num.num (* the section *from which* the reference logically comes *) +} + +let relocSiteCompare x1 x2:int= +(quadrupleCompare elf64_relocation_a_compare Nat_big_num.compare Nat_big_num.compare Nat_big_num.compare (x1.ref_relent, x1.ref_rel_scn, x1.ref_rel_idx, x1.ref_src_scn) + (x2.ref_relent, x2.ref_rel_scn, x2.ref_rel_idx, x2.ref_src_scn)) + +let instance_Basic_classes_Ord_Memory_image_reloc_site_dict:(reloc_site)ord_class= ({ + + compare_method = relocSiteCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(relocSiteCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (relocSiteCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(relocSiteCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (relocSiteCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +type reloc_decision = LeaveReloc + | ApplyReloc + | ChangeRelocTo of (Nat_big_num.num * symbol_reference * reloc_site) + (* | MakePIC -- is now a kind of ChangeRelocTo *) + +let relocDecisionCompare x1 x2:int= + ((match (x1, x2) with + | (LeaveReloc, LeaveReloc) -> 0 + | (LeaveReloc, _) -> (-1) + | (ApplyReloc, ApplyReloc) -> 0 + | (ApplyReloc, ChangeRelocTo _) -> (-1) + | (ApplyReloc, LeaveReloc) -> 1 + | (ChangeRelocTo t1, ChangeRelocTo t2) -> (tripleCompare Nat_big_num.compare symRefCompare relocSiteCompare t1 t2) + | (ChangeRelocTo _, _) -> 1 + )) + +let instance_Basic_classes_Ord_Memory_image_reloc_decision_dict:(reloc_decision)ord_class= ({ + + compare_method = relocDecisionCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(relocDecisionCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (relocDecisionCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(relocDecisionCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (relocDecisionCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +type symbol_reference_and_reloc_site = { + ref : symbol_reference + ; maybe_reloc : reloc_site option + ; maybe_def_bound_to : (reloc_decision * symbol_definition option)option + } + +let symRefAndRelocSiteCompare x1 x2:int= +(tripleCompare symRefCompare (maybeCompare relocSiteCompare) (maybeCompare (pairCompare relocDecisionCompare (maybeCompare symDefCompare))) (x1.ref, x1.maybe_reloc, x1.maybe_def_bound_to) + (x2.ref, x2.maybe_reloc, x2.maybe_def_bound_to)) + +let instance_Basic_classes_Ord_Memory_image_symbol_reference_and_reloc_site_dict:(symbol_reference_and_reloc_site)ord_class= ({ + + compare_method = symRefAndRelocSiteCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(symRefAndRelocSiteCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (symRefAndRelocSiteCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(symRefAndRelocSiteCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (symRefAndRelocSiteCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +(* We can also annotate arbitrary ranges of bytes within an element + * with arbitrary metadata. + * + * Ideally we want to data-abstract this a bit. But it's hard to do + * so without baking in ELF-specific and/or (moreover) per-ABI concepts, + * like PLTs and GOTs. Ideally we would use something like polymorphic + * variants here. For now, this has to be the union of all the concepts + * that we find in the various ABIs we care about. To avoid ELFy things + * creeping in, we parameterise by 'a, and instantiate the 'a with the + * relevant ELFy thing when we use it. OH, but then 'a is different for + * every distinct ELF thing, which is no good. Can we define a mapping + * from an umbrella "ELF" type to the relevant types in each case? *) +type 'abifeature range_tag = (* forall 'abifeature . *) + ImageBase + | EntryPoint + | SymbolDef of symbol_definition + | SymbolRef of symbol_reference_and_reloc_site + | FileFeature of elf_file_feature (* file feature other than symdef and reloc *) + | AbiFeature of 'abifeature + +type 'abifeature annotated_memory_image = { + elements : memory_image + ; by_range : (( element_range option) * ( 'abifeature range_tag)) Pset.set + ; by_tag : (( 'abifeature range_tag), ( element_range option)) multimap +} + +(*val get_empty_memory_image : forall 'abifeature. unit -> annotated_memory_image 'abifeature*) +let get_empty_memory_image:unit ->'abifeature annotated_memory_image= (fun _ -> { + elements = (Pmap.empty compare) + ; by_range = (Pset.empty (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare)) + ; by_tag = (Pset.empty (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))))) +}) + +(* Basic ELFy and ABI-y things. *) +(* "Special" sections are those that necessarily require special treatment by the + * linker. Examples include symbol tables and relocation tables. There are some + * grey areas, such as .eh_frame, debug info, and string tables. For us, the rule + * is that if we have special code to create them, i.e. that we don't rely on + * ordinary section concatenation during the linker script interpretation, they + * should be special -- it means strip_metadata_sections will remove them from + * the image, they won't be seen by the linker script, and that it's *our* job + * to reinstate them afterwards (as we do with symtab and strtab, for example). *) +(* FIXME: this shouldn't really be here, but needs to be in some low-lying module; + * keeping it out of elf_* for now to avoid duplication into elf64_, elf32_. *) +let elf_section_is_special s f:bool= (not (Nat_big_num.equal s.elf64_section_type sht_progbits) + && (not (Nat_big_num.equal s.elf64_section_type sht_nobits) + && (not (Nat_big_num.equal s.elf64_section_type sht_fini_array) + && not (Nat_big_num.equal s.elf64_section_type sht_init_array)))) + +(* This record collects things that ABIs may or must define. + * + * Since we want to put all ABIs in a list and select one at run time, + * we can't maintain a type-level distinction between ABIs; we have to + * use elf_memory_image any_abi_feature. To avoid a reference cycle, + * stay polymorphic in the ABI feature type until we define specific ABIs. + * In practice we'll use only any_abi_feature, because we need to pull + * the ABI out of a list at run time. + *) +type null_abi_feature = unit + +(* The reloc calculation is complicated, so we split up the big function + * type into smaller ones. *) + +(* Q. Do we want "existing", or is it a kind of addend? + * A. We do want it -- modelling both separately is necessary, + * because we model relocations bytewise, but some arches + * do bitfield relocations (think ARM). *) +type reloc_calculate_fn = Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num (* symaddr -> addend -> existing -> relocated *) + +type 'abifeature reloc_apply_fn = 'abifeature + (* elf memory image: the context in which the relocation is being applied *) + annotated_memory_image -> + (* the site address *) + Nat_big_num.num -> + (* Typically there are two symbol table entries involved in a relocation. + * One is the reference, and is usually undefined. + * The other is the definition, and is defined (else absent, when we use 0). + * However, sometimes the reference is itself a defined symbol. + * Almost always, if so, *that* symbol *is* "the definition". + * However, copy relocs are an exception. + * + * In the case of copy relocations being fixed up by the dynamic + * linker, the dynamic linker must figure out which definition to + * copy from. This can't be as simple as "the first definition in + * link order", because *our* copy of that symbol is a definition + * (typically in bss). It could be as simple as "the first *after us* + * in link order". FIXME: find the glibc code that does this. + * + * Can we dig this stuff out of the memory image? If we pass the address + * being relocated, we can find the tags. But I don't want to pass + * the symbol address until the very end. It seems better to pass the symbol + * name, since that's the key that the dynamic linker uses to look for + * other definitions. + * + * Do we want to pass a whole symbol_reference? This has not only the + * symbol name but also syment, scn and idx. The syment is usually UND, + * but *could* be defined (and is for copy relocs). The scn and idx are + * not relevant, but it seems cleaner to pass the whole thing anyway. + *) + symbol_reference_and_reloc_site -> + (* Should we pass a symbol_definition too? Implicitly, we pass part of it + * by passing the symaddr argument (below). I'd prefer not to depend on + * others -- relocation calculations should look like "mostly address + * arithmetic", i.e. only the weird ones do something else. *) + (* How wide, in bytes, is the relocated field? this may depend on img + * and on the wider image (copy relocs), so it's returned *by* the reloc function. *) + (Nat_big_num.num (* width *) * reloc_calculate_fn) + +(* Some kinds of relocation necessarily give us back a R_*_RELATIVE reloc. + * We don't record this explicitly. Instead, the "bool" is a flag recording whether + * the field represents an absolute address. + * Similarly, some relocations can "fail" according to their ABI manuals. + * This just means that the result can't be represented in the field width. + * We detect this when actually applying the reloc in the memory image content + * (done elsewhere). *) +type 'abifeature reloc_fn = Nat_big_num.num -> (bool * 'abifeature reloc_apply_fn) + +(*val noop_reloc_calculate : natural -> integer -> natural -> natural*) +let noop_reloc_calculate symaddr addend existing:Nat_big_num.num= existing + +(*val noop_reloc_apply : forall 'abifeature. reloc_apply_fn 'abifeature*) +let noop_reloc_apply img2 site_addr ref1:Nat_big_num.num*(Nat_big_num.num ->Nat_big_num.num ->Nat_big_num.num ->Nat_big_num.num)= (Nat_big_num.of_int 0, noop_reloc_calculate) + +(*val noop_reloc : forall 'abifeature. natural -> (bool (* result is absolute addr *) * reloc_apply_fn 'abifeature)*) +let noop_reloc k:bool*('abifeature annotated_memory_image ->Nat_big_num.num ->symbol_reference_and_reloc_site ->Nat_big_num.num*reloc_calculate_fn)= (false, noop_reloc_apply) + +type 'abifeature abi = (* forall 'abifeature. *) + { is_valid_elf_header : elf64_header -> bool (* doesn't this generalise outrageously? is_valid_elf_file? *) + ; make_elf_header : Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num -> elf64_header + (* t entry shoff phoff phnum shnum shstrndx *) + ; reloc : 'abifeature reloc_fn + ; section_is_special : elf64_interpreted_section -> 'abifeature annotated_memory_image -> bool + ; section_is_large : elf64_interpreted_section -> 'abifeature annotated_memory_image -> bool + ; maxpagesize : Nat_big_num.num + ; minpagesize : Nat_big_num.num + ; commonpagesize : Nat_big_num.num + ; symbol_is_generated_by_linker : string -> bool + (*; link_inputs_tap : + ; link_output_sections_tap : + ; link_output_image_tap : *) + ; make_phdrs : Nat_big_num.num -> Nat_big_num.num -> Nat_big_num.num (* file type *) -> 'abifeature annotated_memory_image -> elf64_interpreted_section list -> elf64_program_header_table_entry list + ; max_phnum : Nat_big_num.num + ; guess_entry_point : 'abifeature annotated_memory_image -> Nat_big_num.num option + ; pad_data : Nat_big_num.num -> char list + ; pad_code : Nat_big_num.num -> char list + ; generate_support : (string * 'abifeature annotated_memory_image) (* list (list reloc_site_resolution) -> *)list -> 'abifeature annotated_memory_image + ; concretise_support : 'abifeature annotated_memory_image -> 'abifeature annotated_memory_image + ; get_reloc_symaddr : symbol_definition -> 'abifeature annotated_memory_image -> reloc_site option -> Nat_big_num.num + } + +(*val align_up_to : natural -> natural -> natural*) +let align_up_to align addr:Nat_big_num.num= + (let quot = (Nat_big_num.div addr align) + in + if Nat_big_num.equal (Nat_big_num.mul quot align) addr then addr else Nat_big_num.mul ( Nat_big_num.add quot(Nat_big_num.of_int 1)) align) + +(*val round_down_to : natural -> natural -> natural*) +let round_down_to align addr:Nat_big_num.num= + (let quot = (Nat_big_num.div addr align) + in Nat_big_num.mul + quot align) + +(*val uint32_max : natural*) +let uint32_max:Nat_big_num.num= (Nat_big_num.sub_nat ( Nat_big_num.pow_int(Nat_big_num.of_int 2)( 32))(Nat_big_num.of_int 1)) + +(*val uint64_max : natural*) +let uint64_max:Nat_big_num.num= (Nat_big_num.add (Nat_big_num.sub_nat (Nat_big_num.mul + (* HACK around Lem's inability to parse 18446744073709551615: + * the square of uint32_max is + * (2**32 - 1) (2**32 - 1) + * i.e. 2**64 - 2**32 - 2**32 + 1 + * So + * 2**64 - 1 = uint32_max * uint32_max + 2**32 + 2**32 - 2 + *) + uint32_max uint32_max)(Nat_big_num.of_int 2)) (Nat_big_num.pow_int(Nat_big_num.of_int 2)( 33))) + (* 18446744073709551615 *) (* i.e. 0x ffff ffff ffff ffff *) + (* HMM. This still overflows int64 *) + +(* The 2's complement of a value, at 64-bit width *) +(*val compl64 : natural -> natural*) +let compl64 v:Nat_big_num.num= (Nat_big_num.add(Nat_big_num.of_int 1) (Nat_big_num.bitwise_xor v uint64_max)) + +(*val gcd : natural -> natural -> natural*) +let rec gcd a b:Nat_big_num.num= + (if Nat_big_num.equal b(Nat_big_num.of_int 0) then a else gcd b ( Nat_big_num.modulus a b)) + +(*val lcm : natural -> natural -> natural*) +let lcm a b:Nat_big_num.num= (Nat_big_num.div + (* let _ = errln ("lcm of " ^ (show a) ^ " and " ^ (show b) ^ "?") + in *) + ( Nat_big_num.mul a b) (gcd a b)) + +(*val address_of_range : forall 'abifeature. element_range -> annotated_memory_image 'abifeature -> natural*) +let address_of_range el_range img2:Nat_big_num.num= + (let (el_name, (start, len)) = el_range + in + (match Pmap.lookup el_name img2.elements with + Some el -> + (match el.startpos with + Some addr -> Nat_big_num.add addr start + | None -> failwith "address_of_range called for element with no address" + ) + | None -> failwith "address_of_range called on nonexistent element" + )) + +(*val range_contains : (natural * natural) -> (natural * natural) -> bool*) +let range_contains (r1begin, r1len) (r2begin, r2len):bool= (Nat_big_num.greater_equal + (* r1 is at least as big as r2 *) + r2begin r1begin && Nat_big_num.less_equal ( Nat_big_num.add r2begin r2len) ( Nat_big_num.add r1begin r1len)) + +(*val range_overlaps : (natural * natural) -> (natural * natural) -> bool*) +let range_overlaps (r1begin, r1len) (r2begin, r2len):bool= + (( Nat_big_num.less r1begin ( Nat_big_num.add r2begin r2len) && Nat_big_num.greater ( Nat_big_num.add r1begin r1len) r2begin) + || ( Nat_big_num.less r2begin ( Nat_big_num.add r1begin r1len) && Nat_big_num.greater ( Nat_big_num.add r2begin r2len) r1begin)) + +(*val is_partition : list (natural * natural) -> list (natural * natural) -> bool*) +let is_partition rs ranges:bool= +( + (* 1. each element of the first list falls entirely within some element + * from the second list. *)let r_is_contained_by_some_range + = (fun r -> List.fold_left (||) false (Lem_list.map (fun range1 -> range_contains range1 r) ranges)) + in + List.for_all (fun r -> r_is_contained_by_some_range r) rs + && + (* 2. elements of the first list do not overlap *) + List.for_all (fun r -> List.for_all (fun r2 -> ( (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal r (* should be "=="? *) r2)) || (not (range_overlaps r r2))) rs) rs) + +(*val nat_range : natural -> natural -> list natural*) +let rec nat_range base len:(Nat_big_num.num)list= + ( + if(Nat_big_num.equal len (Nat_big_num.of_int 0)) then ([]) else + (base :: + (nat_range ( Nat_big_num.add base (Nat_big_num.of_int 1)) + ( Nat_big_num.sub_nat len (Nat_big_num.of_int 1))))) + +(* Expand a sorted list of ranges into a list of bool, where the list contains + * true if its index is included in one or more ranges, else false. *) +(*val expand_sorted_ranges : list (natural * natural) -> natural -> list bool -> list bool*) +let rec expand_sorted_ranges sorted_ranges min_length accum:(bool)list= + ((match sorted_ranges with + [] -> List.rev_append (List.rev accum) ( + let pad_length = (Nat_big_num.max(Nat_big_num.of_int 0) ( Nat_big_num.sub_nat min_length (Missing_pervasives.length accum))) + in + (* let _ = Missing_pervasives.errln ( + "padding ranges cares list with " ^ (show pad_length) ^ + " cares (accumulated " ^ (show (Missing_pervasives.length accum)) ^ + ", min length " ^ (show min_length) ^ ")") + in *) + Missing_pervasives.replicate0 pad_length true) + | (base, len) :: more -> + (* pad the accum so that it reaches up to base *) + let up_to_base = (Missing_pervasives.replicate0 ( Nat_big_num.sub_nat base (Missing_pervasives.length accum)) true) + in + let up_to_end_of_range = (List.rev_append (List.rev up_to_base) (Missing_pervasives.replicate0 len false)) + in + expand_sorted_ranges more min_length ( List.rev_append (List.rev accum) up_to_end_of_range) + )) + +(*val expand_unsorted_ranges : list (natural * natural) -> natural -> list bool -> list bool*) +let rec expand_unsorted_ranges unsorted_ranges min_length accum:(bool)list= + (expand_sorted_ranges (insertSortBy (fun (base1, len1) -> (fun (base2, len2) -> Nat_big_num.less base1 base2)) unsorted_ranges) min_length accum) + +(*val make_byte_pattern_revacc : list (maybe byte) -> list byte -> list bool -> list (maybe byte)*) +let rec make_byte_pattern_revacc revacc bytes cares:((char)option)list= + ((match bytes with + [] -> List.rev revacc + | b :: bs -> (match cares with + care :: more -> make_byte_pattern_revacc ((if not care then None else Some b) :: revacc) bs more + | _ -> failwith "make_byte_pattern: unequal length" + ) + )) + +(*val make_byte_pattern : list byte -> list bool -> list (maybe byte)*) +let rec make_byte_pattern bytes cares:((char)option)list= + (make_byte_pattern_revacc [] bytes cares) + +(*val relax_byte_pattern_revacc : list (maybe byte) -> list (maybe byte) -> list bool -> list (maybe byte)*) +let rec relax_byte_pattern_revacc revacc bytes cares:((char)option)list= + ((match bytes with + [] -> List.rev revacc + | b :: bs -> (match cares with + care :: more -> relax_byte_pattern_revacc ((if not care then None else b) :: revacc) bs more + | _ -> failwith ("relax_byte_pattern: unequal length") + ) + )) + +(*val relax_byte_pattern : list (maybe byte) -> list bool -> list (maybe byte)*) +let rec relax_byte_pattern bytes cares:((char)option)list= + (relax_byte_pattern_revacc [] bytes cares) + +type pad_fn = Nat_big_num.num -> char list + +(*val concretise_byte_pattern : list byte -> natural -> list (maybe byte) -> pad_fn -> list byte*) +let rec concretise_byte_pattern rev_acc acc_pad bs pad:(char)list= + ((match bs with + [] -> + let padding_bytes = (if Nat_big_num.greater acc_pad(Nat_big_num.of_int 0) then pad acc_pad else []) + in List.rev ( List.rev_append (List.rev (List.rev padding_bytes)) rev_acc) + | Some(b) :: more -> + (* flush accumulated padding *) + let padding_bytes = (if Nat_big_num.greater acc_pad(Nat_big_num.of_int 0) then pad acc_pad else []) + in + concretise_byte_pattern (b :: ( List.rev_append (List.rev (List.rev padding_bytes)) rev_acc))(Nat_big_num.of_int 0) more pad + | None :: more -> + concretise_byte_pattern rev_acc (Nat_big_num.add acc_pad(Nat_big_num.of_int 1)) more pad + )) + +(*val byte_option_matches_byte : maybe byte -> byte -> bool*) +let byte_option_matches_byte optb b:bool= + ((match optb with + None -> true + | Some some -> some = b + )) + +(*val byte_list_matches_pattern : list (maybe byte) -> list byte -> bool*) +let rec byte_list_matches_pattern pattern bytes:bool= + ((match pattern with + [] -> true + | optbyte :: more -> (match bytes with + [] -> false + | abyte :: morebytes -> + byte_option_matches_byte optbyte abyte + && byte_list_matches_pattern more morebytes + ) + )) + +(*val append_to_byte_pattern_at_offset : natural -> list (maybe byte) -> list (maybe byte) -> list (maybe byte)*) +let append_to_byte_pattern_at_offset offset pat1 pat2:((char)option)list= + (let pad_length = (Nat_big_num.sub_nat offset (Missing_pervasives.length pat1)) + in + if Nat_big_num.less pad_length(Nat_big_num.of_int 0) then failwith "can't append at offset already used" + else List.rev_append (List.rev (List.rev_append (List.rev pat1) (Lem_list.replicate (Nat_big_num.to_int pad_length) None))) pat2) + +(*val accum_pattern_possible_starts_in_one_byte_sequence : list (maybe byte) -> nat -> list byte -> nat -> natural -> list natural -> list natural*) +let rec accum_pattern_possible_starts_in_one_byte_sequence pattern pattern_len seq seq_len offset accum:(Nat_big_num.num)list= +( + (* let _ = Missing_pervasives.errs ("At offset " ^ (show offset) ^ "... ") + in *)(match pattern with + [] -> (* let _ = Missing_pervasives.errs ("terminating with hit (empty pattern)\n") in *) + offset :: accum + | bpe :: more_bpes -> (* nonempty, so check for nonempty seq *) + (match seq with + [] -> (*let _ = Missing_pervasives.errs ("terminating with miss (empty pattern)\n") + in *) accum (* ran out of bytes in the sequence, so no match *) + | byte1 :: more_bytes -> let matched_this_byte = + (byte_option_matches_byte bpe byte1) + in + (* let _ = Missing_pervasives.errs ("Byte " ^ (show byte) ^ " matched " ^ (show byte_pattern) ^ "? " ^ (show matched_this_byte) ^ "; ") + in *) + let sequence_long_enough = (seq_len >= pattern_len) + in + (* let _ = Missing_pervasives.errs ("enough bytes remaining (" ^ (show seq_len) ^ ") to match rest of pattern (" ^ (show pattern_len) ^ ")? " ^ (show sequence_long_enough) ^ "; ") + in *) + let matched_here = (matched_this_byte && (sequence_long_enough && + byte_list_matches_pattern more_bpes more_bytes)) + in + (* let _ = Missing_pervasives.errs ("matched pattern anchored here? " ^ (show matched_this_byte) ^ "\n") + in *) + accum_pattern_possible_starts_in_one_byte_sequence + pattern pattern_len + more_bytes ( Nat_num.nat_monus seq_len( 1)) + ( Nat_big_num.add offset(Nat_big_num.of_int 1)) + (if matched_here then offset :: accum else accum) + ) + )) + +let swap_pairs dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b s:('a*'b)Pset.set= (let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_b.setElemCompare_method) []) in Pset.fold (fun(k, v) x2 -> if true then Pset.add (v, k) x2 else x2) s x2) + +let by_range_from_by_tag dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b:('a*'b)Pset.set ->('b*'a)Pset.set= + (swap_pairs dict_Basic_classes_SetType_b dict_Basic_classes_SetType_a) + +let by_tag_from_by_range dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b:('a*'b)Pset.set ->('b*'a)Pset.set= + (swap_pairs dict_Basic_classes_SetType_b dict_Basic_classes_SetType_a) + +(*val filter_elements : forall 'abifeature. ((string * element) -> bool) -> + annotated_memory_image 'abifeature -> annotated_memory_image 'abifeature*) +let filter_elements pred img2:'abifeature annotated_memory_image= + (let new_elements = (Lem_map.fromList + (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) (let x2 = ([]) in List.fold_right + (fun(n, r) x2 -> + if + let result = (pred (n, r)) in + if not result then + (*let _ = Missing_pervasives.outln ("Discarding element named " ^ n) in*) result + else result then (n, r) :: x2 else x2) + (Pset.elements + ((Pmap.bindings (pairCompare compare compare) img2.elements))) + x2)) + in + let new_by_range = (Pset.filter (fun (maybe_range, tag) -> (match maybe_range with + None -> true + | Some (el_name, el_range) -> Pset.mem el_name (Pmap.domain new_elements) + )) img2.by_range) + in + let new_by_tag = (let x2 =(Pset.from_list (pairCompare compare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)))) + []) in Pset.fold (fun(k, v) x2 -> if true then Pset.add (v, k) x2 else x2) + new_by_range x2) + in + { elements = new_elements + ; by_range = new_by_range + ; by_tag = new_by_tag + }) + +(*val tag_image : forall 'abifeature. range_tag 'abifeature -> string -> natural -> natural -> annotated_memory_image 'abifeature + -> annotated_memory_image 'abifeature*) +let tag_image t el_name el_offset tag_len img2:'abifeature annotated_memory_image= + (let (k, v) = (Some (el_name, (el_offset, tag_len)), t) + in + let new_by_range = (Pset.add (k, v) img2.by_range) + in + let new_by_tag = (Pset.add (v, k) img2.by_tag) + in + { elements = (img2.elements) + ; by_range = new_by_range + ; by_tag = new_by_tag + }) + +(*val address_to_element_and_offset : forall 'abifeature. natural -> annotated_memory_image 'abifeature -> maybe (string * natural)*) +let address_to_element_and_offset query_addr img2:(string*Nat_big_num.num)option= +( + (* Find the element with the highest address <= addr. + * What about zero-length elements? + * Break ties on the bigger size. *)let (maybe_highest_le : (Nat_big_num.num * string * element)option) + = (List.fold_left (fun maybe_current_max_le -> (fun (el_name, el_rec) -> + (*let _ = errln ("Saw element named `" ^ el_name ^ " with startpos " ^ ( + (match el_rec.startpos with Just addr -> ("0x" ^ (hex_string_of_natural addr)) | Nothing -> "(none)" end) + ^ " and length " ^ + (match el_rec.length with Just len -> ("0x" ^ (hex_string_of_natural len)) | Nothing -> "(none)" end) + )) + in*) + (match (maybe_current_max_le, el_rec.startpos) with + (None, None) -> None + | (None, Some this_element_pos) -> if Nat_big_num.less_equal this_element_pos query_addr + then Some (this_element_pos, el_name, el_rec) + else None + | (Some (cur_max_le, cur_el_name, cur_el_rec), None) -> maybe_current_max_le + | (Some (cur_max_le, cur_el_name, cur_el_rec), Some this_element_pos) -> if Nat_big_num.less_equal this_element_pos query_addr + && ( Nat_big_num.greater this_element_pos cur_max_le + || ( Nat_big_num.equal this_element_pos cur_max_le + && ( (Lem.option_equal Nat_big_num.equal cur_el_rec.length1 (Some(Nat_big_num.of_int 0)))))) + then Some (this_element_pos, el_name, el_rec) + else maybe_current_max_le + ) + )) None (Pmap.bindings_list img2.elements)) + in + (match maybe_highest_le with + Some (el_def_startpos, el_name, el_rec) -> + (* final sanity check: is the length definite, and if so, does the + * element span far enough? *) + (match el_rec.length1 with + Some l -> if Nat_big_num.greater_equal (Nat_big_num.add el_def_startpos l) query_addr + then Some (el_name, Nat_big_num.sub_nat query_addr el_def_startpos) + else + (*let _ = errln ("Discounting " ^ el_name ^ " because length is too short") in*) None + | None -> (*let _ = errln ("Gave up because element has unknown length") in*) None + ) + | None -> + (* no elements with a low enough assigned address, so nothing *) + (*let _ = errln ("Found no elements with low enough address") in*) None + )) + +(*val element_and_offset_to_address : forall 'abifeature. (string * natural) -> annotated_memory_image 'abifeature -> maybe natural*) +let element_and_offset_to_address (el_name, el_off) img2:(Nat_big_num.num)option= + ((match Pmap.lookup el_name img2.elements with + Some el -> (match el.startpos with + Some addr -> Some ( Nat_big_num.add addr el_off) + | None -> None + ) + | None -> failwith ("error: nonexistent element: " ^ el_name) + )) + +let null_symbol_reference:symbol_reference= ({ + ref_symname = "" + ; ref_syment = elf64_null_symbol_table_entry + ; ref_sym_scn =(Nat_big_num.of_int 0) + ; ref_sym_idx =(Nat_big_num.of_int 0) +}) + +let null_elf_relocation_a:elf64_relocation_a= + ({ elf64_ra_offset = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_ra_info = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_ra_addend = (Nat_big_num.to_int64(Nat_big_num.of_int 0)) + }) + + +let null_symbol_reference_and_reloc_site:symbol_reference_and_reloc_site= ({ + ref = null_symbol_reference + ; maybe_reloc = + (Some { ref_relent = null_elf_relocation_a + ; ref_rel_scn =(Nat_big_num.of_int 0) + ; ref_rel_idx =(Nat_big_num.of_int 0) + ; ref_src_scn =(Nat_big_num.of_int 0) + }) + ; maybe_def_bound_to = None + }) + +let null_symbol_definition:symbol_definition= ({ + def_symname = "" + ; def_syment = elf64_null_symbol_table_entry + ; def_sym_scn =(Nat_big_num.of_int 0) + ; def_sym_idx =(Nat_big_num.of_int 0) + ; def_linkable_idx =(Nat_big_num.of_int 0) +}) + +(*val pattern_possible_starts_in_one_byte_sequence : list (maybe byte) -> list byte -> natural -> list natural*) +let pattern_possible_starts_in_one_byte_sequence pattern seq offset:(Nat_big_num.num)list= +( + (* let _ = Missing_pervasives.errs ("Looking for matches of " ^ + (show (List.length pattern)) ^ "-byte pattern in " ^ (show (List.length seq)) ^ "-byte region\n") + in *)accum_pattern_possible_starts_in_one_byte_sequence pattern (List.length pattern) seq (List.length seq) offset []) + +(*val byte_pattern_of_byte_sequence : byte_sequence -> list (maybe byte)*) +let byte_pattern_of_byte_sequence seq:((char)option)list= ((match seq with + Sequence(bs) -> Lem_list.map (fun b -> Some b) bs +)) + +(*val compute_virtual_address_adjustment : natural -> natural -> natural -> natural*) +let compute_virtual_address_adjustment max_page_size offset vaddr:Nat_big_num.num= (Nat_big_num.modulus + ( Nat_big_num.sub_nat vaddr offset) max_page_size) + +(*val extract_natural_field : natural -> element -> natural -> natural*) +let extract_natural_field width element1 offset:Nat_big_num.num= +( + (* Read n bytes from the contents *)let maybe_bytes = (take0 width (drop0 offset element1.contents)) + in + let bytes = (Lem_list.map (fun mb -> (match mb with None -> Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 0)) | Some mb -> mb )) maybe_bytes) + in + (* FIXME: do we want little- or big-endian? *) + List.fold_left (fun acc -> fun next_byte -> Nat_big_num.add (Nat_big_num.mul + acc(Nat_big_num.of_int 256)) (Nat_big_num.of_int (Char.code next_byte)) + ) (Nat_big_num.of_int 0 : Nat_big_num.num) bytes) + +(*val natural_to_le_byte_list : natural -> list byte*) +let rec natural_to_le_byte_list n:(char)list= + ((Char.chr (Nat_big_num.to_int ( Nat_big_num.modulus n(Nat_big_num.of_int 256)))) :: (let d =(Nat_big_num.div n(Nat_big_num.of_int 256)) in if Nat_big_num.equal d(Nat_big_num.of_int 0) then [] else natural_to_le_byte_list ( Nat_big_num.div n(Nat_big_num.of_int 256)))) + +(*val natural_to_le_byte_list_padded_to : natural -> natural -> list byte*) +let rec natural_to_le_byte_list_padded_to width n:(char)list= + (let bytes = (natural_to_le_byte_list n) + in + List.rev_append (List.rev bytes) (replicate0 ( Nat_big_num.sub_nat width (length bytes)) (Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 0))))) + +(*val n2i : natural -> integer*) +let n2i:Nat_big_num.num ->Nat_big_num.num= (fun n-> n) + +(*val i2n: integer -> natural*) +let i2n:Nat_big_num.num ->Nat_big_num.num= Nat_big_num.abs + +(*val i2n_signed : nat -> integer -> natural*) +let i2n_signed width i:Nat_big_num.num= + (if Nat_big_num.greater_equal i(Nat_big_num.of_int 0) then + if Nat_big_num.greater_equal i (Nat_big_num.pow_int(Nat_big_num.of_int 2) (Nat_num.nat_monus width( 1))) then failwith "overflow" + else Nat_big_num.abs i + else + (* We manually encode the 2's complement of the negated value *) + let negated = (Nat_big_num.abs ( Nat_big_num.sub(Nat_big_num.of_int 0) i)) in + let (xormask : Nat_big_num.num) = ( Nat_big_num.sub_nat (Nat_big_num.pow_int(Nat_big_num.of_int 2) width)(Nat_big_num.of_int 1)) in + let compl = (Nat_big_num.add(Nat_big_num.of_int 1) (Nat_big_num.bitwise_xor negated xormask)) + in + (*let _ = errln ("Signed value " ^ (show i) ^ " is 2's-compl'd to 0x" ^ (hex_string_of_natural compl)) + in*) compl) + +(*val to_le_signed_bytes : natural -> integer -> list byte*) +let to_le_signed_bytes bytewidth i:(char)list= + (natural_to_le_byte_list_padded_to bytewidth (i2n_signed (Nat_big_num.to_int (Nat_big_num.mul(Nat_big_num.of_int 8)bytewidth)) i)) + +(*val to_le_unsigned_bytes : natural -> integer -> list byte*) +let to_le_unsigned_bytes bytewidth i:(char)list= + (natural_to_le_byte_list_padded_to bytewidth (Nat_big_num.abs i)) + +(*val write_natural_field : natural -> natural -> element -> natural -> element*) +let write_natural_field new_field_value width element1 offset:element= + (let pre_bytes = (take0 offset element1.contents) + in + let post_bytes = (drop0 ( Nat_big_num.add offset width) element1.contents) + in + (* FIXME: avoid hard-coding little-endian *) + let field_bytes = (natural_to_le_byte_list new_field_value) + in + if Nat_big_num.greater (length field_bytes) width then failwith "internal error: relocation output unrepresentable" + else + { + contents = (List.rev_append (List.rev (List.rev_append (List.rev (List.rev_append (List.rev pre_bytes) (let x2 = + ([]) in List.fold_right (fun b x2 -> if true then Some b :: x2 else x2) field_bytes + x2))) (replicate0 ( Nat_big_num.sub_nat width (length field_bytes)) (Some (Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 0))))))) post_bytes) + ; startpos = (element1.startpos) + ; length1 = (element1.length1) + }) diff --git a/lib/ocaml_rts/linksem/memory_image_orderings.ml b/lib/ocaml_rts/linksem/memory_image_orderings.ml new file mode 100644 index 00000000..ffde4184 --- /dev/null +++ b/lib/ocaml_rts/linksem/memory_image_orderings.ml @@ -0,0 +1,329 @@ +(*Generated by Lem from memory_image_orderings.lem.*) +open Lem_basic_classes +open Lem_function +open Lem_string +open Lem_tuple +open Lem_bool +open Lem_list +open Lem_sorting +open Lem_map +open Lem_set +open Multimap +open Lem_num +open Lem_maybe +open Lem_assert_extra +open Show + +open Byte_sequence +open Elf_file +open Elf_header +open Elf_interpreted_segment +open Elf_interpreted_section +open Elf_program_header_table +open Elf_section_header_table +open Elf_symbol_table +open Elf_types_native_uint +open Elf_relocation +open Memory_image +open Abi_classes +(* open import Abis *) + +open Missing_pervasives + +(*val elfFileFeatureCompare : elf_file_feature -> elf_file_feature -> Basic_classes.ordering*) +let elfFileFeatureCompare f1 f2:int= +( + (* order is: *)(match (f1, f2) with + (ElfHeader(x1), ElfHeader(x2)) -> (* equal tags, so ... *) elf64_header_compare x1 x2 + | (ElfHeader(x1), _) -> (-1) + | (ElfSectionHeaderTable(x1), ElfHeader(x2)) -> 1 + | (ElfSectionHeaderTable(x1), ElfSectionHeaderTable(x2)) -> ( (* equal tags, so ... *)lexicographic_compare compare_elf64_section_header_table_entry x1 x2) + | (ElfSectionHeaderTable(x1), _) -> (-1) + | (ElfProgramHeaderTable(x1), ElfHeader(x2)) -> 1 + | (ElfProgramHeaderTable(x1), ElfSectionHeaderTable(x2)) -> 1 + | (ElfProgramHeaderTable(x1), ElfProgramHeaderTable(x2)) -> (lexicographic_compare compare_elf64_program_header_table_entry x1 x2) + | (ElfProgramHeaderTable(x1), _) -> (-1) + | (ElfSection(x1), ElfHeader(x2)) -> 1 + | (ElfSection(x1), ElfSectionHeaderTable(x2)) -> 1 + | (ElfSection(x1), ElfProgramHeaderTable(x2)) -> 1 + | (ElfSection(x1), ElfSection(x2)) -> (pairCompare Nat_big_num.compare compare_elf64_interpreted_section x1 x2) + | (ElfSection(x1), _) -> (-1) + | (ElfSegment(x1), ElfHeader(x2)) -> 1 + | (ElfSegment(x1), ElfSectionHeaderTable(x2)) -> 1 + | (ElfSegment(x1), ElfProgramHeaderTable(x2)) -> 1 + | (ElfSegment(x1), ElfSection(x2)) -> 1 + | (ElfSegment(x1), ElfSegment(x2)) -> (pairCompare Nat_big_num.compare compare_elf64_interpreted_segment x1 x2) + | (ElfSegment(x1), _) -> (-1) + )) + +(*val elfFileFeatureTagEquiv : elf_file_feature -> elf_file_feature -> bool*) +let elfFileFeatureTagEquiv f1 f2:bool= +( + (* order is: *)(match (f1, f2) with + (ElfHeader(x1), ElfHeader(x2)) -> (* equal tags, so ... *) true + | (ElfSectionHeaderTable(x1), ElfSectionHeaderTable(x2)) -> true + | (ElfProgramHeaderTable(x1), ElfProgramHeaderTable(x2)) -> true + | (ElfSection(x1), ElfSection(x2)) -> true + | (ElfSegment(x1), ElfSegment(x2)) -> true + | (_, _) -> false + )) + +let instance_Basic_classes_Ord_Memory_image_elf_file_feature_dict:(elf_file_feature)ord_class= ({ + + compare_method = elfFileFeatureCompare; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elfFileFeatureCompare f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elfFileFeatureCompare f1 f2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(elfFileFeatureCompare f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> Pset.mem (elfFileFeatureCompare f1 f2)(Pset.from_list compare [1; 0])))}) + +(*val tagCompare : forall 'abifeature. Ord 'abifeature => + range_tag 'abifeature -> range_tag 'abifeature -> Basic_classes.ordering*) +let tagCompare dict_Basic_classes_Ord_abifeature k1 k2:int= + ((match (k1, k2) with + (ImageBase, ImageBase) -> 0 + | (ImageBase, _) -> (-1) + | (EntryPoint, ImageBase) -> 1 + | (EntryPoint, EntryPoint) -> 0 + | (EntryPoint, _) -> (-1) + | (SymbolDef(_), ImageBase) -> 1 + | (SymbolDef(_), EntryPoint) -> 1 + | (SymbolDef(x1), SymbolDef(x2)) -> symDefCompare x1 x2 + | (SymbolDef(_), _) -> (-1) + | (SymbolRef(_), ImageBase) -> 1 + | (SymbolRef(_), EntryPoint) -> 1 + | (SymbolRef(_), SymbolDef(_)) -> 1 + | (SymbolRef(x1), SymbolRef(x2)) -> symRefAndRelocSiteCompare x1 x2 + | (SymbolRef(_), _) -> (-1) + | (FileFeature(_), ImageBase) -> 1 + | (FileFeature(_), EntryPoint) -> 1 + | (FileFeature(_), SymbolDef(_)) -> 1 + | (FileFeature(_), SymbolRef(_)) -> 1 + | (FileFeature(x1), FileFeature(x2)) -> elfFileFeatureCompare x1 x2 + | (FileFeature(_), _) -> (-1) + | (AbiFeature(_), ImageBase) -> 1 + | (AbiFeature(_), EntryPoint) -> 1 + | (AbiFeature(_), SymbolDef(_)) -> 1 + | (AbiFeature(_), SymbolRef(_)) -> 1 + | (AbiFeature(_), FileFeature(_)) -> 1 + | (AbiFeature(x1), AbiFeature(x2)) -> + dict_Basic_classes_Ord_abifeature.compare_method x1 x2 + | (AbiFeature(_), _) -> (-1) + )) + +let instance_Basic_classes_Ord_Memory_image_range_tag_dict dict_Basic_classes_Ord_abifeature:('abifeature range_tag)ord_class= ({ + + compare_method = + (tagCompare dict_Basic_classes_Ord_abifeature); + + isLess_method = (fun tag1 -> (fun tag2 -> ( Lem.orderingEqual(tagCompare + dict_Basic_classes_Ord_abifeature tag1 tag2) (-1)))); + + isLessEqual_method = (fun tag1 -> (fun tag2 -> Pset.mem (tagCompare + dict_Basic_classes_Ord_abifeature tag1 tag2)(Pset.from_list compare [(-1); 0]))); + + isGreater_method = (fun tag1 -> (fun tag2 -> ( Lem.orderingEqual(tagCompare + dict_Basic_classes_Ord_abifeature tag1 tag2) 1))); + + isGreaterEqual_method = (fun tag1 -> (fun tag2 -> Pset.mem (tagCompare + dict_Basic_classes_Ord_abifeature tag1 tag2)(Pset.from_list compare [1; 0])))}) + +(*val tagEquiv : forall 'abifeature. AbiFeatureTagEquiv 'abifeature => range_tag 'abifeature -> range_tag 'abifeature -> bool*) +let tagEquiv dict_Abi_classes_AbiFeatureTagEquiv_abifeature k1 k2:bool= + ((match (k1, k2) with + (ImageBase, ImageBase) -> true + | (EntryPoint, EntryPoint) -> true + | (SymbolDef(x1), SymbolDef(x2)) -> true + | (SymbolRef(_), SymbolRef(_)) -> true + | (FileFeature(x1), FileFeature(x2)) -> elfFileFeatureTagEquiv x1 x2 + | (AbiFeature(x1), AbiFeature(x2)) -> + dict_Abi_classes_AbiFeatureTagEquiv_abifeature.abiFeatureTagEquiv_method x1 x2 + | (_, _) -> false + )) + +(* ------- end of Ord / compare / ConstructorToNaturalList functions *) + + +(*val unique_tag_matching : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => range_tag 'abifeature -> annotated_memory_image 'abifeature -> range_tag 'abifeature*) +let unique_tag_matching dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature tag img2:'abifeature range_tag= + ((match Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + dict_Basic_classes_Ord_abifeature) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (tagEquiv dict_Abi_classes_AbiFeatureTagEquiv_abifeature) tag img2.by_tag with + [] -> failwith "no tag match found" + | [(t, r)] -> t + | x -> failwith ("more than one tag match") (* (ranges: " ^ + (show (List.map (fun (t, r) -> r) x)) + ^ ") when asserted unique")" *) + )) + +(*val tagged_ranges_matching_tag : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => range_tag 'abifeature -> annotated_memory_image 'abifeature -> list (range_tag 'abifeature * maybe element_range)*) +let tagged_ranges_matching_tag dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature tag img2:('abifeature range_tag*(element_range)option)list= + (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Memory_image_range_tag_dict + dict_Basic_classes_Ord_abifeature) (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) (tagEquiv dict_Abi_classes_AbiFeatureTagEquiv_abifeature) tag img2.by_tag) + +(*val element_range_compare : element_range -> element_range -> Basic_classes.ordering*) +let element_range_compare:string*(Nat_big_num.num*Nat_big_num.num) ->string*(Nat_big_num.num*Nat_big_num.num) ->int= (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare)) + +(*val unique_tag_matching_at_range_exact : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => + maybe element_range + -> range_tag 'abifeature + -> annotated_memory_image 'abifeature + -> range_tag 'abifeature*) +let unique_tag_matching_at_range_exact dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature r tag img2:'abifeature range_tag= +( + (* 1. find tags a unique range labelled as ELF section header table. *)let (_, (allRangeMatches : ( 'abifeature range_tag) list)) = (List.split (Multimap.lookupBy0 + (instance_Basic_classes_Ord_Maybe_maybe_dict + (instance_Basic_classes_Ord_tup2_dict + Lem_string_extra.instance_Basic_classes_Ord_string_dict + (instance_Basic_classes_Ord_tup2_dict + instance_Basic_classes_Ord_Num_natural_dict + instance_Basic_classes_Ord_Num_natural_dict))) (instance_Basic_classes_Ord_Memory_image_range_tag_dict + dict_Basic_classes_Ord_abifeature) (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) instance_Basic_classes_SetType_var_dict (Lem.option_equal (Lem.pair_equal (=) (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal))) r img2.by_range)) + in + let (tagAlsoMatches : ( 'abifeature range_tag) list) = (List.filter (fun x -> tagEquiv + dict_Abi_classes_AbiFeatureTagEquiv_abifeature x tag) allRangeMatches) + in + (match tagAlsoMatches with + [] -> failwith "no range/tag match when asserted to exist" + | [x] -> x + | _ -> failwith "multiple range/tag match when asserted unique" + )) + +(*val symbol_def_ranges : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => annotated_memory_image 'abifeature -> (list (range_tag 'abifeature) * list (maybe element_range))*) +let symbol_def_ranges dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2:('abifeature range_tag)list*((element_range)option)list= +( + (* find all element ranges labelled as ELF symbols *)let (tags, maybe_ranges) = (List.split ( + tagged_ranges_matching_tag + dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature (SymbolDef(null_symbol_definition)) img2 + )) + in + (* some symbols, specifically ABS symbols, needn't label a range. *) + (tags, maybe_ranges)) + +(*val name_of_symbol_def : symbol_definition -> string*) +let name_of_symbol_def sym:string= (sym.def_symname) + +(*val defined_symbols_and_ranges : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => annotated_memory_image 'abifeature -> list ((maybe element_range) * symbol_definition)*) +let defined_symbols_and_ranges dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2:((element_range)option*symbol_definition)list= + (Lem_list.mapMaybe (fun (tag, maybeRange) -> + (match tag with + SymbolDef(ent) -> Some (maybeRange, ent) + | _ -> failwith "impossible: non-symbol def in list of symbol defs" + )) (tagged_ranges_matching_tag + dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature (SymbolDef(null_symbol_definition)) img2)) + +(*val make_ranges_definite : list (maybe element_range) -> list element_range*) +let make_ranges_definite rs:(string*range)list= + (Lem_list.map (fun (maybeR : element_range option) -> (match maybeR with + Some r -> r + | None -> failwith "impossible: range not definite, but asserted to be" + )) rs) + +(*val find_defs_matching : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => symbol_definition -> annotated_memory_image 'abifeature -> list ((maybe element_range) * symbol_definition)*) +let find_defs_matching dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature bound_def img2:((element_range)option*symbol_definition)list= + (let (ranges_and_defs : ( element_range option * symbol_definition) list) = (defined_symbols_and_ranges + dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2) + in + (*let _ = errln ("Searching (among " ^ (show (length ranges_and_defs)) ^ ") for the bound-to symbol `" ^ bound_def.def_symname + ^ "', which came from linkable idx " ^ + (show bound_def.def_linkable_idx) ^ ", section " ^ + (show bound_def.def_syment.elf64_st_shndx) ^ + ", symtab shndx " ^ (show bound_def.def_sym_scn) ^ + ", symind " ^ (show bound_def.def_sym_idx)) + in*) + Lem_list.mapMaybe (fun (maybe_some_range, some_def) -> + (* let _ = errln ("Considering one: `" ^ some_def.def_symname ^ "'") in *) + (* match maybe_some_range with + Nothing -> failwith "symbol definition not over a definite range" + | Just some_range -> *) + (* if some_def.def_symname = bound_def.def_symname + && some_def.def_linkable_idx = bound_def.def_linkable_idx then + if some_def = bound_def + then Just(maybe_some_range, some_def) else Nothing*) + (*let _ = errln ("Found one in the same linkable: syment is " ^ + (show some_def.def_syment)) + in*) + (*else*) if some_def = bound_def + then ( + (*let _ = errln ("Found one: syment is " ^ (show some_def.def_syment)) + in*) + Some(maybe_some_range, some_def) + ) + else if some_def.def_symname = bound_def.def_symname then + (*let _ = errln ("Warning: passing over name-matching def with section " ^ + (show some_def.def_syment.elf64_st_shndx) ^ + ", symtab shndx " ^ (show some_def.def_sym_scn) ^ + ", symind " ^ (show some_def.def_sym_idx) ^ + ", linkable idx " ^ (show some_def.def_linkable_idx)) + in*) None + else None + (* end *) + ) ranges_and_defs) + + +(*val defined_symbols : forall 'abifeature. Ord 'abifeature, AbiFeatureTagEquiv 'abifeature => annotated_memory_image 'abifeature -> list symbol_definition*) +let defined_symbols dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2:(symbol_definition)list= + (let (all_symbol_tags, all_symbol_ranges) = (symbol_def_ranges + dict_Basic_classes_Ord_abifeature dict_Abi_classes_AbiFeatureTagEquiv_abifeature img2) in + Lem_list.mapMaybe (fun tag -> + (match tag with + SymbolDef(ent) -> Some ent + | _ -> failwith "impossible: non-symbol def in list of symbol defs" + )) all_symbol_tags) + + +let default_get_reloc_symaddr dict_Basic_classes_Ord_a dict_Abi_classes_AbiFeatureTagEquiv_a bound_def_in_input output_img maybe_reloc1:Nat_big_num.num= + ((match find_defs_matching + dict_Basic_classes_Ord_a dict_Abi_classes_AbiFeatureTagEquiv_a bound_def_in_input output_img with + [] -> failwith ("internal error: bound-to symbol (name `" ^ (bound_def_in_input.def_symname ^ "') not defined")) + | (maybe_range, d) :: more -> + let v = + ((match maybe_range with + Some(el_name, (start, len)) -> + (match element_and_offset_to_address (el_name, start) output_img with + Some a -> a + | None -> failwith "internal error: could not get address for symbol" + ) + | None -> + (* okay, it'd better be an ABS symbol. *) + if Nat_big_num.equal (Nat_big_num.of_string (Uint32.to_string d.def_syment.elf64_st_shndx)) shn_abs + then Ml_bindings.nat_big_num_of_uint64 d.def_syment.elf64_st_value + else failwith "no range for non-ABS symbol" + )) + in + (match more with + [] -> v + | _ -> (*let _ = errln ("FIXME: internal error: more than one def matching bound def `" ^ + bound_def_in_input.def_symname ^ "'") + in *) v + ) + )) diff --git a/lib/ocaml_rts/linksem/missing_pervasives.ml b/lib/ocaml_rts/linksem/missing_pervasives.ml new file mode 100644 index 00000000..5e81cbe7 --- /dev/null +++ b/lib/ocaml_rts/linksem/missing_pervasives.ml @@ -0,0 +1,590 @@ +(*Generated by Lem from missing_pervasives.lem.*) +open Lem_basic_classes +open Lem_bool +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +open Lem_assert_extra +open Show +open Lem_sorting + +(*val naturalZero : natural*) +(*let naturalZero:natural= 0*) + +(*val id : forall 'a. 'a -> 'a*) +let id0 x:'a= x + +(*type byte*) +(*val natural_of_byte : byte -> natural*) + +let compare_byte b1 b2:int= (Nat_big_num.compare (Nat_big_num.of_int (Char.code b1)) (Nat_big_num.of_int (Char.code b2))) + +let instance_Basic_classes_Ord_Missing_pervasives_byte_dict:(char)ord_class= ({ + + compare_method = compare_byte; + + isLess_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_byte f1 f2) (-1)))); + + isLessEqual_method = (fun f1 -> (fun f2 -> let result = (compare_byte f1 f2) in Lem.orderingEqual result (-1) || Lem.orderingEqual result 0)); + + isGreater_method = (fun f1 -> (fun f2 -> ( Lem.orderingEqual(compare_byte f1 f2) 1))); + + isGreaterEqual_method = (fun f1 -> (fun f2 -> let result = (compare_byte f1 f2) in Lem.orderingEqual result 1 || Lem.orderingEqual result 0))}) + +(*val char_of_byte : byte -> char*) + +(*val byte_of_char : char -> byte*) + +(* Define how to print a byte in hex *) +(*val hex_char_of_nibble : natural -> char*) +let hex_char_of_nibble n:char= + (if Nat_big_num.equal n(Nat_big_num.of_int 0) then + '0' + else if Nat_big_num.equal n(Nat_big_num.of_int 1) then + '1' + else if Nat_big_num.equal n(Nat_big_num.of_int 2) then + '2' + else if Nat_big_num.equal n(Nat_big_num.of_int 3) then + '3' + else if Nat_big_num.equal n(Nat_big_num.of_int 4) then + '4' + else if Nat_big_num.equal n(Nat_big_num.of_int 5) then + '5' + else if Nat_big_num.equal n(Nat_big_num.of_int 6) then + '6' + else if Nat_big_num.equal n(Nat_big_num.of_int 7) then + '7' + else if Nat_big_num.equal n(Nat_big_num.of_int 8) then + '8' + else if Nat_big_num.equal n(Nat_big_num.of_int 9) then + '9' + else if Nat_big_num.equal n(Nat_big_num.of_int 10) then + 'a' + else if Nat_big_num.equal n(Nat_big_num.of_int 11) then + 'b' + else if Nat_big_num.equal n(Nat_big_num.of_int 12) then + 'c' + else if Nat_big_num.equal n(Nat_big_num.of_int 13) then + 'd' + else if Nat_big_num.equal n(Nat_big_num.of_int 14) then + 'e' + else if Nat_big_num.equal n(Nat_big_num.of_int 15) then + 'f' + else +(assert false)) + +let hex_string_of_byte b:string= + (Xstring.implode [ hex_char_of_nibble ( Nat_big_num.div(Nat_big_num.of_int (Char.code b))(Nat_big_num.of_int 16)) + ; hex_char_of_nibble ( Nat_big_num.modulus(Nat_big_num.of_int (Char.code b))(Nat_big_num.of_int 16))]) + +let instance_Show_Show_Missing_pervasives_byte_dict:(char)show_class= ({ + + show_method = hex_string_of_byte}) + +(*val natural_of_decimal_digit : char -> maybe natural*) +let natural_of_decimal_digit c:(Nat_big_num.num)option= + (if c = '0' then + Some(Nat_big_num.of_int 0) + else if c = '1' then + Some(Nat_big_num.of_int 1) + else if c = '2' then + Some(Nat_big_num.of_int 2) + else if c = '3' then + Some(Nat_big_num.of_int 3) + else if c = '4' then + Some(Nat_big_num.of_int 4) + else if c = '5' then + Some(Nat_big_num.of_int 5) + else if c = '6' then + Some(Nat_big_num.of_int 6) + else if c = '7' then + Some(Nat_big_num.of_int 7) + else if c = '8' then + Some(Nat_big_num.of_int 8) + else if c = '9' then + Some(Nat_big_num.of_int 9) + else + None) + +(*val natural_of_decimal_string_helper : natural -> list char -> natural*) +let rec natural_of_decimal_string_helper acc chars:Nat_big_num.num= + ((match chars with + [] -> acc + | c :: cs -> (match natural_of_decimal_digit c with + Some dig -> natural_of_decimal_string_helper ( Nat_big_num.add( Nat_big_num.mul(Nat_big_num.of_int 10) acc) dig) cs + | None -> acc + ) + )) + +(*val natural_of_decimal_string : string -> natural*) +let natural_of_decimal_string s:Nat_big_num.num= + (natural_of_decimal_string_helper(Nat_big_num.of_int 0) (Xstring.explode s)) + +(*val hex_string_of_natural : natural -> string*) +let rec hex_string_of_natural n:string= + (if Nat_big_num.less n(Nat_big_num.of_int 16) then Xstring.implode [hex_char_of_nibble n] + else (hex_string_of_natural ( Nat_big_num.div n(Nat_big_num.of_int 16))) ^ (Xstring.implode [hex_char_of_nibble ( Nat_big_num.modulus n(Nat_big_num.of_int 16))])) + +(*val natural_of_bool : bool -> natural*) +let natural_of_bool b:Nat_big_num.num= + ((match b with + | true ->Nat_big_num.of_int 1 + | false ->Nat_big_num.of_int 0 + )) + +(*val unsafe_nat_of_natural : natural -> nat*) + +(*val unsafe_int_of_natural : natural -> int*) + +(*val byte_of_natural : natural -> byte*) + +(*val natural_ordering : natural -> natural -> ordering*) +(*let natural_ordering left right:ordering= + if (Instance_Basic_classes_Eq_Num_natural.=) left right then + EQ + else if (Instance_Basic_classes_Ord_Num_natural.<) left right then + LT + else + GT*) + +(*val merge_by : forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a -> list 'a*) +let rec merge_by comp xs ys:'a list= + ((match (xs, ys) with + | ([], ys) -> ys + | (xs, []) -> xs + | (x::xs, y::ys) -> + if Lem.orderingEqual (comp x y) (-1) then + x::(merge_by comp xs (y::ys)) + else + y::(merge_by comp (x::xs) ys) + )) + +(*val sort_by : forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a*) +(*let rec sort_by comp xs:list 'a= + match xs with + | [] -> [] + | [x] -> [x] + | xs -> + let ls = List.take (Instance_Num_NumIntegerDivision_nat.div List.length xs 2) xs in + let rs = List.drop (Instance_Num_NumIntegerDivision_nat.div List.length xs 2) xs in + merge_by comp (sort_by comp ls) (sort_by comp rs) + end*) + +(** [mapMaybei f xs] maps a function expecting an index (the position in the list + * [xs] that it is currently viewing) and producing a [maybe] type across a list. + * Elements that produce [Nothing] under [f] are discarded in the output, whilst + * those producing [Just e] for some [e] are kept. + *) +(*val mapMaybei' : forall 'a 'b. (natural -> 'a -> maybe 'b) -> natural -> list 'a -> list 'b*) +let rec mapMaybei' f idx1 xs:'b list= + ((match xs with + | [] -> [] + | x::xs -> + (match f idx1 x with + | None -> mapMaybei' f ( Nat_big_num.add(Nat_big_num.of_int 1) idx1) xs + | Some e -> e :: mapMaybei' f ( Nat_big_num.add(Nat_big_num.of_int 1) idx1) xs + ) + )) + +(*val mapMaybei : forall 'a 'b. (natural -> 'a -> maybe 'b) -> list 'a -> list 'b*) + +let mapMaybei f xs:'b list= + (mapMaybei' f(Nat_big_num.of_int 0) xs) + +(** [partitionii is xs] returns a pair of lists: firstly those elements in [xs] that are + at indices in [is], and secondly the remaining elements. + It preserves the order of elements in xs. *) +(*val partitionii' : forall 'a. natural -> list natural -> list 'a + -> list (natural * 'a) (* accumulates the 'in' partition *) + -> list (natural * 'a) (* accumulates the 'out' partition *) + -> (list (natural * 'a) * list (natural * 'a))*) +let rec partitionii' (offset : Nat_big_num.num) sorted_is xs reverse_accum reverse_accum_compl:(Nat_big_num.num*'a)list*(Nat_big_num.num*'a)list= +( + (* offset o means "xs begins at index o, as reckoned by the indices in sorted_is" *)(match sorted_is with + [] -> (List.rev reverse_accum, List.rev reverse_accum_compl) + | i :: more_is -> + let (length_to_split_off : int) = (Nat_big_num.to_int ( Nat_big_num.sub_nat i offset)) + in + let (left, right) = (Lem_list.split_at length_to_split_off xs) in + let left_indices : Nat_big_num.num list = (Lem_list.genlist + (fun j -> Nat_big_num.add (Nat_big_num.of_int j) offset) + (List.length left)) + in + let left_with_indices = (list_combine left_indices left) in + (* left begins at offset, right begins at offset + i *) + (match right with + [] -> (* We got to the end of the list before the target index. *) + (List.rev reverse_accum, + List.rev_append reverse_accum_compl left_with_indices) + | x :: more_xs -> + (* x is at index i by definition, so more_xs starts with index i + 1 *) + partitionii' (Nat_big_num.add i(Nat_big_num.of_int 1)) more_is more_xs ((i, x) :: reverse_accum) + (List.rev_append left_with_indices reverse_accum_compl) + ) + )) + +(*val filteri : forall 'a. list natural -> list 'a -> list 'a*) +let filteri is xs:'a list= + (let sorted_is = (List.sort Nat_big_num.compare is) in + let (accum, accum_compl) = (partitionii'(Nat_big_num.of_int 0) sorted_is xs [] []) + in + let (just_indices, just_items) = (List.split accum) + in + just_items) + +(*val filterii : forall 'a. list natural -> list 'a -> list (natural * 'a)*) +let filterii is xs:(Nat_big_num.num*'a)list= + (let sorted_is = (List.sort Nat_big_num.compare is) in + let (accum, accum_compl) = (partitionii'(Nat_big_num.of_int 0) sorted_is xs [] []) + in + accum) + +(*val partitioni : forall 'a. list natural -> list 'a -> (list 'a * list 'a)*) +let partitioni is xs:'a list*'a list= + (let sorted_is = (List.sort Nat_big_num.compare is) in + let (accum, accum_compl) = (partitionii'(Nat_big_num.of_int 0) sorted_is xs [] []) + in + let (just_indices, just_items) = (List.split accum) + in + let (just_indices_compl, just_items_compl) = (List.split accum_compl) + in + (just_items, just_items_compl)) + +(*val partitionii : forall 'a. list natural -> list 'a -> (list (natural * 'a) * list (natural * 'a))*) +let partitionii is xs:(Nat_big_num.num*'a)list*(Nat_big_num.num*'a)list= + (let sorted_is = (List.sort Nat_big_num.compare is) in + partitionii'(Nat_big_num.of_int 0) sorted_is xs [] []) + +(** [unzip3 ls] takes a list of triples and returns a triple of lists. *) +(*val unzip3: forall 'a 'b 'c. list ('a * 'b * 'c) -> (list 'a * list 'b * list 'c)*) +let rec unzip3 l:'a list*'b list*'c list= ((match l with + | [] -> ([], [], []) + | (x, y, z) :: xyzs -> let (xs, ys, zs) = (unzip3 xyzs) in ((x :: xs), (y :: ys), (z :: zs)) +)) + +(** [zip3 ls] takes a triple of lists and returns a list of triples. *) +(*val zip3: forall 'a 'b 'c. list 'a -> list 'b -> list 'c -> list ('a * 'b * 'c)*) +let rec zip3 alist blist clist:('a*'b*'c)list= ((match (alist, blist, clist) with + | ([], [], []) -> [] + | (x :: morex, y :: morey, z :: morez) -> let more_xyz = (zip3 morex morey morez) in (x, y, z) :: more_xyz +)) + +(** [null_byte] is the null character a a byte. *) +(*val null_byte : byte*) + +(** [null_char] is the null character. *) +(*val null_char : char*) +let null_char:char= ( '\000') + +(** [println s] prints [s] to stdout, adding a trailing newline. *) +(* val println : string -> unit *) +(* declare ocaml target_rep function println = `print_endline` *) + +(** [prints s] prints [s] to stdout, without adding a trailing newline. *) +(* val prints : string -> unit *) +(* declare ocaml target_rep function prints = `print_string` *) + +(** [errln s] prints [s] to stderr, adding a trailing newline. *) +(*val errln : string -> unit*) + +(** [errs s] prints [s] to stderr, without adding a trailing newline. *) +(*val errs : string -> unit*) + +(** [outln s] prints [s] to stdout, adding a trailing newline. *) +(*val outln : string -> unit*) + +(** [outs s] prints [s] to stdout, without adding a trailing newline. *) +(*val outs : string -> unit*) + +(** [intercalate sep xs] places [sep] between all elements of [xs]. + * Made tail recursive and unrolled slightly to improve performance on large + * lists.*) +(*val intercalate' : forall 'a. 'a -> list 'a -> list 'a -> list 'a*) +let rec intercalate' sep xs accum:'a list= + ((match xs with + | [] -> List.rev accum + | [x] -> List.rev_append (List.rev (List.rev accum)) [x] + | [x; y] -> List.rev_append (List.rev (List.rev accum)) [x; sep; y] + | x::y::xs -> intercalate' sep xs (sep::(y::(sep::(x::accum)))) + )) + +(*val intercalate : forall 'a. 'a -> list 'a -> list 'a*) +let intercalate sep xs:'a list= (intercalate' sep xs []) + +(** [unlines xs] concatenates a list of strings [xs], placing each entry + * on a new line. + *) +(*val unlines : list string -> string*) +let unlines xs:string= + (List.fold_left (^) "" (intercalate "\n" xs)) + +(** [bracket xs] concatenates a list of strings [xs], separating each entry with a + * space, and bracketing the resulting string. + *) +(*val bracket : list string -> string*) +let bracket xs:string= + ("(" ^ (List.fold_left (^) "" (intercalate " " xs) ^ ")")) + +(** [string_of_list l] produces a string representation of list [l]. + *) +(*val string_of_list : forall 'a. Show 'a => list 'a -> string*) +let string_of_list dict_Show_Show_a l:string= + (let result = (intercalate "," (Lem_list.map + dict_Show_Show_a.show_method l)) in + let folded = (List.fold_left (^) "" result) in + "[" ^ (folded ^ "]")) + +let instance_Show_Show_list_dict dict_Show_Show_a:('a list)show_class= ({ + + show_method = + (string_of_list dict_Show_Show_a)}) + +(** [split_string_on_char s c] splits a string [s] into a list of substrings + * on character [c], otherwise returning the singleton list containing [s] + * if [c] is not found in [s]. + * + * NOTE: quirkily, this doesn't discard separators (e.g. because NUL characters + * are significant when indexing into string tables). FIXME: given this, is this + * function really reusable? I suspect not. + *) +(*val split_string_on_char : string -> char -> list string*) + +(* [find_substring sub s] returns the index at which *) +(*val find_substring : string -> string -> maybe natural*) + +(** [string_of_nat m] produces a string representation of natural number [m]. *) +(*val string_of_nat : nat -> string*) + +(** [string_suffix i s] returns all but the first [i] characters of [s]. + * Fails if the index is negative, or beyond the end of the string. + *) +(*val string_suffix : natural -> string -> maybe string*) + +(*val nat_length : forall 'a. list 'a -> nat*) + +(*val length : forall 'a. list 'a -> natural*) +let length xs:Nat_big_num.num= (Nat_big_num.of_int (List.length xs)) + +(*val takeRevAcc : forall 'a. natural -> list 'a -> list 'a -> list 'a*) +let rec takeRevAcc m xs rev_acc:'a list= + ((match xs with + | [] -> List.rev rev_acc + | x::xs -> + if Nat_big_num.equal m(Nat_big_num.of_int 0) then + List.rev rev_acc + else + takeRevAcc ( Nat_big_num.sub_nat m(Nat_big_num.of_int 1)) xs (x::rev_acc) + )) + +(** [take cnt xs] takes the first [cnt] elements of list [xs]. Returns a truncation + * if [cnt] is greater than the length of [xs]. + *) +(*val take : forall 'a. natural -> list 'a -> list 'a*) +let rec take0 m xs:'a list= + (takeRevAcc m xs []) + +(** [drop cnt xs] returns all but the first [cnt] elements of list [xs]. Returns an empty list + * if [cnt] is greater than the length of [xs]. + *) +(*val drop : forall 'a. natural -> list 'a -> list 'a*) +let rec drop0 m xs:'a list= + ((match xs with + | [] -> [] + | x::xs -> + if Nat_big_num.equal m(Nat_big_num.of_int 0) then + x::xs + else + drop0 ( Nat_big_num.sub_nat m(Nat_big_num.of_int 1)) xs + )) + +(** [string_prefix i s] returns the first [i] characters of [s]. + * Fails if the index is negative, or beyond the end of the string. + *) +(*val string_prefix : natural -> string -> maybe string*) +(*let string_prefix m s:maybe(string)= + let cs = String.toCharList s in + if (Instance_Basic_classes_Ord_Num_natural.>) m (length cs) then + Nothing + else + Just (String.toString (take m cs))*) +(* FIXME: isabelle *) + +(** [string_index_of c s] returns [Just(i)] where [i] is the index of the first + * occurrence if [c] in [s], if it exists, otherwise returns [Nothing]. *) +(*val string_index_of' : char -> list char -> natural -> maybe natural*) +let rec string_index_of' e ss idx1:(Nat_big_num.num)option= + ((match ss with + | [] -> None + | s::ss -> + if s = e then + Some idx1 + else + string_index_of' e ss ( Nat_big_num.add(Nat_big_num.of_int 1) idx1) + )) + +(*val string_index_of : char -> string -> maybe natural*) +(*let string_index_of e s:maybe(natural)= string_index_of' e (String.toCharList s) 0*) + +(*val index : forall 'a. natural -> list 'a -> maybe 'a*) +(*let rec index m xs:maybe 'a= + match xs with + | [] -> Nothing + | x::xs -> + if (Instance_Basic_classes_Eq_Num_natural.=) m 0 then + Just x + else + index ((Instance_Num_NumMinus_Num_natural.-) m 1) xs + end*) + +(*val find_index_helper : forall 'a. natural -> ('a -> bool) -> list 'a -> maybe natural*) +let rec find_index_helper count p xs:(Nat_big_num.num)option= + ((match xs with + | [] -> None + | y::ys -> + if p y then + Some count + else + find_index_helper ( Nat_big_num.add count(Nat_big_num.of_int 1)) p ys + )) + +(*val find_index : forall 'a. ('a -> bool) -> list 'a -> maybe natural*) +let find_index0 p xs:(Nat_big_num.num)option= (find_index_helper(Nat_big_num.of_int 0) p xs) + +(*val argv : list string*) + +(*val replicate_revacc : forall 'a. list 'a -> natural -> 'a -> list 'a*) +let rec replicate_revacc revacc len e:'a list= + ( + if(Nat_big_num.equal len (Nat_big_num.of_int 0)) then (List.rev revacc) + else + (replicate_revacc (e :: revacc) + ( Nat_big_num.sub_nat len (Nat_big_num.of_int 1)) e)) + +(*val replicate : forall 'a. natural -> 'a -> list 'a*) +let rec replicate0 len e:'a list= + (replicate_revacc [] len e) + +(* We want a tail-recursive append. reverse_append l1 l2 appends l2 to the + * reverse of l1. So we get [l1-backwards] [l2]. So just reverse l1. *) +(*val list_append : forall 'a. list 'a -> list 'a -> list 'a*) +let list_append l1 l2:'a list= + (List.rev_append (List.rev l1) l2) + +(*val list_concat : forall 'a. list (list 'a) -> list 'a*) +let list_concat ll:'a list= (List.fold_left list_append [] ll) + +(*val list_concat_map : forall 'a 'b. ('a -> list 'b) -> list 'a -> list 'b*) +let list_concat_map f l:'b list= + (list_concat (Lem_list.map f l)) + +(*val list_reverse_concat_map_helper : forall 'a 'b. ('a -> list 'b) -> list 'b -> list 'a -> list 'b*) +let rec list_reverse_concat_map_helper f acc ll:'b list= + (let lcons = (fun l -> (fun i -> i :: l)) + in + (match ll with + | [] -> acc + | item :: items -> + (* item is a thing that maps to a list. it needn't be a list yet *) + let mapped_list = (f item) + in + (* let _ = Missing_pervasives.errln ("Map function gave us a list of " ^ (show (List.length mapped_list)) ^ " items") in *) + list_reverse_concat_map_helper f (List.fold_left lcons acc (f item)) items + )) + +(*val list_reverse_concat_map : forall 'a 'b. ('a -> list 'b) -> list 'a -> list 'b*) +let list_reverse_concat_map f ll:'b list= (list_reverse_concat_map_helper f [] ll) + +(*val list_take_with_accum : forall 'a. nat -> list 'a -> list 'a -> list 'a*) +let rec list_take_with_accum n reverse_acc l:'a list= +( + (* let _ = Missing_pervasives.errs ("Taking a byte; have accumulated " ^ (show (List.length acc) ^ " so far\n")) + in *)(match n with + 0 -> List.rev reverse_acc + | _ -> (match l with + [] -> failwith "list_take_with_accum: not enough elements" + | x :: xs -> list_take_with_accum (Nat_num.nat_monus n( 1)) (x :: reverse_acc) xs + ) + )) + +(*val unsafe_string_take : natural -> string -> string*) +let unsafe_string_take m str:string= + (let m = (Nat_big_num.to_int m) in + Xstring.implode (Lem_list.take m (Xstring.explode str))) + +(** [padding_and_maybe_newline c w s] creates enough of char [c] to pad string [s] to [w] characters, + * unless [s] is of length [w - 1] or greater, in which case it generates [w] copies preceded by a newline. + * This style of formatting is used by the GNU linker in its link map output, so we + * reproduce it using this function. Note that string [s] does not appear in the + * output. *) +(*val padding_and_maybe_newline : char -> natural -> string -> string*) +let padding_and_maybe_newline c width str:string= + (let padlen = (Nat_big_num.sub_nat width (Nat_big_num.of_int (String.length str))) in + (if Nat_big_num.less_equal padlen(Nat_big_num.of_int 1) then "\n" else "") + ^ (Xstring.implode (replicate0 (if Nat_big_num.less_equal padlen(Nat_big_num.of_int 1) then width else padlen) c))) + +(** [space_padding_and_maybe_newline w s] creates enoughspaces to pad string [s] to [w] characters, + * unless [s] is of length [w - 1] or greater, in which case it generates [w] copies preceded by a newline. + * This style of formatting is used by the GNU linker in its link map output, so we + * reproduce it using this function. Note that string [s] does not appear in the + * output. *) +(*val space_padding_and_maybe_newline : natural -> string -> string*) +let space_padding_and_maybe_newline width str:string= + (padding_and_maybe_newline ' ' width str) + +(** [padded_and_maybe_newline w s] pads string [s] to [w] characters, using char [c] + * unless [s] is of length [w - 1] or greater, in which case the padding consists of + * [w] copies of [c] preceded by a newline. + * This style of formatting is used by the GNU linker in its link map output, so we + * reproduce it using this function. *) +(*val padded_and_maybe_newline : char -> natural -> string -> string*) +let padded_and_maybe_newline c width str:string= + (str ^ (padding_and_maybe_newline c width str)) + +(** [padding_to c w s] creates enough copies of [c] to pad string [s] to [w] characters, + * or 0 characters if [s] is of length [w] or greater. Note that string [s] does not appear in the + * output. *) +(*val padding_to : char -> natural -> string -> string*) +let padding_to c width str:string= + (let padlen = (Nat_big_num.sub_nat width (Nat_big_num.of_int (String.length str))) in + if Nat_big_num.less_equal padlen(Nat_big_num.of_int 0) then "" else (Xstring.implode (replicate0 padlen c))) + +(** [left_padded_to c w s] left-pads string [s] to [w] characters using [c], + * returning it unchanged if [s] is of length [w] or greater. *) +(*val left_padded_to : char -> natural -> string -> string*) +let left_padded_to c width str:string= + ((padding_to c width str) ^ str) + +(** [right_padded_to c w s] right-pads string [s] to [w] characters using [c], + * returning it unchanged if [s] is of length [w] or greater. *) +(*val right_padded_to : char -> natural -> string -> string*) +let right_padded_to c width str:string= + (str ^ (padding_to c width str)) + +(** [space_padded_and_maybe_newline w s] pads string [s] to [w] characters, using spaces, + * unless [s] is of length [w - 1] or greater, in which case the padding consists of + * [w] spaces preceded by a newline. + * This style of formatting is used by the GNU linker in its link map output, so we + * reproduce it using this function. *) +(*val space_padded_and_maybe_newline : natural -> string -> string*) +let space_padded_and_maybe_newline width str:string= + (str ^ (padding_and_maybe_newline ' ' width str)) + +(** [left_space_padded_to w s] left-pads string [s] to [w] characters using spaces, + * returning it unchanged if [s] is of length [w] or greater. *) +(*val left_space_padded_to : natural -> string -> string*) +let left_space_padded_to width str:string= + ((padding_to ' ' width str) ^ str) + +(** [right_space_padded_to w s] right-pads string [s] to [w] characters using spaces, + * returning it unchanged if [s] is of length [w] or greater. *) +(*val right_space_padded_to : natural -> string -> string*) +let right_space_padded_to width str:string= + (str ^ (padding_to ' ' width str)) + +(** [left_zero_padded_to w s] left-pads string [s] to [w] characters using zeroes, + * returning it unchanged if [s] is of length [w] or greater. *) +(*val left_zero_padded_to : natural -> string -> string*) +let left_zero_padded_to width str:string= + ((padding_to '0' width str) ^ str) + diff --git a/lib/ocaml_rts/linksem/missing_pervasivesAuxiliary.ml b/lib/ocaml_rts/linksem/missing_pervasivesAuxiliary.ml new file mode 100644 index 00000000..5bcc2165 --- /dev/null +++ b/lib/ocaml_rts/linksem/missing_pervasivesAuxiliary.ml @@ -0,0 +1,42 @@ +(*Generated by Lem from missing_pervasives.lem.*) +open Lem_num + +open Lem_list + +open Lem_basic_classes + +open Lem_bool + +open Lem_maybe + +open Lem_string + +open Lem_assert_extra + +open Show + +open Lem_sorting + +open Missing_pervasives + +let run_test n loc b = + if b then (Format.printf "%s: ok\n" n) else ((Format.printf "%s: FAILED\n %s\n\n" n loc); exit 1);; + + +(****************************************************) +(* *) +(* Assertions *) +(* *) +(****************************************************) + +let _ = run_test "split_string_null" "File \"missing_pervasives.lem\", line 418, character 1 to line 422, character 32\n" ( + (let afterSplit = (Ml_bindings.split_string_on_char (Xstring.implode ([null_char; 's'; null_char; 't']: char list)) null_char) + in + let _ = (prerr_endline ("split string is " ^ (string_of_list + instance_Show_Show_string_dict afterSplit))) + in (listEqualBy (=) + afterSplit [""; "s"; "t"])) +) + + + diff --git a/lib/ocaml_rts/linksem/ml_bindings.ml b/lib/ocaml_rts/linksem/ml_bindings.ml new file mode 100644 index 00000000..ed7c05fe --- /dev/null +++ b/lib/ocaml_rts/linksem/ml_bindings.ml @@ -0,0 +1,156 @@ +open Endianness +open Error + +open Printf +open Unix + +let string_of_unix_time (tm : Nat_big_num.num) = + let num = Nat_big_num.to_int64 tm in + let tm = Unix.gmtime (Int64.to_float num) in + let day = tm.tm_mday in + let mon = 1 + tm.tm_mon in + let year = 1900 + tm.tm_year in + let hour = tm.tm_hour in + let min = tm.tm_min in + let sec = tm.tm_sec in + Printf.sprintf "%i-%i-%iT%02i:%02i:%02i" year mon day hour min sec + +let hex_string_of_nat_pad2 i : string = + Printf.sprintf "%02i" i +;; + +let hex_string_of_big_int_pad6 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%06Lx" i0 +;; + +let hex_string_of_big_int_pad7 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%07Lx" i0 +;; + +let hex_string_of_big_int_pad2 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%02Lx" i0 +;; + +let hex_string_of_big_int_pad4 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%04Lx" i0 +;; + +let hex_string_of_big_int_pad5 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%05Lx" i0 +;; + +let hex_string_of_big_int_pad8 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%08Lx" i0 +;; + +let hex_string_of_big_int_pad16 i : string = + let i0 = Nat_big_num.to_int64 i in + Printf.sprintf "%016Lx" i0 +;; + +let hex_string_of_big_int_no_padding i : string = + let i0 = Nat_big_num.to_int64 i in + if Int64.compare i0 Int64.zero < 0 then + let i0 = Int64.neg i0 in + Printf.sprintf "-%Lx" i0 + else + Printf.sprintf "%Lx" i0 +;; + +let bytes_of_int32 (i : Int32.t) = assert false +;; + +let bytes_of_int64 (i : Int64.t) = assert false +;; + +let int32_of_quad c1 c2 c3 c4 = + let b1 = Int32.of_int (Char.code c1) in + let b2 = Int32.shift_left (Int32.of_int (Char.code c2)) 8 in + let b3 = Int32.shift_left (Int32.of_int (Char.code c3)) 16 in + let b4 = Int32.shift_left (Int32.of_int (Char.code c4)) 24 in + Int32.add b1 (Int32.add b2 (Int32.add b3 b4)) +;; + +let int64_of_oct c1 c2 c3 c4 c5 c6 c7 c8 = + let b1 = Int64.of_int (Char.code c1) in + let b2 = Int64.shift_left (Int64.of_int (Char.code c2)) 8 in + let b3 = Int64.shift_left (Int64.of_int (Char.code c3)) 16 in + let b4 = Int64.shift_left (Int64.of_int (Char.code c4)) 24 in + let b5 = Int64.shift_left (Int64.of_int (Char.code c5)) 32 in + let b6 = Int64.shift_left (Int64.of_int (Char.code c6)) 40 in + let b7 = Int64.shift_left (Int64.of_int (Char.code c7)) 48 in + let b8 = Int64.shift_left (Int64.of_int (Char.code c8)) 56 in + Int64.add b1 (Int64.add b2 (Int64.add b3 (Int64.add b4 + (Int64.add b5 (Int64.add b6 (Int64.add b7 b8)))))) +;; + +let decimal_string_of_int64 e = + let i = Int64.to_int e in + string_of_int i +;; + +let hex_string_of_int64 (e : Int64.t) : string = + let i = Int64.to_int e in + Printf.sprintf "0x%x" i +;; + +let string_suffix index str = + if (* index < 0 *) Nat_big_num.less index (Nat_big_num.of_int 0) || + (* index > length str *) (Nat_big_num.greater index (Nat_big_num.of_int (String.length str))) then + None + else + let idx = Nat_big_num.to_int index in + Some (String.sub str idx (String.length str - idx)) +;; + +let string_prefix index str = + if (* index < 0 *) Nat_big_num.less index (Nat_big_num.of_int 0) || + (* index > length str *) (Nat_big_num.greater index (Nat_big_num.of_int (String.length str))) then + None + else + let idx = Nat_big_num.to_int index in + Some (String.sub str 0 idx) +;; + +let string_index_of (c: char) (s : string) = try Some(Nat_big_num.of_int (String.index s c)) + with Not_found -> None +;; + +let find_substring (sub: string) (s : string) = + try Some(Nat_big_num.of_int (Str.search_forward (Str.regexp_string sub) s 0)) + with Not_found -> None +;; + +let rec list_index_big_int index xs = + match xs with + | [] -> None + | x::xs -> + if Nat_big_num.equal index (Nat_big_num.of_int 0) then + Some x + else + list_index_big_int (Nat_big_num.sub index (Nat_big_num.of_int 1)) xs +;; + +let argv_list = Array.to_list Sys.argv +;; + +let nat_big_num_of_uint64 x = + (* Nat_big_num can only be made from signed integers at present. + * Workaround: make an int64, and if negative, add the high bit + * in the big-num domain. *) + let via_int64 = Uint64.to_int64 x + in + if Int64.compare via_int64 Int64.zero >= 0 then Nat_big_num.of_int64 via_int64 + else + let two_to_63 = Uint64.shift_left (Uint64.of_int 1) 63 in + let lower_by_2_to_63 = Uint64.sub x two_to_63 in + (Nat_big_num.add + (Nat_big_num.of_int64 (Uint64.to_int64 lower_by_2_to_63)) + (Nat_big_num.shift_left (Nat_big_num.of_int 1) 63) + ) diff --git a/lib/ocaml_rts/linksem/multimap.ml b/lib/ocaml_rts/linksem/multimap.ml new file mode 100644 index 00000000..5ba51824 --- /dev/null +++ b/lib/ocaml_rts/linksem/multimap.ml @@ -0,0 +1,215 @@ +(*Generated by Lem from multimap.lem.*) +open Lem_bool +open Lem_basic_classes +open Lem_maybe +open Lem_function +open Lem_num +open Lem_list +open Lem_set +open Lem_set_extra +open Lem_assert_extra +open Missing_pervasives +open Lem_string +open Show + +(* HMM. Is the right thing instead to implement multiset first? Probably. *) + +(* This is a set of pairs + * augmented with operations implementing a particular kind of + * map. + * + * This map differs from the Lem map in the following ways. + * + * 0. The basic idea: it's a multimap, so a single key, supplied as a "query", + * can map to many (key, value) results. + * But PROBLEM: how do we store them in a tree? We're using OCaml's + * Set implementation underneath, and that doesn't allow duplicates. + * + * 1. ANSWER: require keys still be unique, but that the user supplies an + * equivalence relation on them, which + * is coarser-grained than the ordering relation + * used to order the set. It must be consistent with it, though: + * equivalent keys should appear as a contiguous range in the + * ordering. + * + * 2. This allows many "non-equal" keys, hence present independently + * in the set of pairs, to be "equivalent" for the purposes of a + * query. + * + * 3. The coarse-grained equivalence relation can be supplied on a + * per-query basis, meaning that different queries on the same + * set can query by finer or coarser criteria (while respecting + * the requirement to be consistent with the ordering). + * + * Although this seems more complicated than writing a map from + * k to list (k, v), which would allow us to ditch the finer ordering, + * it scales better (no lists) and allows certain range queries which + * would be harder to implement under that approach. It also has the + * nice property that the inverse multimap is represented as the same + * set but with the pairs reversed. + *) + +type( 'k, 'v) multimap = ('k * 'v) Pset.set + +(* In order for bisection search within a set to work, + * we need the equivalence class to tell us whether we're less than or + * greater than the members of the key's class. + * It effectively identifies a set of ranges. *) +type 'k key_equiv = 'k -> 'k -> bool + +(* +val hasMapping : forall 'k 'v. key_equiv 'k -> multimap 'k 'v -> bool +let inline hasMapping equiv m = +*) + +(* +val mappingCount : forall 'k 'v. key_equiv 'k -> multimap 'k 'v -> natural +val any : forall 'k 'v. ('k -> 'v -> bool) -> multimap 'k 'v -> bool +val all : forall 'k 'v. ('k -> 'v -> bool) -> multimap 'k 'v -> bool +*) +(*val findLowestKVWithKEquivTo : forall 'k 'v. + Ord 'k, Ord 'v, SetType 'k, SetType 'v => + 'k + -> key_equiv 'k + -> multimap 'k 'v + -> maybe ('k * 'v) + -> maybe ('k * 'v)*) +let rec findLowestKVWithKEquivTo dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv subSet maybeBest:('k*'v)option= + ((match Pset.choose_and_split subSet with + None -> (* empty subset *) maybeBest + | Some(lower, ((chosenK: 'k), (chosenV : 'v)), higher) -> + (* is k equiv to chosen? *) + if equiv k chosenK + then + (* is chosen less than our current best? *) + let (bestK, bestV) = ((match maybeBest with + None -> (chosenK, chosenV) + | Some(currentBestK, currentBestV) -> + if pairLess + dict_Basic_classes_Ord_v dict_Basic_classes_Ord_k (chosenK, chosenV) (currentBestK, currentBestV) + then (chosenK, chosenV) + else (currentBestK, currentBestV) + )) + in + (* recurse down lower subSet; best is whichever is lower *) + findLowestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv lower (Some(bestK, bestV)) + else + (* k is not equiv to chosen; do we need to look lower or higher? *) + if dict_Basic_classes_Ord_k.isLess_method k chosenK + then + (* k is lower, so look lower for equivs-to-k *) + findLowestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv lower maybeBest + else + (* k is higher *) + findLowestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv higher maybeBest + )) + +(*val testEquiv : natural -> natural -> bool*) +let testEquiv x y:bool= (if ( Nat_big_num.greater_equal x(Nat_big_num.of_int 3) && (Nat_big_num.less x(Nat_big_num.of_int 5) && (Nat_big_num.greater_equal y(Nat_big_num.of_int 3) && Nat_big_num.less_equal y(Nat_big_num.of_int 5)))) then true + else if ( Nat_big_num.less x(Nat_big_num.of_int 3) && Nat_big_num.less y(Nat_big_num.of_int 3)) then true + else if ( Nat_big_num.greater x(Nat_big_num.of_int 5) && Nat_big_num.greater y(Nat_big_num.of_int 5)) then true + else false) + +(* Note we can't just use findLowestEquiv with inverted relations, because + * chooseAndSplit returns us (lower, chosen, higher) and we need to swap + * around how we consume that. *) +(*val findHighestKVWithKEquivTo : forall 'k 'v. + Ord 'k, Ord 'v, SetType 'k, SetType 'v => + 'k + -> key_equiv 'k + -> multimap 'k 'v + -> maybe ('k * 'v) + -> maybe ('k * 'v)*) +let rec findHighestKVWithKEquivTo dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv subSet maybeBest:('k*'v)option= + ((match Pset.choose_and_split subSet with + None -> (* empty subset *) maybeBest + | Some(lower, ((chosenK: 'k), (chosenV : 'v)), higher) -> + (* is k equiv to chosen? *) + if equiv k chosenK + then + (* is chosen greater than our current best? *) + let (bestK, bestV) = ((match maybeBest with + None -> (chosenK, chosenV) + | Some(currentBestK, currentBestV) -> + if pairGreater + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v (chosenK, chosenV) (currentBestK, currentBestV) + then (chosenK, chosenV) + else (currentBestK, currentBestV) + )) + in + (* recurse down higher-than-chosen subSet; best is whichever is higher *) + findHighestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv higher (Some(bestK, bestV)) + else + (* k is not equiv to chosen; do we need to look lower or higher? + * NOTE: the pairs in the set must be lexicographically ordered! *) + if dict_Basic_classes_Ord_k.isGreater_method k chosenK + then + (* k is higher than chosen, so look higher for equivs-to-k *) + findHighestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv higher maybeBest + else + (* k is lower than chosen, so look lower *) + findHighestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv lower maybeBest + )) + +(* get the list of all pairs with key equiv to k. *) +(*val lookupBy : forall 'k 'v. + Ord 'k, Ord 'v, SetType 'k, SetType 'v => + key_equiv 'k -> 'k -> multimap 'k 'v -> list ('k * 'v)*) +let lookupBy0 dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v equiv k m:('k*'v)list= +( + (* Find the lowest and highest elements equiv to k. + * We do this using chooseAndSplit recursively. *)(match findLowestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv m None with + None -> [] + | Some lowestEquiv -> + let (highestEquiv : ('k * 'v)) = +( + (* We can't just invert the relation on the set, because + * the whole set is ordered *)(match findHighestKVWithKEquivTo + dict_Basic_classes_Ord_k dict_Basic_classes_Ord_v dict_Basic_classes_SetType_k dict_Basic_classes_SetType_v k equiv m None with + None -> failwith "impossible: lowest equiv but no highest equiv" + | Some highestEquiv -> highestEquiv + )) + in + (* FIXME: split is currently needlessly inefficient on OCaml! *) + let (lowerThanLow, highEnough) = (Lem_set.split + (instance_Basic_classes_SetType_tup2_dict dict_Basic_classes_SetType_k + dict_Basic_classes_SetType_v) (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_k + dict_Basic_classes_Ord_v) lowestEquiv m) + in + let (wanted, tooHigh) = (Lem_set.split + (instance_Basic_classes_SetType_tup2_dict dict_Basic_classes_SetType_k + dict_Basic_classes_SetType_v) (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_k + dict_Basic_classes_Ord_v) highestEquiv highEnough) + in + (* NOTE that lowestEquiv is a single element; we want to include + * *all those equiv to it*, which may be non-equal. FIXME: use splitMember, + * although that needs fixing in Lem (plus an optimised OCaml version). *) + List.rev_append (List.rev (List.rev_append (List.rev (Pset.elements (let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_k.setElemCompare_method dict_Basic_classes_SetType_v.setElemCompare_method) []) in Pset.fold + (fun s x2 -> + if Lem.orderingEqual 0 + (pairCompare dict_Basic_classes_Ord_k.compare_method + dict_Basic_classes_Ord_v.compare_method s lowestEquiv) then + Pset.add s x2 else x2) m x2))) (Pset.elements wanted))) ( + (* don't include the lowest and highest twice, if they're the same *) + if pairLess + dict_Basic_classes_Ord_v dict_Basic_classes_Ord_k lowestEquiv highestEquiv then (Pset.elements (let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_k.setElemCompare_method dict_Basic_classes_SetType_v.setElemCompare_method) []) in Pset.fold + (fun s x2 -> + if Lem.orderingEqual 0 + (pairCompare dict_Basic_classes_Ord_k.compare_method + dict_Basic_classes_Ord_v.compare_method s highestEquiv) then + Pset.add s x2 else x2) m x2)) else [] + ) + )) + + +(* To delete all pairs with key equiv to k, can use deleteBy *) + diff --git a/lib/ocaml_rts/linksem/multimapAuxiliary.ml b/lib/ocaml_rts/linksem/multimapAuxiliary.ml new file mode 100644 index 00000000..c5123769 --- /dev/null +++ b/lib/ocaml_rts/linksem/multimapAuxiliary.ml @@ -0,0 +1,129 @@ +(*Generated by Lem from multimap.lem.*) +open Lem_num + +open Lem_list + +open Lem_set + +open Lem_function + +open Lem_basic_classes + +open Lem_bool + +open Lem_maybe + +open Lem_string + +open Lem_assert_extra + +open Show + +open Lem_set_extra + +open Missing_pervasives + +open Multimap + +let run_test n loc b = + if b then (Format.printf "%s: ok\n" n) else ((Format.printf "%s: FAILED\n %s\n\n" n loc); exit 1);; + + +(****************************************************) +(* *) +(* Assertions *) +(* *) +(****************************************************) + +let _ = run_test "lowest_simple" "File \"multimap.lem\", line 111, character 1 to line 112, character 100\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findLowestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 1,Nat_big_num.of_int 0); (Nat_big_num.of_int 2,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 0); (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) (Some (Nat_big_num.of_int 3,Nat_big_num.of_int 0))) +) + +let _ = run_test "lowest_kv" "File \"multimap.lem\", line 113, character 1 to line 114, character 108\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findLowestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 1,Nat_big_num.of_int 0); (Nat_big_num.of_int 2,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 1); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 0); (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) (Some (Nat_big_num.of_int 3,Nat_big_num.of_int 0))) +) + +let _ = run_test "lowest_empty" "File \"multimap.lem\", line 115, character 1 to line 116, character 48\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findLowestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) []) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) None) +) + +let _ = run_test "lowest_onepast" "File \"multimap.lem\", line 117, character 1 to line 118, character 56\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findLowestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) None) +) + +let _ = run_test "lowest_oneprev" "File \"multimap.lem\", line 119, character 1 to line 120, character 56\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findLowestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 2,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) None) +) + +let _ = run_test "highest_simple" "File \"multimap.lem\", line 169, character 1 to line 170, character 100\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findHighestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 1,Nat_big_num.of_int 0); (Nat_big_num.of_int 2,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 0); (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) (Some (Nat_big_num.of_int 5,Nat_big_num.of_int 0))) +) + +let _ = run_test "highest_kv" "File \"multimap.lem\", line 171, character 1 to line 172, character 108\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findHighestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 1,Nat_big_num.of_int 0); (Nat_big_num.of_int 2,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 1); (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) (Some (Nat_big_num.of_int 5,Nat_big_num.of_int 1))) +) + +let _ = run_test "highest_empty" "File \"multimap.lem\", line 173, character 1 to line 174, character 48\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findHighestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) []) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) None) +) + +let _ = run_test "highest_onepast" "File \"multimap.lem\", line 175, character 1 to line 176, character 56\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findHighestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) None) +) + +let _ = run_test "highest_oneprev" "File \"multimap.lem\", line 177, character 1 to line 178, character 56\n" ( + (Lem.option_equal (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (findHighestKVWithKEquivTo + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict(Nat_big_num.of_int 4) testEquiv +((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 2,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set) None) None) +) + +let _ = run_test "lookup_simple" "File \"multimap.lem\", line 219, character 1 to line 221, character 55\n" ( + (listEqualBy (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (lookupBy0 + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict testEquiv(Nat_big_num.of_int 4) ((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 1,Nat_big_num.of_int 0); (Nat_big_num.of_int 2,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 0); (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set)) ([(Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 5,Nat_big_num.of_int 0)] : (Nat_big_num.num * Nat_big_num.num) list)) +) + +let _ = run_test "lookup_kv" "File \"multimap.lem\", line 222, character 1 to line 224, character 63\n" ( + (listEqualBy (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (lookupBy0 + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict testEquiv(Nat_big_num.of_int 4) ((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 1,Nat_big_num.of_int 0); (Nat_big_num.of_int 2,Nat_big_num.of_int 0); (Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 1); (Nat_big_num.of_int 5,Nat_big_num.of_int 0); (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set)) ([(Nat_big_num.of_int 3,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 0); (Nat_big_num.of_int 4,Nat_big_num.of_int 1); (Nat_big_num.of_int 5,Nat_big_num.of_int 0)] : (Nat_big_num.num * Nat_big_num.num) list)) +) + +let _ = run_test "lookup_empty" "File \"multimap.lem\", line 225, character 1 to line 226, character 65\n" ( + (listEqualBy (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (lookupBy0 + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict testEquiv(Nat_big_num.of_int 4) ((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) []) : (Nat_big_num.num * Nat_big_num.num) Pset.set)) ([]: (Nat_big_num.num * Nat_big_num.num) list)) +) + +let _ = run_test "lookup_singleton" "File \"multimap.lem\", line 227, character 1 to line 228, character 77\n" ( + (listEqualBy (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (lookupBy0 + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict testEquiv(Nat_big_num.of_int 4) ((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [(Nat_big_num.of_int 5,Nat_big_num.of_int 0)]) : (Nat_big_num.num * Nat_big_num.num) Pset.set)) ([(Nat_big_num.of_int 5,Nat_big_num.of_int 0)]: (Nat_big_num.num * Nat_big_num.num) list)) +) + +let _ = run_test "lookup_onepast" "File \"multimap.lem\", line 229, character 1 to line 230, character 74\n" ( + (listEqualBy (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (lookupBy0 + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict testEquiv(Nat_big_num.of_int 4) ((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 6,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set)) ([] : (Nat_big_num.num * Nat_big_num.num) list)) +) + +let _ = run_test "lookup_oneprev" "File \"multimap.lem\", line 231, character 1 to line 232, character 74\n" ( + (listEqualBy (Lem.pair_equal Nat_big_num.equal Nat_big_num.equal) (lookupBy0 + instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_Ord_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict instance_Basic_classes_SetType_Num_natural_dict testEquiv(Nat_big_num.of_int 4) ((Pset.from_list (pairCompare Nat_big_num.compare Nat_big_num.compare) [ (Nat_big_num.of_int 2,Nat_big_num.of_int 0) ]) : (Nat_big_num.num * Nat_big_num.num) Pset.set)) ([] : (Nat_big_num.num * Nat_big_num.num) list)) +) + + + diff --git a/lib/ocaml_rts/linksem/scratch.ml b/lib/ocaml_rts/linksem/scratch.ml new file mode 100644 index 00000000..4b57ba9d --- /dev/null +++ b/lib/ocaml_rts/linksem/scratch.ml @@ -0,0 +1,28 @@ +(*Generated by Lem from scratch.lem.*) +open Byte_sequence +open Error +open Missing_pervasives + +open Endianness +open Show + +open Elf_file +open Elf_header +open Elf_note +open Elf_section_header_table + +open Gnu_ext_note + +let ( _:unit) = +(let res = +(Byte_sequence.acquire "/usr/bin/less" >>= (fun bs0 -> + Elf_file.read_elf32_file bs0 >>= (fun ef1 -> + let endian = (get_elf32_header_endianness ef1.elf32_file_header) in + Elf_file.get_elf32_file_section_header_string_table ef1 >>= (fun sect_hdr -> + return (gnu_ext_extract_elf32_earliest_compatible_kernel endian ef1.elf32_file_section_header_table sect_hdr bs0))))) + in + (match res with + | Fail err -> print_endline err + | Success s -> print_endline (string_of_error + instance_Show_Show_string_dict s) + )) diff --git a/lib/ocaml_rts/linksem/show.ml b/lib/ocaml_rts/linksem/show.ml new file mode 100644 index 00000000..ef8dc4ff --- /dev/null +++ b/lib/ocaml_rts/linksem/show.ml @@ -0,0 +1,123 @@ +(*Generated by Lem from show.lem.*) +(** [show.lem] exports the typeclass [Show] and associated functions for pretty + * printing arbitrary values. + *) + +open Lem_function +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +open Lem_string_extra + +type 'a show_class={ + show_method : 'a -> string +} + +(** [string_of_unit u] produces a string representation of unit [u]. + *) +(*val string_of_unit : unit -> string*) +let string_of_unit u:string= "()" + +let instance_Show_Show_unit_dict:(unit)show_class= ({ + + show_method = string_of_unit}) + +(** [string_of_bool b] produces a string representation of boolean [b]. + *) +(*val string_of_bool : bool -> string*) +let string_of_bool b:string= + ((match b with + | true -> "true" + | false -> "false" + )) + +let instance_Show_Show_bool_dict:(bool)show_class= ({ + + show_method = string_of_bool}) + +(** To give control over extraction as instances cannot be target specific, but + * the functions they are bound to can be... + *) +(*val string_of_string : string -> string*) +let string_of_string x:string= x + +let instance_Show_Show_string_dict:(string)show_class= ({ + + show_method = string_of_string}) + +(** [string_of_pair p] produces a string representation of pair [p]. + *) +(*val string_of_pair : forall 'a 'b. Show 'a, Show 'b => ('a * 'b) -> string*) +let string_of_pair dict_Show_Show_a dict_Show_Show_b (left, right):string= + ("(" ^ (dict_Show_Show_a.show_method left ^ (", " ^ (dict_Show_Show_b.show_method right ^ ")")))) + +let instance_Show_Show_tup2_dict dict_Show_Show_a dict_Show_Show_b:('a*'b)show_class= ({ + + show_method = + (string_of_pair dict_Show_Show_a dict_Show_Show_b)}) + +(** [string_of_triple p] produces a string representation of triple [p]. + *) +(*val string_of_triple : forall 'a 'b 'c. Show 'a, Show 'b, Show 'c => ('a * 'b * 'c) -> string*) +let string_of_triple dict_Show_Show_a dict_Show_Show_b dict_Show_Show_c (left, middle, right):string= + ("(" ^ (dict_Show_Show_a.show_method left ^ (", " ^ (dict_Show_Show_b.show_method middle ^ (", " ^ (dict_Show_Show_c.show_method right ^ ")")))))) + +let instance_Show_Show_tup3_dict dict_Show_Show_a dict_Show_Show_b dict_Show_Show_c:('a*'b*'c)show_class= ({ + + show_method = + (string_of_triple dict_Show_Show_a dict_Show_Show_b dict_Show_Show_c)}) + +(** [string_of_quad p] produces a string representation of quad [p]. + *) +(*val string_of_quad : forall 'a 'b 'c 'd. Show 'a, Show 'b, Show 'c, Show 'd => ('a * 'b * 'c * 'd) -> string*) +let string_of_quad dict_Show_Show_a dict_Show_Show_b dict_Show_Show_c dict_Show_Show_d (left, middle1, middle2, right):string= + ("(" ^ (dict_Show_Show_a.show_method left ^ (", " ^ (dict_Show_Show_b.show_method middle1 ^ (", " ^ (dict_Show_Show_c.show_method middle2 ^ (", " ^ (dict_Show_Show_d.show_method right ^ ")")))))))) + +let instance_Show_Show_tup4_dict dict_Show_Show_a dict_Show_Show_b dict_Show_Show_c dict_Show_Show_d:('a*'b*'c*'d)show_class= ({ + + show_method = + (string_of_quad dict_Show_Show_a dict_Show_Show_b dict_Show_Show_c + dict_Show_Show_d)}) + +(** [string_of_maybe m] produces a string representation of maybe value [m]. + *) +(*val string_of_maybe : forall 'a. Show 'a => maybe 'a -> string*) +let string_of_maybe dict_Show_Show_a m:string= + ((match m with + | None -> "Nothing" + | Some e -> "Just " ^ + dict_Show_Show_a.show_method e + )) + +let instance_Show_Show_Maybe_maybe_dict dict_Show_Show_a:('a option)show_class= ({ + + show_method = + (string_of_maybe dict_Show_Show_a)}) + +(** [show_else s m] produces a string representation of maybe [m], using [s] + * in the case [m] = Nothing. *) +(*val show_else : forall 'a. Show 'a => string -> maybe 'a -> string*) +let show_else dict_Show_Show_a subst m:string= + ((match m with + Some x -> dict_Show_Show_a.show_method x + | None -> subst + )) + +(** [string_of_nat m] produces a string representation of nat value [m]. + *) +(*val string_of_nat : nat -> string*) + +let instance_Show_Show_nat_dict:(int)show_class= ({ + + show_method = Pervasives.string_of_int}) + +let instance_Show_Show_Num_natural_dict:(Nat_big_num.num)show_class= ({ + + show_method = Nat_big_num.to_string}) + +(*val string_of_integer : integer -> string*) + +let instance_Show_Show_Num_integer_dict:(Nat_big_num.num)show_class= ({ + + show_method = Nat_big_num.to_string}) diff --git a/lib/ocaml_rts/linksem/src_lem_library/bit.ml b/lib/ocaml_rts/linksem/src_lem_library/bit.ml new file mode 100644 index 00000000..bd972008 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/bit.ml @@ -0,0 +1,19 @@ +type bit = Zero | One + +let to_bool b = match b with | Zero -> false | _ -> true +let bn b = match b with | Zero -> One | One -> Zero +let bor b1 b2 = match (b1,b2) with + | Zero,Zero -> Zero + | _ -> One +let xor b1 b2 = match (b1,b2) with + | Zero,Zero -> Zero + | Zero,One | One,Zero -> One + | _ -> Zero +let band b1 b2 = match (b1,b2) with + | One,One -> One + | _ -> Zero + +let add b1 b2 = match (b1,b2) with + | Zero,Zero -> Zero, false + | Zero,One | One,Zero -> One, false + | One,One -> Zero, true diff --git a/lib/ocaml_rts/linksem/src_lem_library/bit.mli b/lib/ocaml_rts/linksem/src_lem_library/bit.mli new file mode 100644 index 00000000..a39c1a09 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/bit.mli @@ -0,0 +1,8 @@ +type bit = Zero | One + +val to_bool : bit -> bool +val bn : bit -> bit +val bor : bit -> bit -> bit +val xor : bit -> bit -> bit +val band : bit -> bit -> bit +val add : bit -> bit -> bit * bool diff --git a/lib/ocaml_rts/linksem/src_lem_library/either.ml b/lib/ocaml_rts/linksem/src_lem_library/either.ml new file mode 100644 index 00000000..ddf1b214 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/either.ml @@ -0,0 +1,24 @@ +type ('a, 'b) either = + | Left of 'a + | Right of 'b + +let either_case fa fb x = match x with + | (Left a) -> fa a + | (Right b) -> fb b + +let eitherEqualBy eql eqr (left: ('a, 'b) either) (right: ('a, 'b) either) = + match (left, right) with + | ((Left l), (Left l')) -> eql l l' + | ((Right r), (Right r')) -> eqr r r' + | _ -> false + +let rec either_partition l = ((match l with + | [] -> ([], []) + | x :: xs -> begin + let (ll, rl) = (either_partition xs) in + (match x with + | (Left l) -> ((l::ll), rl) + | (Right r) -> (ll, (r::rl)) + ) + end +)) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem.ml b/lib/ocaml_rts/linksem/src_lem_library/lem.ml new file mode 100644 index 00000000..2ff0090f --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem.ml @@ -0,0 +1,103 @@ +(* ========================================================================== *) +(* Tuples *) +(* ========================================================================== *) + + +let pair_equal eq1 eq2 (a1, b1) (a2, b2) = + (eq1 a1 a2) && (eq2 b1 b2) + +let pair_swap (v1, v2) = (v2, v1) + +let curry f v1 v2 = f (v1, v2) + +let uncurry f (v1, v2) = f v1 v2 + +(* ========================================================================== *) +(* Orderings *) +(* ========================================================================== *) + +let orderingIsLess r = (r < 0) +let orderingIsGreater r = (r > 0) +let orderingIsEqual r = (r = 0) + +let ordering_cases (r : int) (lt : 'a) (eq : 'a) (gt : 'a) : 'a = + (if (r < 0) then lt else + if (r = 0) then eq else gt) + +let orderingEqual r1 r2 = + ordering_cases r1 (orderingIsLess r2) (orderingIsEqual r2) (orderingIsGreater r2) + + +(* ========================================================================== *) +(* Lists *) +(* ========================================================================== *) + + +let list_null = function + | [] -> true + | _ -> false + +let rec lexicographic_compare cmp l1 l2 : int = (match (l1,l2) with + | ([], []) -> 0 + | ([], _::_) -> -1 + | (_::_, []) -> 1 + | (x::xs, y::ys) -> begin + ordering_cases (cmp x y) (-1) (lexicographic_compare cmp xs ys) (1) + end +) + +let rec lexicographic_less less less_eq l1 l2 = ((match (l1,l2) with + | ([], []) -> false + | ([], _::_) -> true + | (_::_, []) -> false + | (x::xs, y::ys) -> ((less x y) || ((less_eq x y) && (lexicographic_less less less_eq xs ys))) +)) + +let rec lexicographic_less_eq less less_eq l1 l2 = ((match (l1,l2) with + | ([], []) -> true + | ([], _::_) -> true + | (_::_, []) -> false + | (x::xs, y::ys) -> (less x y || (less_eq x y && lexicographic_less_eq less less_eq xs ys)) +)) + +let rec list_index l n = (match l with + | [] -> None + | x :: xs -> if n = 0 then (Some x) else list_index xs (n - 1) +) + + +(* ========================================================================== *) +(* Options *) +(* ========================================================================== *) + +let is_none = function + | None -> true + | Some _ -> false + +let is_some = function + | None -> false + | Some _ -> true + +let option_case d f mb = (match mb with + | Some a -> f a + | None -> d +) + +let option_default d = function + | Some a -> a + | None -> d + +let option_map f = function + | Some a -> Some (f a) + | None -> None + +let option_bind m f = + match m with + | Some a -> f a + | None -> None + +let option_equal eq o1 o2 = match (o1, o2) with + | (None, None) -> true + | (None, Some _) -> false + | (Some _, None) -> false + | (Some x1, Some x2) -> eq x1 x2 diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_assert_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_assert_extra.ml new file mode 100644 index 00000000..3b4a1548 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_assert_extra.ml @@ -0,0 +1,28 @@ +(*Generated by Lem from assert_extra.lem.*) + +open Xstring + +(* ------------------------------------ *) +(* failing with a proper error message *) +(* ------------------------------------ *) + +(*val failwith: forall 'a. string -> 'a*) + +(* ------------------------------------ *) +(* failing without an error message *) +(* ------------------------------------ *) + +(*val fail : forall 'a. 'a*) +(*let fail = failwith "fail"*) + +(* ------------------------------------- *) +(* assertions *) +(* ------------------------------------- *) + +(*val ensure : bool -> string -> unit*) +let ensure test msg = +(if test then + () + else + failwith msg) +;; diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_basic_classes.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_basic_classes.ml new file mode 100644 index 00000000..9f24e5fb --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_basic_classes.ml @@ -0,0 +1,323 @@ +(*Generated by Lem from basic_classes.lem.*) +(******************************************************************************) +(* Basic Type Classes *) +(******************************************************************************) + +open Lem_bool + +(* ========================================================================== *) +(* Equality *) +(* ========================================================================== *) + +(* Lem`s default equality (=) is defined by the following type-class Eq. + This typeclass should define equality on an abstract datatype 'a. It should + always coincide with the default equality of Coq, HOL and Isabelle. + For OCaml, it might be different, since abstract datatypes like sets + might have fancy equalities. *) + +type 'a eq_class= { + isEqual_method : 'a -> 'a -> bool; + isInequal_method : 'a -> 'a -> bool +} + + +(* (=) should for all instances be an equivalence relation + The isEquivalence predicate of relations could be used here. + However, this would lead to a cyclic dependency. *) + +(* TODO: add later, once lemmata can be assigned to classes +lemma eq_equiv: ((forall x. (x = x)) && + (forall x y. (x = y) <-> (y = x)) && + (forall x y z. ((x = y) && (y = z)) --> (x = z))) +*) + +(* Structural equality *) + +(* Sometimes, it is also handy to be able to use structural equality. + This equality is mapped to the build-in equality of backends. This equality + differs significantly for each backend. For example, OCaml can`t check equality + of function types, whereas HOL can. When using structural equality, one should + know what one is doing. The only guarentee is that is behaves like + the native backend equality. + + A lengthy name for structural equality is used to discourage its direct use. + It also ensures that users realise it is unsafe (e.g. OCaml can`t check two functions + for equality *) +(*val unsafe_structural_equality : forall 'a. 'a -> 'a -> bool*) + +(*val unsafe_structural_inequality : forall 'a. 'a -> 'a -> bool*) +let unsafe_structural_inequality x y = (not (x = y)) + +(* The default for equality is the unsafe structural one. It can + (and should) be overriden for concrete types later. *) + +let instance_Basic_classes_Eq_var_dict =({ + + isEqual_method = (=); + + isInequal_method = unsafe_structural_inequality}) + + +(* ========================================================================== *) +(* Orderings *) +(* ========================================================================== *) + +(* The type-class Ord represents total orders (also called linear orders) *) +(*type ordering = LT | EQ | GT*) + +(*let orderingIsLess r = (match r with LT -> true | _ -> false end)*) +(*let orderingIsGreater r = (match r with GT -> true | _ -> false end)*) +(*let orderingIsEqual r = (match r with EQ -> true | _ -> false end)*) + +(*let ordering_cases r lt eq gt = + if orderingIsLess r then lt else + if orderingIsEqual r then eq else gt*) + + +(*val orderingEqual : ordering -> ordering -> bool*) + +let instance_Basic_classes_Eq_Basic_classes_ordering_dict =({ + + isEqual_method = Lem.orderingEqual; + + isInequal_method = (fun x y->not (Lem.orderingEqual x y))}) + +type 'a ord_class= { + compare_method : 'a -> 'a -> int; + isLess_method : 'a -> 'a -> bool; + isLessEqual_method : 'a -> 'a -> bool; + isGreater_method : 'a -> 'a -> bool; + isGreaterEqual_method : 'a -> 'a -> bool +} + + +(* Ocaml provides default, polymorphic compare functions. Let's use them + as the default. However, because used perhaps in a typeclass they must be + defined for all targets. So, explicitly declare them as undefined for + all other targets. If explictly declare undefined, the type-checker won't complain and + an error will only be raised when trying to actually output the function for a certain + target. *) +(*val defaultCompare : forall 'a. 'a -> 'a -> ordering*) +(*val defaultLess : forall 'a. 'a -> 'a -> bool*) +(*val defaultLessEq : forall 'a. 'a -> 'a -> bool*) +(*val defaultGreater : forall 'a. 'a -> 'a -> bool*) +(*val defaultGreaterEq : forall 'a. 'a -> 'a -> bool*) +;; + +let genericCompare (less: 'a -> 'a -> bool) (equal: 'a -> 'a -> bool) (x : 'a) (y : 'a) = +(if less x y then + (-1) + else if equal x y then + 0 + else + 1) + + +(* +(* compare should really be a total order *) +lemma ord_OK_1: ( + (forall x y. (compare x y = EQ) <-> (compare y x = EQ)) && + (forall x y. (compare x y = LT) <-> (compare y x = GT))) + +lemma ord_OK_2: ( + (forall x y z. (x <= y) && (y <= z) --> (x <= z)) && + (forall x y. (x <= y) || (y <= x)) +) +*) + +(* let's derive a compare function from the Ord type-class *) +(*val ordCompare : forall 'a. Eq 'a, Ord 'a => 'a -> 'a -> ordering*) +let ordCompare dict_Basic_classes_Eq_a dict_Basic_classes_Ord_a x y = +(if ( dict_Basic_classes_Ord_a.isLess_method x y) then (-1) else + if ( dict_Basic_classes_Eq_a.isEqual_method x y) then 0 else 1) + +type 'a ordMaxMin_class= { + max_method : 'a -> 'a -> 'a; + min_method : 'a -> 'a -> 'a +} + +(*val minByLessEqual : forall 'a. ('a -> 'a -> bool) -> 'a -> 'a -> 'a*) +let minByLessEqual le x y = (if (le x y) then x else y) + +(*val maxByLessEqual : forall 'a. ('a -> 'a -> bool) -> 'a -> 'a -> 'a*) +let maxByLessEqual le x y = (if (le y x) then x else y) + +(*val defaultMax : forall 'a. Ord 'a => 'a -> 'a -> 'a*) + +(*val defaultMin : forall 'a. Ord 'a => 'a -> 'a -> 'a*) + +let instance_Basic_classes_OrdMaxMin_var_dict dict_Basic_classes_Ord_a =({ + + max_method = max; + + min_method = min}) + + +(* ========================================================================== *) +(* SetTypes *) +(* ========================================================================== *) + +(* Set implementations use often an order on the elements. This allows the OCaml implementation + to use trees for implementing them. At least, one needs to be able to check equality on sets. + One could use the Ord type-class for sets. However, defining a special typeclass is cleaner + and allows more flexibility. One can make e.g. sure, that this type-class is ignored for + backends like HOL or Isabelle, which don't need it. Moreover, one is not forced to also instantiate + the functions "<", "<=" ... *) + +type 'a setType_class= { + setElemCompare_method : 'a -> 'a -> int +} + +let instance_Basic_classes_SetType_var_dict =({ + + setElemCompare_method = compare}) + +(* ========================================================================== *) +(* Instantiations *) +(* ========================================================================== *) + +let instance_Basic_classes_Eq_bool_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun x y->not ((=) x y))}) + +let boolCompare b1 b2 = ((match (b1, b2) with + | (true, true) -> 0 + | (true, false) -> 1 + | (false, true) -> (-1) + | (false, false) -> 0 +)) + +let instance_Basic_classes_SetType_bool_dict =({ + + setElemCompare_method = boolCompare}) + +(* strings *) + +(*val charEqual : char -> char -> bool*) + +let instance_Basic_classes_Eq_char_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun left right->not (left = right))}) + +(*val stringEquality : string -> string -> bool*) + +let instance_Basic_classes_Eq_string_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun l r->not (l = r))}) + +(* pairs *) + +(*val pairEqual : forall 'a 'b. Eq 'a, Eq 'b => ('a * 'b) -> ('a * 'b) -> bool*) +(*let pairEqual (a1, b1) (a2, b2) = ( + dict_Basic_classes_Eq_a.isEqual_method a1 a2) && ( dict_Basic_classes_Eq_b.isEqual_method b1 b2)*) + +(*val pairEqualBy : forall 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -> bool*) + +let instance_Basic_classes_Eq_tup2_dict dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b =({ + + isEqual_method = (Lem.pair_equal + dict_Basic_classes_Eq_a.isEqual_method dict_Basic_classes_Eq_b.isEqual_method); + + isInequal_method = (fun x y->not ((Lem.pair_equal + dict_Basic_classes_Eq_a.isEqual_method dict_Basic_classes_Eq_b.isEqual_method x y)))}) + +(*val pairCompare : forall 'a 'b. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('a * 'b) -> ('a * 'b) -> ordering*) +let pairCompare cmpa cmpb (a1, b1) (a2, b2) = + (Lem.ordering_cases (cmpa a1 a2) (-1) (cmpb b1 b2) 1) + +let pairLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b (x1, x2) (y1, y2) = (( + dict_Basic_classes_Ord_b.isLess_method x1 y1) || (( dict_Basic_classes_Ord_b.isLessEqual_method x1 y1) && ( dict_Basic_classes_Ord_a.isLess_method x2 y2))) +let pairLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b (x1, x2) (y1, y2) = (( + dict_Basic_classes_Ord_b.isLess_method x1 y1) || (( dict_Basic_classes_Ord_b.isLessEqual_method x1 y1) && ( dict_Basic_classes_Ord_a.isLessEqual_method x2 y2))) + +let pairGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b x12 y12 = (pairLess + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12 x12) +let pairGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b x12 y12 = (pairLessEq + dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y12 x12) + +let instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b =({ + + compare_method = (pairCompare + dict_Basic_classes_Ord_a.compare_method dict_Basic_classes_Ord_b.compare_method); + + isLess_method = + (pairLess dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a); + + isLessEqual_method = + (pairLessEq dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a); + + isGreater_method = + (pairGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b); + + isGreaterEqual_method = + (pairGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b)}) + +let instance_Basic_classes_SetType_tup2_dict dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b =({ + + setElemCompare_method = (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_b.setElemCompare_method)}) + + +(* triples *) + +(*val tripleEqual : forall 'a 'b 'c. Eq 'a, Eq 'b, Eq 'c => ('a * 'b * 'c) -> ('a * 'b * 'c) -> bool*) +let tripleEqual dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b dict_Basic_classes_Eq_c (x1, x2, x3) (y1, y2, y3) = ( (Lem.pair_equal + dict_Basic_classes_Eq_a.isEqual_method (Lem.pair_equal dict_Basic_classes_Eq_b.isEqual_method dict_Basic_classes_Eq_c.isEqual_method)(x1, (x2, x3)) (y1, (y2, y3)))) + +let instance_Basic_classes_Eq_tup3_dict dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b dict_Basic_classes_Eq_c =({ + + isEqual_method = + (tripleEqual dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b + dict_Basic_classes_Eq_c); + + isInequal_method = (fun x y->not (tripleEqual + dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b dict_Basic_classes_Eq_c x y))}) + +(*val tripleCompare : forall 'a 'b 'c. ('a -> 'a -> ordering) -> ('b -> 'b -> ordering) -> ('c -> 'c -> ordering) -> ('a * 'b * 'c) -> ('a * 'b * 'c) -> ordering*) +let tripleCompare cmpa cmpb cmpc (a1, b1, c1) (a2, b2, c2) = +(pairCompare cmpa (pairCompare cmpb cmpc) (a1, (b1, c1)) (a2, (b2, c2))) + +let tripleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c (x1, x2, x3) (y1, y2, y3) = (pairLess + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c) dict_Basic_classes_Ord_a (x1, (x2, x3)) (y1, (y2, y3))) +let tripleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c (x1, x2, x3) (y1, y2, y3) = (pairLessEq + (instance_Basic_classes_Ord_tup2_dict dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c) dict_Basic_classes_Ord_a (x1, (x2, x3)) (y1, (y2, y3))) + +let tripleGreater dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c x123 y123 = (tripleLess + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123 x123) +let tripleGreaterEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c x123 y123 = (tripleLessEq + dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b dict_Basic_classes_Ord_a y123 x123) + +let instance_Basic_classes_Ord_tup3_dict dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b dict_Basic_classes_Ord_c =({ + + compare_method = (tripleCompare + dict_Basic_classes_Ord_a.compare_method dict_Basic_classes_Ord_b.compare_method dict_Basic_classes_Ord_c.compare_method); + + isLess_method = + (tripleLess dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c); + + isLessEqual_method = + (tripleLessEq dict_Basic_classes_Ord_a dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_c); + + isGreater_method = + (tripleGreater dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_a); + + isGreaterEqual_method = + (tripleGreaterEq dict_Basic_classes_Ord_c dict_Basic_classes_Ord_b + dict_Basic_classes_Ord_a)}) + +let instance_Basic_classes_SetType_tup3_dict dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b dict_Basic_classes_SetType_c =({ + + setElemCompare_method = (tripleCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_b.setElemCompare_method dict_Basic_classes_SetType_c.setElemCompare_method)}) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_bool.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_bool.ml new file mode 100644 index 00000000..9b6eb0f6 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_bool.ml @@ -0,0 +1,66 @@ +(*Generated by Lem from bool.lem.*) + + +(* The type bool is hard-coded, so are true and false *) + +(* ----------------------- *) +(* not *) +(* ----------------------- *) + +(*val not : bool -> bool*) +(*let not b = match b with + | true -> false + | false -> true +end*) + +(* ----------------------- *) +(* and *) +(* ----------------------- *) + +(*val && [and] : bool -> bool -> bool*) +(*let && b1 b2 = match (b1, b2) with + | (true, true) -> true + | _ -> false +end*) + + +(* ----------------------- *) +(* or *) +(* ----------------------- *) + +(*val || [or] : bool -> bool -> bool*) +(*let || b1 b2 = match (b1, b2) with + | (false, false) -> false + | _ -> true +end*) + + +(* ----------------------- *) +(* implication *) +(* ----------------------- *) + +(*val --> [imp] : bool -> bool -> bool*) +(*let --> b1 b2 = match (b1, b2) with + | (true, false) -> false + | _ -> true +end*) + + +(* ----------------------- *) +(* equivalence *) +(* ----------------------- *) + +(*val <-> [equiv] : bool -> bool -> bool*) +(*let <-> b1 b2 = match (b1, b2) with + | (true, true) -> true + | (false, false) -> true + | _ -> false +end*) + + +(* ----------------------- *) +(* xor *) +(* ----------------------- *) + +(*val xor : bool -> bool -> bool*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_either.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_either.ml new file mode 100644 index 00000000..9f1b4ad8 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_either.ml @@ -0,0 +1,87 @@ +(*Generated by Lem from either.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_list +open Lem_tuple +open Either + +(*type either 'a 'b + = Left of 'a + | Right of 'b*) + + +(* -------------------------------------------------------------------------- *) +(* Equality. *) +(* -------------------------------------------------------------------------- *) + +(*val eitherEqual : forall 'a 'b. Eq 'a, Eq 'b => (either 'a 'b) -> (either 'a 'b) -> bool*) +(*val eitherEqualBy : forall 'a 'b. ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> (either 'a 'b) -> (either 'a 'b) -> bool*) + +(*let eitherEqualBy eql eqr (left: either 'a 'b) (right: either 'a 'b) = + match (left, right) with + | (Left l, Left l') -> eql l l' + | (Right r, Right r') -> eqr r r' + | _ -> false + end*) +(*let eitherEqual = eitherEqualBy + dict_Basic_classes_Eq_a.isEqual_method dict_Basic_classes_Eq_b.isEqual_method*) + +let instance_Basic_classes_Eq_Either_either_dict dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b =({ + + isEqual_method = (Either.eitherEqualBy + dict_Basic_classes_Eq_a.isEqual_method dict_Basic_classes_Eq_b.isEqual_method); + + isInequal_method = (fun x y->not ((Either.eitherEqualBy + dict_Basic_classes_Eq_a.isEqual_method dict_Basic_classes_Eq_b.isEqual_method x y)))}) + +let either_setElemCompare cmpa cmpb x y = +((match (x, y) with + | (Either.Left x', Either.Left y') -> cmpa x' y' + | (Either.Right x', Either.Right y') -> cmpb x' y' + | (Either.Left _, Either.Right _) -> (-1) + | (Either.Right _, Either.Left _) -> 1 + )) + +let instance_Basic_classes_SetType_Either_either_dict dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b =({ + + setElemCompare_method = (fun x y->either_setElemCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_b.setElemCompare_method x y)}) + + +(* -------------------------------------------------------------------------- *) +(* Utility functions. *) +(* -------------------------------------------------------------------------- *) + +(*val isLeft : forall 'a 'b. either 'a 'b -> bool*) + +(*val isRight : forall 'a 'b. either 'a 'b -> bool*) + + +(*val either : forall 'a 'b 'c. ('a -> 'c) -> ('b -> 'c) -> either 'a 'b -> 'c*) +(*let either fa fb x = match x with + | Left a -> fa a + | Right b -> fb b +end*) + + +(*val partitionEither : forall 'a 'b. list (either 'a 'b) -> (list 'a * list 'b)*) +(*let rec partitionEither l = match l with + | [] -> ([], []) + | x :: xs -> begin + let (ll, rl) = partitionEither xs in + match x with + | Left l -> (l::ll, rl) + | Right r -> (ll, r::rl) + end + end +end*) + + +(*val lefts : forall 'a 'b. list (either 'a 'b) -> list 'a*) + + +(*val rights : forall 'a 'b. list (either 'a 'b) -> list 'b*) + + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_function.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_function.ml new file mode 100644 index 00000000..677adc4c --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_function.ml @@ -0,0 +1,53 @@ +(*Generated by Lem from function.lem.*) +(******************************************************************************) +(* A library for common operations on functions *) +(******************************************************************************) + +open Lem_bool +open Lem_basic_classes + +(* ----------------------- *) +(* identity function *) +(* ----------------------- *) + +(*val id : forall 'a. 'a -> 'a*) +let id x = x + + +(* ----------------------- *) +(* constant function *) +(* ----------------------- *) + +(*val const : forall 'a 'b. 'a -> 'b -> 'a*) + + +(* ----------------------- *) +(* function composition *) +(* ----------------------- *) + +(*val comb : forall 'a 'b 'c. ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c)*) +let comb f g = (fun x -> f (g x)) + + +(* ----------------------- *) +(* function application *) +(* ----------------------- *) + +(*val $ [apply] : forall 'a 'b. ('a -> 'b) -> ('a -> 'b)*) +(*let $ f = (fun x -> f x)*) + +(* ----------------------- *) +(* flipping argument order *) +(* ----------------------- *) + +(*val flip : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('b -> 'a -> 'c)*) +let flip f = (fun x y -> f y x) + + +(* currying / uncurrying *) + +(*val curry : forall 'a 'b 'c. (('a * 'b) -> 'c) -> 'a -> 'b -> 'c*) +let curry f = (fun a b -> f (a, b)) + +(*val uncurry : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('a * 'b -> 'c)*) +let uncurry f (a,b) = (f a b) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_function_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_function_extra.ml new file mode 100644 index 00000000..3c9e7854 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_function_extra.ml @@ -0,0 +1,15 @@ +(*Generated by Lem from function_extra.lem.*) + + +open Lem_maybe +open Lem_bool +open Lem_basic_classes +open Lem_num +open Lem_function + +(* ----------------------- *) +(* getting a unique value *) +(* ----------------------- *) + +(*val THE : forall 'a. ('a -> bool) -> maybe 'a*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_list.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_list.ml new file mode 100644 index 00000000..be308d6e --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_list.ml @@ -0,0 +1,722 @@ +(*Generated by Lem from list.lem.*) + + +open Lem_bool +open Lem_maybe +open Lem_basic_classes +open Lem_tuple +open Lem_num + +(* ========================================================================== *) +(* Basic list functions *) +(* ========================================================================== *) + +(* The type of lists as well as list literals like [], [1;2], ... are hardcoded. + Thus, we can directly dive into derived definitions. *) + + +(* ----------------------- *) +(* cons *) +(* ----------------------- *) + +(*val :: : forall 'a. 'a -> list 'a -> list 'a*) + + +(* ----------------------- *) +(* Emptyness check *) +(* ----------------------- *) + +(*val null : forall 'a. list 'a -> bool*) +let list_null l = ((match l with [] -> true | _ -> false )) + +(* ----------------------- *) +(* Length *) +(* ----------------------- *) + +(*val length : forall 'a. list 'a -> nat*) +(*let rec length l = + match l with + | [] -> 0 + | x :: xs -> (Instance_Num_NumAdd_nat.+) (length xs) 1 + end*) + +(* ----------------------- *) +(* Equality *) +(* ----------------------- *) + +(*val listEqual : forall 'a. Eq 'a => list 'a -> list 'a -> bool*) +(*val listEqualBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) + +let rec listEqualBy eq l1 l2 = ((match (l1,l2) with + | ([], []) -> true + | ([], (_::_)) -> false + | ((_::_), []) -> false + | (x::xs, y :: ys) -> (eq x y && listEqualBy eq xs ys) +)) + +let instance_Basic_classes_Eq_list_dict dict_Basic_classes_Eq_a =({ + + isEqual_method = (listEqualBy + dict_Basic_classes_Eq_a.isEqual_method); + + isInequal_method = (fun l1 l2->not ((listEqualBy + dict_Basic_classes_Eq_a.isEqual_method l1 l2)))}) + + +(* ----------------------- *) +(* compare *) +(* ----------------------- *) + +(*val lexicographicCompare : forall 'a. Ord 'a => list 'a -> list 'a -> ordering*) +(*val lexicographicCompareBy : forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a -> ordering*) + +let rec lexicographic_compare cmp l1 l2 = ((match (l1,l2) with + | ([], []) -> 0 + | ([], _::_) -> (-1) + | (_::_, []) -> 1 + | (x::xs, y::ys) -> begin + Lem.ordering_cases (cmp x y) (-1) (lexicographic_compare cmp xs ys) 1 + end +)) + +(*val lexicographicLess : forall 'a. Ord 'a => list 'a -> list 'a -> bool*) +(*val lexicographicLessBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) +let rec lexicographic_less less less_eq l1 l2 = ((match (l1,l2) with + | ([], []) -> false + | ([], _::_) -> true + | (_::_, []) -> false + | (x::xs, y::ys) -> ((less x y) || ((less_eq x y) && (lexicographic_less less less_eq xs ys))) +)) + +(*val lexicographicLessEq : forall 'a. Ord 'a => list 'a -> list 'a -> bool*) +(*val lexicographicLessEqBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) +let rec lexicographic_less_eq less less_eq l1 l2 = ((match (l1,l2) with + | ([], []) -> true + | ([], _::_) -> true + | (_::_, []) -> false + | (x::xs, y::ys) -> (less x y || (less_eq x y && lexicographic_less_eq less less_eq xs ys)) +)) + + +let instance_Basic_classes_Ord_list_dict dict_Basic_classes_Ord_a =({ + + compare_method = (lexicographic_compare + dict_Basic_classes_Ord_a.compare_method); + + isLess_method = (lexicographic_less + dict_Basic_classes_Ord_a.isLess_method dict_Basic_classes_Ord_a.isLessEqual_method); + + isLessEqual_method = (lexicographic_less_eq + dict_Basic_classes_Ord_a.isLess_method dict_Basic_classes_Ord_a.isLessEqual_method); + + isGreater_method = (fun x y->(lexicographic_less + dict_Basic_classes_Ord_a.isLess_method dict_Basic_classes_Ord_a.isLessEqual_method y x)); + + isGreaterEqual_method = (fun x y->(lexicographic_less_eq + dict_Basic_classes_Ord_a.isLess_method dict_Basic_classes_Ord_a.isLessEqual_method y x))}) + + +(* ----------------------- *) +(* Append *) +(* ----------------------- *) + +(*val ++ : forall 'a. list 'a -> list 'a -> list 'a*) (* originally append *) +(*let rec ++ xs ys = match xs with + | [] -> ys + | x :: xs' -> x :: (xs' ++ ys) + end*) + +(* ----------------------- *) +(* snoc *) +(* ----------------------- *) + +(*val snoc : forall 'a. 'a -> list 'a -> list 'a*) +let snoc e l = (List.append l [e]) + + +(* ----------------------- *) +(* Map *) +(* ----------------------- *) + +(*val map : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*) +(*let rec map f l = match l with + | [] -> [] + | x :: xs -> (f x) :: map f xs +end*) + +(* ----------------------- *) +(* Reverse *) +(* ----------------------- *) + +(* First lets define the function [reverse_append], which is + closely related to reverse. [reverse_append l1 l2] appends the list [l2] to the reverse of [l1]. + This can be implemented more efficienctly than appending and is + used to implement reverse. *) + +(*val reverseAppend : forall 'a. list 'a -> list 'a -> list 'a*) (* originally named rev_append *) +(*let rec reverseAppend l1 l2 = match l1 with + | [] -> l2 + | x :: xs -> reverseAppend xs (x :: l2) + end*) + +(* Reversing a list *) +(*val reverse : forall 'a. list 'a -> list 'a*) (* originally named rev *) +(*let reverse l = reverseAppend l []*) + + +(* ----------------------- *) +(* Reverse Map *) +(* ----------------------- *) + +(*val reverseMap : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*) + + + +(* ========================================================================== *) +(* Folding *) +(* ========================================================================== *) + +(* ----------------------- *) +(* fold left *) +(* ----------------------- *) + +(*val foldl : forall 'a 'b. ('a -> 'b -> 'a) -> 'a -> list 'b -> 'a*) (* originally foldl *) + +(*let rec foldl f b l = match l with + | [] -> b + | x :: xs -> foldl f (f b x) xs +end*) + + +(* ----------------------- *) +(* fold right *) +(* ----------------------- *) + +(*val foldr : forall 'a 'b. ('a -> 'b -> 'b) -> 'b -> list 'a -> 'b*) (* originally foldr with different argument order *) +(*let rec foldr f b l = match l with + | [] -> b + | x :: xs -> f x (foldr f b xs) +end*) + + +(* ----------------------- *) +(* concatenating lists *) +(* ----------------------- *) + +(*val concat : forall 'a. list (list 'a) -> list 'a*) (* before also called "flatten" *) +(*let concat = foldr (++) []*) + + +(* -------------------------- *) +(* concatenating with mapping *) +(* -------------------------- *) + +(*val concatMap : forall 'a 'b. ('a -> list 'b) -> list 'a -> list 'b*) + + +(* ------------------------- *) +(* universal qualification *) +(* ------------------------- *) + +(*val all : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally for_all *) +(*let all P l = foldl (fun r e -> P e && r) true l*) + + + +(* ------------------------- *) +(* existential qualification *) +(* ------------------------- *) + +(*val any : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally exist *) +(*let any P l = foldl (fun r e -> P e || r) false l*) + + +(* ------------------------- *) +(* dest_init *) +(* ------------------------- *) + +(* get the initial part and the last element of the list in a safe way *) + +(*val dest_init : forall 'a. list 'a -> maybe (list 'a * 'a)*) + +let rec dest_init_aux rev_init last_elem_seen to_process = +((match to_process with + | [] -> (List.rev rev_init, last_elem_seen) + | x::xs -> dest_init_aux (last_elem_seen::rev_init) x xs + )) + +let dest_init l = ((match l with + | [] -> None + | x::xs -> Some (dest_init_aux [] x xs) +)) + + +(* ========================================================================== *) +(* Indexing lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* index / nth with maybe *) +(* ------------------------- *) + +(*val index : forall 'a. list 'a -> nat -> maybe 'a*) + +let rec list_index l n = ((match l with + | [] -> None + | x :: xs -> if n = 0 then Some x else list_index xs (Nat_num.nat_monus n( 1)) +)) + +(* ------------------------- *) +(* findIndices *) +(* ------------------------- *) + +(* [findIndices P l] returns the indices of all elements of list [l] that satisfy predicate [P]. + Counting starts with 0, the result list is sorted ascendingly *) +(*val findIndices : forall 'a. ('a -> bool) -> list 'a -> list nat*) + +let rec find_indices_aux (i:int) p0 l = +((match l with + | [] -> [] + | x :: xs -> if p0 x then i :: find_indices_aux (i + 1) p0 xs else find_indices_aux (i + 1) p0 xs + )) +let find_indices p0 l = (find_indices_aux( 0) p0 l) + + + +(* ------------------------- *) +(* findIndex *) +(* ------------------------- *) + +(* findIndex returns the first index of a list that satisfies a given predicate. *) +(*val findIndex : forall 'a. ('a -> bool) -> list 'a -> maybe nat*) +let find_index p0 l = ((match find_indices p0 l with + | [] -> None + | x :: _ -> Some x +)) + +(* ------------------------- *) +(* elemIndices *) +(* ------------------------- *) + +(*val elemIndices : forall 'a. Eq 'a => 'a -> list 'a -> list nat*) + +(* ------------------------- *) +(* elemIndex *) +(* ------------------------- *) + +(*val elemIndex : forall 'a. Eq 'a => 'a -> list 'a -> maybe nat*) + + +(* ========================================================================== *) +(* Creating lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* genlist *) +(* ------------------------- *) + +(* [genlist f n] generates the list [f 0; f 1; ... (f (n-1))] *) +(*val genlist : forall 'a. (nat -> 'a) -> nat -> list 'a*) + + +let rec genlist f n = + ( + if(n = 0) then ([]) else + (let n'0 =(Nat_num.nat_monus n ( 1)) in snoc (f n'0) (genlist f n'0))) + + +(* ------------------------- *) +(* replicate *) +(* ------------------------- *) + +(*val replicate : forall 'a. nat -> 'a -> list 'a*) +let rec replicate n x = + ( + if(n = 0) then ([]) else + (let n'0 =(Nat_num.nat_monus n ( 1)) in x :: replicate n'0 x)) + + +(* ========================================================================== *) +(* Sublists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* splitAt *) +(* ------------------------- *) + +(* [splitAt n xs] returns a tuple (xs1, xs2), with "append xs1 xs2 = xs" and + "length xs1 = n". If there are not enough elements + in [xs], the original list and the empty one are returned. *) +(*val splitAt : forall 'a. nat -> list 'a -> (list 'a * list 'a)*) +let rec split_at n l = + ((match l with + | [] -> ([], []) + | x::xs -> + if n <= 0 then ([], l) else + begin + let (l1, l2) = (split_at (Nat_num.nat_monus n( 1)) xs) in + ((x::l1), l2) + end + )) + + +(* ------------------------- *) +(* take *) +(* ------------------------- *) + +(* take n xs returns the prefix of xs of length n, or xs itself if n > length xs *) +(*val take : forall 'a. nat -> list 'a -> list 'a*) +let take n l = (fst (split_at n l)) + + + +(* ------------------------- *) +(* drop *) +(* ------------------------- *) + +(* [drop n xs] drops the first [n] elements of [xs]. It returns the empty list, if [n] > [length xs]. *) +(*val drop : forall 'a. nat -> list 'a -> list 'a*) +let drop n l = (snd (split_at n l)) + +(* ------------------------- *) +(* dropWhile *) +(* ------------------------- *) + +(* [dropWhile p xs] drops the first elements of [xs] that satisfy [p]. *) +(*val dropWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*) +let rec dropWhile p l = ((match l with + | [] -> [] + | x::xs -> if p x then dropWhile p xs else l +)) + + +(* ------------------------- *) +(* takeWhile *) +(* ------------------------- *) + +(* [takeWhile p xs] takes the first elements of [xs] that satisfy [p]. *) +(*val takeWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*) +let rec takeWhile p l = ((match l with + | [] -> [] + | x::xs -> if p x then x::takeWhile p xs else [] +)) + + +(* ------------------------- *) +(* isPrefixOf *) +(* ------------------------- *) + +(*val isPrefixOf : forall 'a. Eq 'a => list 'a -> list 'a -> bool*) +let rec isPrefixOf dict_Basic_classes_Eq_a l1 l2 = ((match (l1, l2) with + | ([], _) -> true + | (_::_, []) -> false + | (x::xs, y::ys) -> ( + dict_Basic_classes_Eq_a.isEqual_method x y) && isPrefixOf dict_Basic_classes_Eq_a xs ys +)) + +(* ------------------------- *) +(* update *) +(* ------------------------- *) +(*val update : forall 'a. list 'a -> nat -> 'a -> list 'a*) +let rec list_update l n e = + ((match l with + | [] -> [] + | x :: xs -> if n = 0 then e :: xs else x :: (list_update xs ( Nat_num.nat_monus n( 1)) e) +)) + + + +(* ========================================================================== *) +(* Searching lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* Membership test *) +(* ------------------------- *) + +(* The membership test, one of the basic list functions, is actually tricky for + Lem, because it is tricky, which equality to use. From Lem`s point of + perspective, we want to use the equality provided by the equality type - class. + This allows for example to check whether a set is in a list of sets. + + However, in order to use the equality type class, elem essentially becomes + existential quantification over lists. For types, which implement semantic + equality (=) with syntactic equality, this is overly complicated. In + our theorem prover backend, we would end up with overly complicated, harder + to read definitions and some of the automation would be harder to apply. + Moreover, nearly all the old Lem generated code would change and require + (hopefully minor) adaptions of proofs. + + For now, we ignore this problem and just demand, that all instances of + the equality type class do the right thing for the theorem prover backends. +*) + +(*val elem : forall 'a. Eq 'a => 'a -> list 'a -> bool*) +(*val elemBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> bool*) + +let elemBy eq e l = (List.exists (eq e) l) +(*let elem = elemBy dict_Basic_classes_Eq_a.isEqual_method*) + +(* ------------------------- *) +(* Find *) +(* ------------------------- *) +(*val find : forall 'a. ('a -> bool) -> list 'a -> maybe 'a*) (* previously not of maybe type *) +let rec list_find_opt p0 l = ((match l with + | [] -> None + | x :: xs -> if p0 x then Some x else list_find_opt p0 xs +)) + + +(* ----------------------------- *) +(* Lookup in an associative list *) +(* ----------------------------- *) +(*val lookup : forall 'a 'b. Eq 'a => 'a -> list ('a * 'b) -> maybe 'b*) +(*val lookupBy : forall 'a 'b. ('a -> 'a -> bool) -> 'a -> list ('a * 'b) -> maybe 'b*) + +(* DPM: eta-expansion for Coq backend type-inference. *) +let lookupBy eq k m = (Lem.option_map (fun x -> snd x) (list_find_opt (fun (k', _) -> eq k k') m)) + +(* ------------------------- *) +(* filter *) +(* ------------------------- *) +(*val filter : forall 'a. ('a -> bool) -> list 'a -> list 'a*) +(*let rec filter P l = match l with + | [] -> [] + | x :: xs -> if (P x) then x :: (filter P xs) else filter P xs + end*) + + +(* ------------------------- *) +(* partition *) +(* ------------------------- *) +(*val partition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*) +(*let partition P l = (filter P l, filter (fun x -> not (P x)) l)*) + +(*val reversePartition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*) +let reversePartition p0 l = (List.partition p0 (List.rev l)) + + +(* ------------------------- *) +(* delete first element *) +(* with certain property *) +(* ------------------------- *) + +(*val deleteFirst : forall 'a. ('a -> bool) -> list 'a -> maybe (list 'a)*) +let rec list_delete_first p0 l = ((match l with + | [] -> None + | x :: xs -> if (p0 x) then Some xs else Lem.option_map (fun xs' -> x :: xs') (list_delete_first p0 xs) + )) + + +(*val delete : forall 'a. Eq 'a => 'a -> list 'a -> list 'a*) +(*val deleteBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a*) + +let list_delete eq x l = (Lem.option_default l (list_delete_first (eq x) l)) + + +(* ========================================================================== *) +(* Zipping and unzipping lists *) +(* ========================================================================== *) + +(* ------------------------- *) +(* zip *) +(* ------------------------- *) + +(* zip takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded. *) +(*val zip : forall 'a 'b. list 'a -> list 'b -> list ('a * 'b)*) (* before combine *) +let rec list_combine l1 l2 = ((match (l1, l2) with + | (x :: xs, y :: ys) -> (x, y) :: list_combine xs ys + | _ -> [] +)) + +(* ------------------------- *) +(* unzip *) +(* ------------------------- *) + +(*val unzip: forall 'a 'b. list ('a * 'b) -> (list 'a * list 'b)*) +(*let rec unzip l = match l with + | [] -> ([], []) + | (x, y) :: xys -> let (xs, ys) = unzip xys in (x :: xs, y :: ys) +end*) + + +let instance_Basic_classes_SetType_list_dict dict_Basic_classes_SetType_a =({ + + setElemCompare_method = (lexicographic_compare + dict_Basic_classes_SetType_a.setElemCompare_method)}) + +(* ------------------------- *) +(* distinct elements *) +(* ------------------------- *) + +(*val allDistinct : forall 'a. Eq 'a => list 'a -> bool*) +let rec allDistinct dict_Basic_classes_Eq_a l = + ((match l with + | [] -> true + | (x::l') -> not (List.mem x l') && allDistinct + dict_Basic_classes_Eq_a l' + )) + +(* some more useful functions *) +(*val mapMaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b*) +let rec mapMaybe f xs = +((match xs with + | [] -> [] + | x::xs -> + (match f x with + | None -> mapMaybe f xs + | Some y -> y :: (mapMaybe f xs) + ) + )) + +(*val mapi : forall 'a 'b. (nat -> 'a -> 'b) -> list 'a -> list 'b*) +let rec mapiAux f (n : int) l = ((match l with + | [] -> [] + | x :: xs -> (f n x) :: mapiAux f (n + 1) xs +)) +let mapi f l = (mapiAux f( 0) l) + +(* ========================================================================== *) +(* Comments (not clean yet, please ignore the rest of the file) *) +(* ========================================================================== *) + +(* ----------------------- *) +(* skipped from Haskell Lib*) +(* ----------------------- + +intersperse :: a -> [a] -> [a] +intercalate :: [a] -> [[a]] -> [a] +transpose :: [[a]] -> [[a]] +subsequences :: [a] -> [[a]] +permutations :: [a] -> [[a]] +foldl` :: (a -> b -> a) -> a -> [b] -> aSource +foldl1` :: (a -> a -> a) -> [a] -> aSource + +and +or +sum +product +maximum +minimum +scanl +scanr +scanl1 +scanr1 +Accumulating maps + +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source + +iterate :: (a -> a) -> a -> [a] +repeat :: a -> [a] +cycle :: [a] -> [a] +unfoldr + + +takeWhile :: (a -> Bool) -> [a] -> [a]Source +dropWhile :: (a -> Bool) -> [a] -> [a]Source +dropWhileEnd :: (a -> Bool) -> [a] -> [a]Source +span :: (a -> Bool) -> [a] -> ([a], [a])Source +break :: (a -> Bool) -> [a] -> ([a], [a])Source +break p is equivalent to span (not . p). +stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]Source +group :: Eq a => [a] -> [[a]]Source +inits :: [a] -> [[a]]Source +tails :: [a] -> [[a]]Source + + +isPrefixOf :: Eq a => [a] -> [a] -> BoolSource +isSuffixOf :: Eq a => [a] -> [a] -> BoolSource +isInfixOf :: Eq a => [a] -> [a] -> BoolSource + + + +notElem :: Eq a => a -> [a] -> BoolSource + +zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]Source +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]Source +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]Source +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]Source +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)]Source + +zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]Source +zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]Source +zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]Source +zipWith5 :: (a -> b -> c -> d -> e -> f) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f]Source +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]Source +zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h]Source + + +unzip3 :: [(a, b, c)] -> ([a], [b], [c])Source +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])Source +unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])Source +unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])Source +unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g])Source + + +lines :: String -> [String]Source +words :: String -> [String]Source +unlines :: [String] -> StringSource +unwords :: [String] -> StringSource +nub :: Eq a => [a] -> [a]Source +delete :: Eq a => a -> [a] -> [a]Source + +(\\) :: Eq a => [a] -> [a] -> [a]Source +union :: Eq a => [a] -> [a] -> [a]Source +intersect :: Eq a => [a] -> [a] -> [a]Source +sort :: Ord a => [a] -> [a]Source +insert :: Ord a => a -> [a] -> [a]Source + + +nubBy :: (a -> a -> Bool) -> [a] -> [a]Source +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]Source +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source +groupBy :: (a -> a -> Bool) -> [a] -> [[a]]Source +sortBy :: (a -> a -> Ordering) -> [a] -> [a]Source +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]Source +maximumBy :: (a -> a -> Ordering) -> [a] -> aSource +minimumBy :: (a -> a -> Ordering) -> [a] -> aSource +genericLength :: Num i => [b] -> iSource +genericTake :: Integral i => i -> [a] -> [a]Source +genericDrop :: Integral i => i -> [a] -> [a]Source +genericSplitAt :: Integral i => i -> [b] -> ([b], [b])Source +genericIndex :: Integral a => [b] -> a -> bSource +genericReplicate :: Integral i => i -> a -> [a]Source + + +*) + + +(* ----------------------- *) +(* skipped from Lem Lib *) +(* ----------------------- + + +val for_all2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool +val exists2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool +val map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c +val rev_map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c +val fold_left2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'a) -> 'a -> list 'b -> list 'c -> 'a +val fold_right2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'c) -> list 'a -> list 'b -> 'c -> 'c + + +(* now maybe result and called lookup *) +val assoc : forall 'a 'b. 'a -> list ('a * 'b) -> 'b +let inline {ocaml} assoc = Ocaml.List.assoc + + +val mem_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> bool +val remove_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> list ('a * 'b) + + + +val stable_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a +val fast_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a + +val merge : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a -> list 'a +val intersect : forall 'a. list 'a -> list 'a -> list 'a + + +*) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_list_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_list_extra.ml new file mode 100644 index 00000000..8769b232 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_list_extra.ml @@ -0,0 +1,85 @@ +(*Generated by Lem from list_extra.lem.*) + + +open Lem_bool +open Lem_maybe +open Lem_basic_classes +open Lem_tuple +open Lem_num +open Lem_list +open Lem_assert_extra + +(* ------------------------- *) +(* head of non-empty list *) +(* ------------------------- *) +(*val head : forall 'a. list 'a -> 'a*) +(*let head l = match l with | x::xs -> x | [] -> failwith "List_extra.head of empty list" end*) + + +(* ------------------------- *) +(* tail of non-empty list *) +(* ------------------------- *) +(*val tail : forall 'a. list 'a -> list 'a*) +(*let tail l = match l with | x::xs -> xs | [] -> failwith "List_extra.tail of empty list" end*) + + +(* ------------------------- *) +(* last *) +(* ------------------------- *) +(*val last : forall 'a. list 'a -> 'a*) +let rec last l = ((match l with | [x] -> x | x1::x2::xs -> last (x2 :: xs) | [] -> failwith "List_extra.last of empty list" )) + + +(* ------------------------- *) +(* init *) +(* ------------------------- *) + +(* All elements of a non-empty list except the last one. *) +(*val init : forall 'a. list 'a -> list 'a*) +let rec init l = ((match l with | [x] -> [] | x1::x2::xs -> x1::(init (x2::xs)) | [] -> failwith "List_extra.init of empty list" )) + + +(* ------------------------- *) +(* foldl1 / foldr1 *) +(* ------------------------- *) + +(* folding functions for non-empty lists, + which don`t take the base case *) +(*val foldl1 : forall 'a. ('a -> 'a -> 'a) -> list 'a -> 'a*) +let foldl1 f x_xs = ((match x_xs with | (x :: xs) -> List.fold_left f x xs | [] -> failwith "List_extra.foldl1 of empty list" )) + +(*val foldr1 : forall 'a. ('a -> 'a -> 'a) -> list 'a -> 'a*) +let foldr1 f x_xs = ((match x_xs with | (x :: xs) -> List.fold_right f xs x | [] -> failwith "List_extra.foldr1 of empty list" )) + + +(* ------------------------- *) +(* nth element *) +(* ------------------------- *) + +(* get the nth element of a list *) +(*val nth : forall 'a. list 'a -> nat -> 'a*) +(*let nth l n = match index l n with Just e -> e | Nothing -> failwith "List_extra.nth" end*) + + +(* ------------------------- *) +(* Find_non_pure *) +(* ------------------------- *) +(*val findNonPure : forall 'a. ('a -> bool) -> list 'a -> 'a*) +let findNonPure p0 l = ((match (list_find_opt p0 l) with + | Some e -> e + | None -> failwith "List_extra.findNonPure" +)) + + +(* ------------------------- *) +(* zip same length *) +(* ------------------------- *) + +(*val zipSameLength : forall 'a 'b. list 'a -> list 'b -> list ('a * 'b)*) +(*let rec zipSameLength l1 l2 = match (l1, l2) with + | (x :: xs, y :: ys) -> (x, y) :: zipSameLength xs ys + | ([], []) -> [] + | _ -> failwith "List_extra.zipSameLength of different length lists" + +end*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_map.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_map.ml new file mode 100644 index 00000000..a1aab076 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_map.ml @@ -0,0 +1,154 @@ +(*Generated by Lem from map.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_function +open Lem_maybe +open Lem_list +open Lem_tuple +open Lem_set +open Lem_num + +(*type map 'k 'v*) + + + +(* -------------------------------------------------------------------------- *) +(* Map equality. *) +(* -------------------------------------------------------------------------- *) + +(*val mapEqual : forall 'k 'v. Eq 'k, Eq 'v => map 'k 'v -> map 'k 'v -> bool*) +(*val mapEqualBy : forall 'k 'v. ('k -> 'k -> bool) -> ('v -> 'v -> bool) -> map 'k 'v -> map 'k 'v -> bool*) + +let instance_Basic_classes_Eq_Map_map_dict dict_Basic_classes_Eq_k dict_Basic_classes_Eq_v =({ + + isEqual_method = (Pmap.equal dict_Basic_classes_Eq_v.isEqual_method); + + isInequal_method = (fun m1 m2->not ((Pmap.equal dict_Basic_classes_Eq_v.isEqual_method m1 m2)))}) + + +(* -------------------------------------------------------------------------- *) +(* Map type class *) +(* -------------------------------------------------------------------------- *) + +type 'a mapKeyType_class= { + mapKeyCompare_method : 'a -> 'a -> int +} + +let instance_Map_MapKeyType_var_dict dict_Basic_classes_SetType_a =({ + + mapKeyCompare_method = dict_Basic_classes_SetType_a.setElemCompare_method}) + + +(* -------------------------------------------------------------------------- *) +(* Empty maps *) +(* -------------------------------------------------------------------------- *) + +(*val empty : forall 'k 'v. MapKeyType 'k => map 'k 'v*) +(*val emptyBy : forall 'k 'v. ('k -> 'k -> ordering) -> map 'k 'v*) + + +(* -------------------------------------------------------------------------- *) +(* Insertion *) +(* -------------------------------------------------------------------------- *) + +(*val insert : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v -> map 'k 'v*) + + +(* -------------------------------------------------------------------------- *) +(* Singleton *) +(* -------------------------------------------------------------------------- *) + +(*val singleton : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v*) + + + +(* -------------------------------------------------------------------------- *) +(* Emptyness check *) +(* -------------------------------------------------------------------------- *) + +(*val null : forall 'k 'v. MapKeyType 'k, Eq 'k, Eq 'v => map 'k 'v -> bool*) + + +(* -------------------------------------------------------------------------- *) +(* lookup *) +(* -------------------------------------------------------------------------- *) + +(*val lookupBy : forall 'k 'v. ('k -> 'k -> ordering) -> 'k -> map 'k 'v -> maybe 'v*) + +(*val lookup : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> maybe 'v*) + +(* -------------------------------------------------------------------------- *) +(* findWithDefault *) +(* -------------------------------------------------------------------------- *) + +(*val findWithDefault : forall 'k 'v. MapKeyType 'k => 'k -> 'v -> map 'k 'v -> 'v*) + +(* -------------------------------------------------------------------------- *) +(* from lists *) +(* -------------------------------------------------------------------------- *) + +(*val fromList : forall 'k 'v. MapKeyType 'k => list ('k * 'v) -> map 'k 'v*) +let fromList dict_Map_MapKeyType_k l = (List.fold_left (fun m (k,v) -> Pmap.add k v m) (Pmap.empty + dict_Map_MapKeyType_k.mapKeyCompare_method) l) + + +(* -------------------------------------------------------------------------- *) +(* to sets / domain / range *) +(* -------------------------------------------------------------------------- *) + +(*val toSet : forall 'k 'v. MapKeyType 'k, SetType 'k, SetType 'v => map 'k 'v -> set ('k * 'v)*) +(*val toSetBy : forall 'k 'v. (('k * 'v) -> ('k * 'v) -> ordering) -> map 'k 'v -> set ('k * 'v)*) + + +(*val domainBy : forall 'k 'v. ('k -> 'k -> ordering) -> map 'k 'v -> set 'k*) +(*val domain : forall 'k 'v. MapKeyType 'k, SetType 'k => map 'k 'v -> set 'k*) + + +(*val range : forall 'k 'v. MapKeyType 'k, SetType 'v => map 'k 'v -> set 'v*) +(*val rangeBy : forall 'k 'v. ('v -> 'v -> ordering) -> map 'k 'v -> set 'v*) + + +(* -------------------------------------------------------------------------- *) +(* member *) +(* -------------------------------------------------------------------------- *) + +(*val member : forall 'k 'v. MapKeyType 'k, SetType 'k, Eq 'k => 'k -> map 'k 'v -> bool*) + +(*val notMember : forall 'k 'v. MapKeyType 'k, SetType 'k, Eq 'k => 'k -> map 'k 'v -> bool*) + +(* -------------------------------------------------------------------------- *) +(* Quantification *) +(* -------------------------------------------------------------------------- *) + +(*val any : forall 'k 'v. MapKeyType 'k, Eq 'v => ('k -> 'v -> bool) -> map 'k 'v -> bool*) +(*val all : forall 'k 'v. MapKeyType 'k, Eq 'v => ('k -> 'v -> bool) -> map 'k 'v -> bool*) + +(*let all P m = (forall k v. (P k v && ((Instance_Basic_classes_Eq_Maybe_maybe.=) (lookup k m) (Just v))))*) + + +(* -------------------------------------------------------------------------- *) +(* Set-like operations. *) +(* -------------------------------------------------------------------------- *) +(*val deleteBy : forall 'k 'v. ('k -> 'k -> ordering) -> 'k -> map 'k 'v -> map 'k 'v*) +(*val delete : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> map 'k 'v*) +(*val deleteSwap : forall 'k 'v. MapKeyType 'k => map 'k 'v -> 'k -> map 'k 'v*) + +(*val union : forall 'k 'v. MapKeyType 'k => map 'k 'v -> map 'k 'v -> map 'k 'v*) + +(*val unions : forall 'k 'v. MapKeyType 'k => list (map 'k 'v) -> map 'k 'v*) + + +(* -------------------------------------------------------------------------- *) +(* Maps (in the functor sense). *) +(* -------------------------------------------------------------------------- *) + +(*val map : forall 'k 'v 'w. MapKeyType 'k => ('v -> 'w) -> map 'k 'v -> map 'k 'w*) + +(*val mapi : forall 'k 'v 'w. MapKeyType 'k => ('k -> 'v -> 'w) -> map 'k 'v -> map 'k 'w*) + +(* -------------------------------------------------------------------------- *) +(* Cardinality *) +(* -------------------------------------------------------------------------- *) +(*val size : forall 'k 'v. MapKeyType 'k, SetType 'k => map 'k 'v -> nat*) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_map_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_map_extra.ml new file mode 100644 index 00000000..c27f6b73 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_map_extra.ml @@ -0,0 +1,41 @@ +(*Generated by Lem from map_extra.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_function +open Lem_assert_extra +open Lem_maybe +open Lem_list +open Lem_num +open Lem_set +open Lem_map + +(* -------------------------------------------------------------------------- *) +(* find *) +(* -------------------------------------------------------------------------- *) + +(*val find : forall 'k 'v. MapKeyType 'k => 'k -> map 'k 'v -> 'v*) +(*let find k m = match (lookup k m) with Just x -> x | Nothing -> failwith "Map_extra.find" end*) + + + +(* -------------------------------------------------------------------------- *) +(* from sets / domain / range *) +(* -------------------------------------------------------------------------- *) + + +(*val fromSet : forall 'k 'v. MapKeyType 'k => ('k -> 'v) -> set 'k -> map 'k 'v*) +(*let fromSet f s = Set_helpers.fold (fun k m -> Map.insert k (f k) m) s Map.empty*) + + +(* -------------------------------------------------------------------------- *) +(* fold *) +(* -------------------------------------------------------------------------- *) + +(*val fold : forall 'k 'v 'r. MapKeyType 'k, SetType 'k, SetType 'v => ('k -> 'v -> 'r -> 'r) -> map 'k 'v -> 'r -> 'r*) +(*let fold f m v = Set_helpers.fold (fun (k, v) r -> f k v r) (Map.toSet m) v*) + + +(*val toList: forall 'k 'v. MapKeyType 'k => map 'k 'v -> list ('k * 'v)*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_maybe.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_maybe.ml new file mode 100644 index 00000000..8f35b88f --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_maybe.ml @@ -0,0 +1,98 @@ +(*Generated by Lem from maybe.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_function + +(* ========================================================================== *) +(* Basic stuff *) +(* ========================================================================== *) + +(*type maybe 'a = + | Nothing + | Just of 'a*) + + +(*val maybeEqual : forall 'a. Eq 'a => maybe 'a -> maybe 'a -> bool*) +(*val maybeEqualBy : forall 'a. ('a -> 'a -> bool) -> maybe 'a -> maybe 'a -> bool*) + +(*let maybeEqualBy eq x y = match (x,y) with + | (Nothing, Nothing) -> true + | (Nothing, Just _) -> false + | (Just _, Nothing) -> false + | (Just x', Just y') -> (eq x' y') +end*) + +let instance_Basic_classes_Eq_Maybe_maybe_dict dict_Basic_classes_Eq_a =({ + + isEqual_method = (Lem.option_equal + dict_Basic_classes_Eq_a.isEqual_method); + + isInequal_method = (fun x y->not ((Lem.option_equal + dict_Basic_classes_Eq_a.isEqual_method x y)))}) + + +let maybeCompare cmp x y = ((match (x,y) with + | (None, None) -> 0 + | (None, Some _) -> (-1) + | (Some _, None) -> 1 + | (Some x', Some y') -> cmp x' y' +)) + +let instance_Basic_classes_SetType_Maybe_maybe_dict dict_Basic_classes_SetType_a =({ + + setElemCompare_method = (maybeCompare + dict_Basic_classes_SetType_a.setElemCompare_method)}) + + +(* ----------------------- *) +(* maybe *) +(* ----------------------- *) + +(*val maybe : forall 'a 'b. 'b -> ('a -> 'b) -> maybe 'a -> 'b*) +(*let maybe d f mb = match mb with + | Just a -> f a + | Nothing -> d +end*) + +(* ----------------------- *) +(* isJust / isNothing *) +(* ----------------------- *) + +(*val isJust : forall 'a. maybe 'a -> bool*) +(*let isJust mb = match mb with + | Just _ -> true + | Nothing -> false +end*) + +(*val isNothing : forall 'a. maybe 'a -> bool*) +(*let isNothing mb = match mb with + | Just _ -> false + | Nothing -> true +end*) + +(* ----------------------- *) +(* fromMaybe *) +(* ----------------------- *) + +(*val fromMaybe : forall 'a. 'a -> maybe 'a -> 'a*) +(*let fromMaybe d mb = match mb with + | Just v -> v + | Nothing -> d +end*) + +(* ----------------------- *) +(* map *) +(* ----------------------- *) + +(*val map : forall 'a 'b. ('a -> 'b) -> maybe 'a -> maybe 'b*) +(*let map f = maybe Nothing (fun v -> Just (f v))*) + + +(* ----------------------- *) +(* bind *) +(* ----------------------- *) + +(*val bind : forall 'a 'b. maybe 'a -> ('a -> maybe 'b) -> maybe 'b*) +(*let bind mb f = maybe Nothing f mb*) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_maybe_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_maybe_extra.ml new file mode 100644 index 00000000..7260b642 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_maybe_extra.ml @@ -0,0 +1,14 @@ +(*Generated by Lem from maybe_extra.lem.*) + + +open Lem_basic_classes +open Lem_maybe +open Lem_assert_extra + +(* ----------------------- *) +(* fromJust *) +(* ----------------------- *) + +(*val fromJust : forall 'a. maybe 'a -> 'a*) +let fromJust op = ((match op with | Some v -> v | None -> failwith "fromJust of Nothing" )) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_num.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_num.ml new file mode 100644 index 00000000..f2e10846 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_num.ml @@ -0,0 +1,901 @@ +(*Generated by Lem from num.lem.*) + + +open Lem_bool +open Lem_basic_classes + +(*class inline ( Numeral 'a ) + val fromNumeral : numeral -> 'a +end*) + +(* ========================================================================== *) +(* Syntactic type-classes for common operations *) +(* ========================================================================== *) + +(* Typeclasses can be used as a mean to overload constants like "+", "-", etc *) + +type 'a numNegate_class= { + numNegate_method : 'a -> 'a +} + +type 'a numAbs_class= { + abs_method : 'a -> 'a +} + +type 'a numAdd_class= { + numAdd_method : 'a -> 'a -> 'a +} + +type 'a numMinus_class= { + numMinus_method : 'a -> 'a -> 'a +} + +type 'a numMult_class= { + numMult_method : 'a -> 'a -> 'a +} + +type 'a numPow_class= { + numPow_method : 'a -> int -> 'a +} + +type 'a numDivision_class= { + numDivision_method : 'a -> 'a -> 'a +} + +type 'a numIntegerDivision_class= { + div_method : 'a -> 'a -> 'a +} + + +type 'a numRemainder_class= { + mod_method : 'a -> 'a -> 'a +} + +type 'a numSucc_class= { + succ_method : 'a -> 'a +} + +type 'a numPred_class= { + pred_method : 'a -> 'a +} + + +(* ----------------------- *) +(* natural *) +(* ----------------------- *) + +(* unbounded size natural numbers *) +(*type natural*) + + +(* ----------------------- *) +(* int *) +(* ----------------------- *) + +(* bounded size integers with uncertain length *) + +(*type int*) + + +(* ----------------------- *) +(* integer *) +(* ----------------------- *) + +(* unbounded size integers *) + +(*type integer*) + +(* ----------------------- *) +(* bint *) +(* ----------------------- *) + +(* TODO the bounded ints are only partially implemented, use with care. *) + +(* 32 bit integers *) +(*type int32*) + +(* 64 bit integers *) +(*type int64*) + + +(* ----------------------- *) +(* rational *) +(* ----------------------- *) + +(* unbounded size and precision rational numbers *) + +(*type rational*) (* ???: better type for this in HOL? *) + + +(* ----------------------- *) +(* double *) +(* ----------------------- *) + +(* double precision floating point (64 bits) *) + +(*type float64*) (* ???: better type for this in HOL? *) + +(*type float32*) (* ???: better type for this in HOL? *) + + +(* ========================================================================== *) +(* Binding the standard operations for the number types *) +(* ========================================================================== *) + + +(* ----------------------- *) +(* nat *) +(* ----------------------- *) + +(*val natFromNumeral : numeral -> nat*) + +(*val natEq : nat -> nat -> bool*) +let instance_Basic_classes_Eq_nat_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun n1 n2->not (n1 = n2))}) + +(*val natLess : nat -> nat -> bool*) +(*val natLessEqual : nat -> nat -> bool*) +(*val natGreater : nat -> nat -> bool*) +(*val natGreaterEqual : nat -> nat -> bool*) + +(*val natCompare : nat -> nat -> ordering*) + +let instance_Basic_classes_Ord_nat_dict =({ + + compare_method = compare; + + isLess_method = (<); + + isLessEqual_method = (<=); + + isGreater_method = (>); + + isGreaterEqual_method = (>=)}) + +let instance_Basic_classes_SetType_nat_dict =({ + + setElemCompare_method = compare}) + +(*val natAdd : nat -> nat -> nat*) + +let instance_Num_NumAdd_nat_dict =({ + + numAdd_method = (+)}) + +(*val natMinus : nat -> nat -> nat*) + +let instance_Num_NumMinus_nat_dict =({ + + numMinus_method = Nat_num.nat_monus}) + +(*val natSucc : nat -> nat*) +(*let natSucc n = (Instance_Num_NumAdd_nat.+) n 1*) +let instance_Num_NumSucc_nat_dict =({ + + succ_method = succ}) + +(*val natPred : nat -> nat*) +let instance_Num_NumPred_nat_dict =({ + + pred_method = Nat_num.nat_pred}) + +(*val natMult : nat -> nat -> nat*) + +let instance_Num_NumMult_nat_dict =({ + + numMult_method = ( * )}) + +(*val natDiv : nat -> nat -> nat*) + +let instance_Num_NumIntegerDivision_nat_dict =({ + + div_method = (/)}) + +let instance_Num_NumDivision_nat_dict =({ + + numDivision_method = (/)}) + +(*val natMod : nat -> nat -> nat*) + +let instance_Num_NumRemainder_nat_dict =({ + + mod_method = (mod)}) + + +(*val gen_pow_aux : forall 'a. ('a -> 'a -> 'a) -> 'a -> 'a -> nat -> 'a*) +let rec gen_pow_aux (mul : 'a -> 'a -> 'a) (a : 'a) (b : 'a) (e : int) = + ( (* cannot happen, call discipline guarentees e >= 1 *) if(e = 0) then + a else + ( + if(e = 1) then (mul a b) else + (let e'' = (e / 2) in + let a' = (if (e mod 2) = 0 then a else mul a b) in + gen_pow_aux mul a' (mul b b) e''))) + +let gen_pow (one : 'a) (mul : 'a -> 'a -> 'a) (b : 'a) (e : int) : 'a = + (if e < 0 then one else + if (e = 0) then one else gen_pow_aux mul one b e) + +(*val natPow : nat -> nat -> nat*) +let natPow = (gen_pow( 1) ( * )) + +let instance_Num_NumPow_nat_dict =({ + + numPow_method = natPow}) + +(*val natMin : nat -> nat -> nat*) + +(*val natMax : nat -> nat -> nat*) + +let instance_Basic_classes_OrdMaxMin_nat_dict =({ + + max_method = max; + + min_method = min}) + + +(* ----------------------- *) +(* natural *) +(* ----------------------- *) + +(*val naturalFromNumeral : numeral -> natural*) + +(*val naturalEq : natural -> natural -> bool*) +let instance_Basic_classes_Eq_Num_natural_dict =({ + + isEqual_method = Big_int.eq_big_int; + + isInequal_method = (fun n1 n2->not (Big_int.eq_big_int n1 n2))}) + +(*val naturalLess : natural -> natural -> bool*) +(*val naturalLessEqual : natural -> natural -> bool*) +(*val naturalGreater : natural -> natural -> bool*) +(*val naturalGreaterEqual : natural -> natural -> bool*) + +(*val naturalCompare : natural -> natural -> ordering*) + +let instance_Basic_classes_Ord_Num_natural_dict =({ + + compare_method = Big_int.compare_big_int; + + isLess_method = Big_int.lt_big_int; + + isLessEqual_method = Big_int.le_big_int; + + isGreater_method = Big_int.gt_big_int; + + isGreaterEqual_method = Big_int.ge_big_int}) + +let instance_Basic_classes_SetType_Num_natural_dict =({ + + setElemCompare_method = Big_int.compare_big_int}) + +(*val naturalAdd : natural -> natural -> natural*) + +let instance_Num_NumAdd_Num_natural_dict =({ + + numAdd_method = Big_int.add_big_int}) + +(*val naturalMinus : natural -> natural -> natural*) + +let instance_Num_NumMinus_Num_natural_dict =({ + + numMinus_method = Nat_num.natural_monus}) + +(*val naturalSucc : natural -> natural*) +(*let naturalSucc n = (Instance_Num_NumAdd_Num_natural.+) n 1*) +let instance_Num_NumSucc_Num_natural_dict =({ + + succ_method = Big_int.succ_big_int}) + +(*val naturalPred : natural -> natural*) +let instance_Num_NumPred_Num_natural_dict =({ + + pred_method = Nat_num.natural_pred}) + +(*val naturalMult : natural -> natural -> natural*) + +let instance_Num_NumMult_Num_natural_dict =({ + + numMult_method = Big_int.mult_big_int}) + + +(*val naturalPow : natural -> nat -> natural*) + +let instance_Num_NumPow_Num_natural_dict =({ + + numPow_method = Big_int.power_big_int_positive_int}) + +(*val naturalDiv : natural -> natural -> natural*) + +let instance_Num_NumIntegerDivision_Num_natural_dict =({ + + div_method = Big_int.div_big_int}) + +let instance_Num_NumDivision_Num_natural_dict =({ + + numDivision_method = Big_int.div_big_int}) + +(*val naturalMod : natural -> natural -> natural*) + +let instance_Num_NumRemainder_Num_natural_dict =({ + + mod_method = Big_int.mod_big_int}) + +(*val naturalMin : natural -> natural -> natural*) + +(*val naturalMax : natural -> natural -> natural*) + +let instance_Basic_classes_OrdMaxMin_Num_natural_dict =({ + + max_method = Big_int.max_big_int; + + min_method = Big_int.min_big_int}) + + +(* ----------------------- *) +(* int *) +(* ----------------------- *) + +(*val intFromNumeral : numeral -> int*) + +(*val intEq : int -> int -> bool*) +let instance_Basic_classes_Eq_Num_int_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun n1 n2->not (n1 = n2))}) + +(*val intLess : int -> int -> bool*) +(*val intLessEqual : int -> int -> bool*) +(*val intGreater : int -> int -> bool*) +(*val intGreaterEqual : int -> int -> bool*) + +(*val intCompare : int -> int -> ordering*) + +let instance_Basic_classes_Ord_Num_int_dict =({ + + compare_method = compare; + + isLess_method = (<); + + isLessEqual_method = (<=); + + isGreater_method = (>); + + isGreaterEqual_method = (>=)}) + +let instance_Basic_classes_SetType_Num_int_dict =({ + + setElemCompare_method = compare}) + +(*val intNegate : int -> int*) + +let instance_Num_NumNegate_Num_int_dict =({ + + numNegate_method = (fun i->(~- i))}) + +(*val intAbs : int -> int*) (* TODO: check *) + +let instance_Num_NumAbs_Num_int_dict =({ + + abs_method = abs}) + +(*val intAdd : int -> int -> int*) + +let instance_Num_NumAdd_Num_int_dict =({ + + numAdd_method = (+)}) + +(*val intMinus : int -> int -> int*) + +let instance_Num_NumMinus_Num_int_dict =({ + + numMinus_method = (-)}) + +(*val intSucc : int -> int*) +let instance_Num_NumSucc_Num_int_dict =({ + + succ_method = succ}) + +(*val intPred : int -> int*) +let instance_Num_NumPred_Num_int_dict =({ + + pred_method = pred}) + +(*val intMult : int -> int -> int*) + +let instance_Num_NumMult_Num_int_dict =({ + + numMult_method = ( * )}) + + +(*val intPow : int -> nat -> int*) +let intPow = (gen_pow( 1) ( * )) + +let instance_Num_NumPow_Num_int_dict =({ + + numPow_method = intPow}) + +(*val intDiv : int -> int -> int*) + +let instance_Num_NumIntegerDivision_Num_int_dict =({ + + div_method = Nat_num.int_div}) + +let instance_Num_NumDivision_Num_int_dict =({ + + numDivision_method = Nat_num.int_div}) + +(*val intMod : int -> int -> int*) + +let instance_Num_NumRemainder_Num_int_dict =({ + + mod_method = Nat_num.int_mod}) + +(*val intMin : int -> int -> int*) + +(*val intMax : int -> int -> int*) + +let instance_Basic_classes_OrdMaxMin_Num_int_dict =({ + + max_method = max; + + min_method = min}) + +(* ----------------------- *) +(* int32 *) +(* ----------------------- *) +(*val int32FromNumeral : numeral -> int32*) + +(*val int32Eq : int32 -> int32 -> bool*) + +let instance_Basic_classes_Eq_Num_int32_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun n1 n2->not (n1 = n2))}) + +(*val int32Less : int32 -> int32 -> bool*) +(*val int32LessEqual : int32 -> int32 -> bool*) +(*val int32Greater : int32 -> int32 -> bool*) +(*val int32GreaterEqual : int32 -> int32 -> bool*) + +(*val int32Compare : int32 -> int32 -> ordering*) + +let instance_Basic_classes_Ord_Num_int32_dict =({ + + compare_method = Int32.compare; + + isLess_method = (<); + + isLessEqual_method = (<=); + + isGreater_method = (>); + + isGreaterEqual_method = (>=)}) + +let instance_Basic_classes_SetType_Num_int32_dict =({ + + setElemCompare_method = Int32.compare}) + +(*val int32Negate : int32 -> int32*) + +let instance_Num_NumNegate_Num_int32_dict =({ + + numNegate_method = Int32.neg}) + +(*val int32Abs : int32 -> int32*) +(*let int32Abs i = (if (Instance_Basic_classes_Ord_Num_int32.<=) 0 i then i else Instance_Num_NumNegate_Num_int32.~ i)*) + +let instance_Num_NumAbs_Num_int32_dict =({ + + abs_method = Int32.abs}) + + +(*val int32Add : int32 -> int32 -> int32*) + +let instance_Num_NumAdd_Num_int32_dict =({ + + numAdd_method = Int32.add}) + +(*val int32Minus : int32 -> int32 -> int32*) + +let instance_Num_NumMinus_Num_int32_dict =({ + + numMinus_method = Int32.sub}) + +(*val int32Succ : int32 -> int32*) + +let instance_Num_NumSucc_Num_int32_dict =({ + + succ_method = Int32.succ}) + +(*val int32Pred : int32 -> int32*) +let instance_Num_NumPred_Num_int32_dict =({ + + pred_method = Int32.pred}) + +(*val int32Mult : int32 -> int32 -> int32*) + +let instance_Num_NumMult_Num_int32_dict =({ + + numMult_method = Int32.mul}) + + +(*val int32Pow : int32 -> nat -> int32*) +let int32Pow = (gen_pow(Int32.of_int 1) Int32.mul) + +let instance_Num_NumPow_Num_int32_dict =({ + + numPow_method = int32Pow}) + +(*val int32Div : int32 -> int32 -> int32*) + +let instance_Num_NumIntegerDivision_Num_int32_dict =({ + + div_method = Nat_num.int32_div}) + +let instance_Num_NumDivision_Num_int32_dict =({ + + numDivision_method = Nat_num.int32_div}) + +(*val int32Mod : int32 -> int32 -> int32*) + +let instance_Num_NumRemainder_Num_int32_dict =({ + + mod_method = Nat_num.int32_mod}) + +(*val int32Min : int32 -> int32 -> int32*) + +(*val int32Max : int32 -> int32 -> int32*) + +let instance_Basic_classes_OrdMaxMin_Num_int32_dict =({ + + max_method = max; + + min_method = min}) + + + +(* ----------------------- *) +(* int64 *) +(* ----------------------- *) +(*val int64FromNumeral : numeral -> int64*) + +(*val int64Eq : int64 -> int64 -> bool*) + +let instance_Basic_classes_Eq_Num_int64_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun n1 n2->not (n1 = n2))}) + +(*val int64Less : int64 -> int64 -> bool*) +(*val int64LessEqual : int64 -> int64 -> bool*) +(*val int64Greater : int64 -> int64 -> bool*) +(*val int64GreaterEqual : int64 -> int64 -> bool*) + +(*val int64Compare : int64 -> int64 -> ordering*) + +let instance_Basic_classes_Ord_Num_int64_dict =({ + + compare_method = Int64.compare; + + isLess_method = (<); + + isLessEqual_method = (<=); + + isGreater_method = (>); + + isGreaterEqual_method = (>=)}) + +let instance_Basic_classes_SetType_Num_int64_dict =({ + + setElemCompare_method = Int64.compare}) + +(*val int64Negate : int64 -> int64*) + +let instance_Num_NumNegate_Num_int64_dict =({ + + numNegate_method = Int64.neg}) + +(*val int64Abs : int64 -> int64*) +(*let int64Abs i = (if (Instance_Basic_classes_Ord_Num_int64.<=) 0 i then i else Instance_Num_NumNegate_Num_int64.~ i)*) + +let instance_Num_NumAbs_Num_int64_dict =({ + + abs_method = Int64.abs}) + + +(*val int64Add : int64 -> int64 -> int64*) + +let instance_Num_NumAdd_Num_int64_dict =({ + + numAdd_method = Int64.add}) + +(*val int64Minus : int64 -> int64 -> int64*) + +let instance_Num_NumMinus_Num_int64_dict =({ + + numMinus_method = Int64.sub}) + +(*val int64Succ : int64 -> int64*) + +let instance_Num_NumSucc_Num_int64_dict =({ + + succ_method = Int64.succ}) + +(*val int64Pred : int64 -> int64*) +let instance_Num_NumPred_Num_int64_dict =({ + + pred_method = Int64.pred}) + +(*val int64Mult : int64 -> int64 -> int64*) + +let instance_Num_NumMult_Num_int64_dict =({ + + numMult_method = Int64.mul}) + + +(*val int64Pow : int64 -> nat -> int64*) +let int64Pow = (gen_pow(Int64.of_int 1) Int64.mul) + +let instance_Num_NumPow_Num_int64_dict =({ + + numPow_method = int64Pow}) + +(*val int64Div : int64 -> int64 -> int64*) + +let instance_Num_NumIntegerDivision_Num_int64_dict =({ + + div_method = Nat_num.int64_div}) + +let instance_Num_NumDivision_Num_int64_dict =({ + + numDivision_method = Nat_num.int64_div}) + +(*val int64Mod : int64 -> int64 -> int64*) + +let instance_Num_NumRemainder_Num_int64_dict =({ + + mod_method = Nat_num.int64_mod}) + +(*val int64Min : int64 -> int64 -> int64*) + +(*val int64Max : int64 -> int64 -> int64*) + +let instance_Basic_classes_OrdMaxMin_Num_int64_dict =({ + + max_method = max; + + min_method = min}) + + +(* ----------------------- *) +(* integer *) +(* ----------------------- *) + +(*val integerFromNumeral : numeral -> integer*) + +(*val integerEq : integer -> integer -> bool*) +let instance_Basic_classes_Eq_Num_integer_dict =({ + + isEqual_method = Big_int.eq_big_int; + + isInequal_method = (fun n1 n2->not (Big_int.eq_big_int n1 n2))}) + +(*val integerLess : integer -> integer -> bool*) +(*val integerLessEqual : integer -> integer -> bool*) +(*val integerGreater : integer -> integer -> bool*) +(*val integerGreaterEqual : integer -> integer -> bool*) + +(*val integerCompare : integer -> integer -> ordering*) + +let instance_Basic_classes_Ord_Num_integer_dict =({ + + compare_method = Big_int.compare_big_int; + + isLess_method = Big_int.lt_big_int; + + isLessEqual_method = Big_int.le_big_int; + + isGreater_method = Big_int.gt_big_int; + + isGreaterEqual_method = Big_int.ge_big_int}) + +let instance_Basic_classes_SetType_Num_integer_dict =({ + + setElemCompare_method = Big_int.compare_big_int}) + +(*val integerNegate : integer -> integer*) + +let instance_Num_NumNegate_Num_integer_dict =({ + + numNegate_method = Big_int.minus_big_int}) + +(*val integerAbs : integer -> integer*) (* TODO: check *) + +let instance_Num_NumAbs_Num_integer_dict =({ + + abs_method = Big_int.abs_big_int}) + +(*val integerAdd : integer -> integer -> integer*) + +let instance_Num_NumAdd_Num_integer_dict =({ + + numAdd_method = Big_int.add_big_int}) + +(*val integerMinus : integer -> integer -> integer*) + +let instance_Num_NumMinus_Num_integer_dict =({ + + numMinus_method = Big_int.sub_big_int}) + +(*val integerSucc : integer -> integer*) +let instance_Num_NumSucc_Num_integer_dict =({ + + succ_method = Big_int.succ_big_int}) + +(*val integerPred : integer -> integer*) +let instance_Num_NumPred_Num_integer_dict =({ + + pred_method = Big_int.pred_big_int}) + +(*val integerMult : integer -> integer -> integer*) + +let instance_Num_NumMult_Num_integer_dict =({ + + numMult_method = Big_int.mult_big_int}) + + +(*val integerPow : integer -> nat -> integer*) + +let instance_Num_NumPow_Num_integer_dict =({ + + numPow_method = Big_int.power_big_int_positive_int}) + +(*val integerDiv : integer -> integer -> integer*) + +let instance_Num_NumIntegerDivision_Num_integer_dict =({ + + div_method = Big_int.div_big_int}) + +let instance_Num_NumDivision_Num_integer_dict =({ + + numDivision_method = Big_int.div_big_int}) + +(*val integerMod : integer -> integer -> integer*) + +let instance_Num_NumRemainder_Num_integer_dict =({ + + mod_method = Big_int.mod_big_int}) + +(*val integerMin : integer -> integer -> integer*) + +(*val integerMax : integer -> integer -> integer*) + +let instance_Basic_classes_OrdMaxMin_Num_integer_dict =({ + + max_method = Big_int.max_big_int; + + min_method = Big_int.min_big_int}) + + + +(* ========================================================================== *) +(* Translation between number types *) +(* ========================================================================== *) + +(******************) +(* integerFrom... *) +(******************) + +(*val integerFromInt : int -> integer*) + + +(*val integerFromNat : nat -> integer*) + +(*val integerFromNatural : natural -> integer*) + + +(*val integerFromInt32 : int32 -> integer*) + + +(*val integerFromInt64 : int64 -> integer*) + + +(******************) +(* naturalFrom... *) +(******************) + +(*val naturalFromNat : nat -> natural*) + +(*val naturalFromInteger : integer -> natural*) + + +(******************) +(* intFrom ... *) +(******************) + +(*val intFromInteger : integer -> int*) + +(*val intFromNat : nat -> int*) + + +(******************) +(* natFrom ... *) +(******************) + +(*val natFromNatural : natural -> nat*) + +(*val natFromInt : int -> nat*) + + +(******************) +(* int32From ... *) +(******************) + +(*val int32FromNat : nat -> int32*) + +(*val int32FromNatural : natural -> int32*) + +(*val int32FromInteger : integer -> int32*) +(*let int32FromInteger i = ( + let abs_int32 = int32FromNatural (naturalFromInteger i) in + if ((Instance_Basic_classes_Ord_Num_integer.<) i 0) then (Instance_Num_NumNegate_Num_int32.~ abs_int32) else abs_int32 +)*) + +(*val int32FromInt : int -> int32*) +(*let int32FromInt i = int32FromInteger (integerFromInt i)*) + + +(*val int32FromInt64 : int64 -> int32*) +(*let int32FromInt64 i = int32FromInteger (integerFromInt64 i)*) + + + + +(******************) +(* int64From ... *) +(******************) + +(*val int64FromNat : nat -> int64*) + +(*val int64FromNatural : natural -> int64*) + +(*val int64FromInteger : integer -> int64*) +(*let int64FromInteger i = ( + let abs_int64 = int64FromNatural (naturalFromInteger i) in + if ((Instance_Basic_classes_Ord_Num_integer.<) i 0) then (Instance_Num_NumNegate_Num_int64.~ abs_int64) else abs_int64 +)*) + +(*val int64FromInt : int -> int64*) +(*let int64FromInt i = int64FromInteger (integerFromInt i)*) + + +(*val int64FromInt32 : int32 -> int64*) +(*let int64FromInt32 i = int64FromInteger (integerFromInt32 i)*) + + +(******************) +(* what's missing *) +(******************) + +(*val naturalFromInt : int -> natural*) +(*val naturalFromInt32 : int32 -> natural*) +(*val naturalFromInt64 : int64 -> natural*) + + +(*val intFromNatural : natural -> int*) +(*val intFromInt32 : int32 -> int*) +(*val intFromInt64 : int64 -> int*) + +(*val natFromInteger : integer -> nat*) +(*val natFromInt32 : int32 -> nat*) +(*val natFromInt64 : int64 -> nat*) + +(*val string_of_natural : natural -> string*) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_pervasives.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_pervasives.ml new file mode 100644 index 00000000..729d9b79 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_pervasives.ml @@ -0,0 +1,18 @@ +(*Generated by Lem from pervasives.lem.*) + + +include Lem_basic_classes +include Lem_bool +include Lem_tuple +include Lem_maybe +include Lem_either +include Lem_function +include Lem_num +include Lem_map +include Lem_set +include Lem_list +include Lem_string +include Lem_word + +(*import Sorting Relation*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_pervasives_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_pervasives_extra.ml new file mode 100644 index 00000000..121429c6 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_pervasives_extra.ml @@ -0,0 +1,12 @@ +(*Generated by Lem from pervasives_extra.lem.*) + + +include Lem_pervasives +include Lem_function_extra +include Lem_maybe_extra +include Lem_map_extra +include Lem_set_extra +include Lem_set_helpers +include Lem_list_extra +include Lem_string_extra +include Lem_assert_extra diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_relation.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_relation.ml new file mode 100644 index 00000000..f2e8114b --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_relation.ml @@ -0,0 +1,424 @@ +(*Generated by Lem from relation.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_tuple +open Lem_set +open Lem_num + +(* ========================================================================== *) +(* The type of relations *) +(* ========================================================================== *) + +type( 'a, 'b) rel_pred = 'a -> 'b -> bool +type( 'a, 'b) rel_set = ('a * 'b) Pset.set + +(* Binary relations are usually represented as either + sets of pairs (rel_set) or as curried functions (rel_pred). + + The choice depends on taste and the backend. Lem should not take a + decision, but supports both representations. There is an abstract type + pred, which can be converted to both representations. The representation + of pred itself then depends on the backend. However, for the time beeing, + let's implement relations as sets to get them working more quickly. *) + +type( 'a, 'b) rel = ('a, 'b) rel_set + +(*val relToSet : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel_set 'a 'b*) +(*val relFromSet : forall 'a 'b. SetType 'a, SetType 'b => rel_set 'a 'b -> rel 'a 'b*) + +(*val relEq : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel 'a 'b -> bool*) +let relEq dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b r1 r2 = ( Pset.equal r1 r2) + +(*val relToPred : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> rel_pred 'a 'b*) +(*val relFromPred : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => set 'a -> set 'b -> rel_pred 'a 'b -> rel 'a 'b*) + +let relToPred dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b r = (fun x y -> Pset.mem(x, y) r) +let relFromPred dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b xs ys p = (Pset.filter (fun (x,y) -> p x y) ((Pset.cross (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_b.setElemCompare_method) xs ys))) + + +(* ========================================================================== *) +(* Basic Operations *) +(* ========================================================================== *) + +(* ----------------------- *) +(* membership test *) +(* ----------------------- *) + +(*val inRel : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => 'a -> 'b -> rel 'a 'b -> bool*) + + +(* ----------------------- *) +(* empty relation *) +(* ----------------------- *) + +(*val relEmpty : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b*) + +(* ----------------------- *) +(* Insertion *) +(* ----------------------- *) + +(*val relAdd : forall 'a 'b. SetType 'a, SetType 'b => 'a -> 'b -> rel 'a 'b -> rel 'a 'b*) + + +(* ----------------------- *) +(* Identity relation *) +(* ----------------------- *) + +(*val relIdOn : forall 'a. SetType 'a, Eq 'a => set 'a -> rel 'a 'a*) +let relIdOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a s = (relFromPred + dict_Basic_classes_SetType_a dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a dict_Basic_classes_Eq_a s s dict_Basic_classes_Eq_a.isEqual_method) + +(*val relId : forall 'a. SetType 'a, Eq 'a => rel 'a 'a*) + +(* ----------------------- *) +(* relation union *) +(* ----------------------- *) + +(*val relUnion : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel 'a 'b -> rel 'a 'b*) + +(* ----------------------- *) +(* relation intersection *) +(* ----------------------- *) + +(*val relIntersection : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> rel 'a 'b -> rel 'a 'b*) + +(* ----------------------- *) +(* Relation Composition *) +(* ----------------------- *) + +(*val relComp : forall 'a 'b 'c. SetType 'a, SetType 'b, SetType 'c, Eq 'a, Eq 'b => rel 'a 'b -> rel 'b 'c -> rel 'a 'c*) +let relComp dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b dict_Basic_classes_SetType_c dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b r1 r2 = (let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_c.setElemCompare_method) []) in Pset.fold + (fun(e1,e2) x2 -> Pset.fold + (fun(e2',e3) x2 -> + if dict_Basic_classes_Eq_b.isEqual_method e2 e2' then + Pset.add (e1, e3) x2 else x2) (r2) x2) (r1) + x2) + +(* ----------------------- *) +(* restrict *) +(* ----------------------- *) + +(*val relRestrict : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> rel 'a 'a*) +let relRestrict dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_a.setElemCompare_method) []) in Pset.fold + (fun a x2 -> Pset.fold + (fun b x2 -> + if Pset.mem (a, b) r then Pset.add (a, b) x2 else x2) + s x2) s x2) + + +(* ----------------------- *) +(* Converse *) +(* ----------------------- *) + +(*val relConverse : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> rel 'b 'a*) +let relConverse dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b r = ((Pset.map (pairCompare + dict_Basic_classes_SetType_b.setElemCompare_method dict_Basic_classes_SetType_a.setElemCompare_method) Lem.pair_swap (r))) + + +(* ----------------------- *) +(* domain *) +(* ----------------------- *) + +(*val relDomain : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> set 'a*) +let relDomain dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b r = (Pset.map + dict_Basic_classes_SetType_a.setElemCompare_method (fun x -> fst x) (r)) + +(* ----------------------- *) +(* range *) +(* ----------------------- *) + +(*val relRange : forall 'a 'b. SetType 'a, SetType 'b => rel 'a 'b -> set 'b*) +let relRange dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b r = (Pset.map + dict_Basic_classes_SetType_b.setElemCompare_method (fun x -> snd x) (r)) + + +(* ----------------------- *) +(* field / definedOn *) +(* *) +(* avoid the keyword field *) +(* ----------------------- *) + +(*val relDefinedOn : forall 'a. SetType 'a => rel 'a 'a -> set 'a*) + +(* ----------------------- *) +(* relOver *) +(* *) +(* avoid the keyword field *) +(* ----------------------- *) + +(*val relOver : forall 'a. SetType 'a => rel 'a 'a -> set 'a -> bool*) +let relOver dict_Basic_classes_SetType_a r s = ( Pset.subset(( Pset.(union)(relDomain + dict_Basic_classes_SetType_a dict_Basic_classes_SetType_a r) (relRange dict_Basic_classes_SetType_a dict_Basic_classes_SetType_a r))) s) + + +(* ----------------------- *) +(* apply a relation *) +(* ----------------------- *) + +(* Given a relation r and a set s, relApply r s applies s to r, i.e. + it returns the set of all value reachable via r from a value in s. + This operation can be seen as a generalisation of function application. *) + +(*val relApply : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a => rel 'a 'b -> set 'a -> set 'b*) +let relApply dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b dict_Basic_classes_Eq_a r s = (let x2 =(Pset.from_list + dict_Basic_classes_SetType_b.setElemCompare_method []) in Pset.fold (fun(x, y) x2 -> if Pset.mem x s then Pset.add y x2 else x2) + (r) x2) + + +(* ========================================================================== *) +(* Properties *) +(* ========================================================================== *) + +(* ----------------------- *) +(* subrel *) +(* ----------------------- *) + +(*val isSubrel : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> rel 'a 'b -> bool*) + +(* ----------------------- *) +(* reflexivity *) +(* ----------------------- *) + +(*val isReflexiveOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isReflexiveOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e -> Pset.mem (e, e) r) s) + +(*val isReflexive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + +(* ----------------------- *) +(* irreflexivity *) +(* ----------------------- *) + +(*val isIrreflexiveOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isIrreflexiveOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e -> not ( Pset.mem (e, e) r)) s) + +(*val isIrreflexive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +let isIrreflexive dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r = (Pset.for_all + (fun (e1, e2) -> not ( dict_Basic_classes_Eq_a.isEqual_method e1 e2)) (r)) + + +(* ----------------------- *) +(* symmetry *) +(* ----------------------- *) + +(*val isSymmetricOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isSymmetricOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e1 -> Pset.for_all + (fun e2 -> ((not ( Pset.mem (e1, e2) r)) || + ( Pset.mem (e2, e1) r))) s) s) + +(*val isSymmetric : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +let isSymmetric dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r = (Pset.for_all + (fun (e1, e2) -> Pset.mem (e2, e1) r) r) + + +(* ----------------------- *) +(* antisymmetry *) +(* ----------------------- *) + +(*val isAntisymmetricOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isAntisymmetricOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e1 -> Pset.for_all + (fun e2 -> ((not ( Pset.mem (e1, e2) r)) || + ((not ( Pset.mem (e2, e1) r)) || + ( dict_Basic_classes_Eq_a.isEqual_method + e1 e2)))) s) s) + +(*val isAntisymmetric : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +let isAntisymmetric dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r = (Pset.for_all + (fun (e1, e2) -> ((not ( Pset.mem (e2, e1) r)) || + ( dict_Basic_classes_Eq_a.isEqual_method e1 e2))) r) + + +(* ----------------------- *) +(* transitivity *) +(* ----------------------- *) + +(*val isTransitiveOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isTransitiveOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e1 -> Pset.for_all + (fun e2 -> Pset.for_all + (fun e3 -> ((not ( Pset.mem (e1, e2) r)) || + ((not ( Pset.mem (e2, e3) r)) || + ( Pset.mem (e1, e3) r)))) + s) s) s) + +(*val isTransitive : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +let isTransitive dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r = (Pset.for_all + (fun (e1, e2) -> Pset.for_all (fun e3 -> Pset.mem (e1, e3) r) + (relApply dict_Basic_classes_SetType_a + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a + r + (Pset.from_list + dict_Basic_classes_SetType_a.setElemCompare_method + [e2]))) r) + +(* ----------------------- *) +(* total *) +(* ----------------------- *) + +(*val isTotalOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isTotalOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e1 -> Pset.for_all + (fun e2 -> ( Pset.mem (e1, e2) r) || ( Pset.mem (e2, e1) r)) + s) s) + + +(*val isTotal : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + +(*val isTrichotomousOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isTrichotomousOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.for_all + (fun e1 -> Pset.for_all + (fun e2 -> ( Pset.mem (e1, e2) r) || + (( dict_Basic_classes_Eq_a.isEqual_method e1 e2) + || ( Pset.mem (e2, e1) r))) s) s) + +(*val isTrichotomous : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + +(* ----------------------- *) +(* is_single_valued *) +(* ----------------------- *) + +(*val isSingleValued : forall 'a 'b. SetType 'a, SetType 'b, Eq 'a, Eq 'b => rel 'a 'b -> bool*) +let isSingleValued dict_Basic_classes_SetType_a dict_Basic_classes_SetType_b dict_Basic_classes_Eq_a dict_Basic_classes_Eq_b r = (Pset.for_all + (fun (e1, e2a) -> Pset.for_all + (fun e2b -> dict_Basic_classes_Eq_b.isEqual_method + e2a e2b) + (relApply dict_Basic_classes_SetType_a + dict_Basic_classes_SetType_b dict_Basic_classes_Eq_a + r + (Pset.from_list + dict_Basic_classes_SetType_a.setElemCompare_method + [e1]))) r) + + +(* ----------------------- *) +(* equivalence relation *) +(* ----------------------- *) + +(*val isEquivalenceOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isEquivalenceOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (isReflexiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && (isSymmetricOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && isTransitiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s)) + + +(*val isEquivalence : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + +(* ----------------------- *) +(* well founded *) +(* ----------------------- *) + +(*val isWellFounded : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + +(* ========================================================================== *) +(* Orders *) +(* ========================================================================== *) + + +(* ----------------------- *) +(* pre- or quasiorders *) +(* ----------------------- *) + +(*val isPreorderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isPreorderOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (isReflexiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && isTransitiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s) + +(*val isPreorder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + +(* ----------------------- *) +(* partial orders *) +(* ----------------------- *) + +(*val isPartialOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isPartialOrderOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (isReflexiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && (isTransitiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && isAntisymmetricOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s)) + + +(*val isStrictPartialOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isStrictPartialOrderOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (isIrreflexiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && isTransitiveOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s) + + +(*val isStrictPartialOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) +let isStrictPartialOrder dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r = (isIrreflexive + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r && isTransitive dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r) + +(*val isPartialOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + +(* ----------------------- *) +(* total / linear orders *) +(* ----------------------- *) + +(*val isTotalOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isTotalOrderOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (isPartialOrderOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && isTotalOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s) + +(*val isStrictTotalOrderOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> bool*) +let isStrictTotalOrderOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (isStrictPartialOrderOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s && isTrichotomousOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s) + +(*val isTotalOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + +(*val isStrictTotalOrder : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> bool*) + + + +(* ========================================================================== *) +(* closures *) +(* ========================================================================== *) + +(* ----------------------- *) +(* transitive closure *) +(* ----------------------- *) + +(*val transitiveClosure : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> rel 'a 'a*) +(*val transitiveClosureByEq : forall 'a. ('a -> 'a -> bool) -> rel 'a 'a -> rel 'a 'a*) +(*val transitiveClosureByCmp : forall 'a. ('a * 'a -> 'a * 'a -> ordering) -> rel 'a 'a -> rel 'a 'a*) + + +(* ----------------------- *) +(* transitive closure step *) +(* ----------------------- *) + +(*val transitiveClosureAdd : forall 'a. SetType 'a, Eq 'a => 'a -> 'a -> rel 'a 'a -> rel 'a 'a*) + +let transitiveClosureAdd dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a x y r = + (( Pset.(union)(((Pset.add (x,y) (r)))) ((( Pset.(union)((let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_a.setElemCompare_method) []) in Pset.fold (fun z x2 -> if Pset.mem (y, z) r then Pset.add (x, z) x2 else x2) + (relRange dict_Basic_classes_SetType_a dict_Basic_classes_SetType_a r) + x2)) ((let x2 =(Pset.from_list (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_a.setElemCompare_method) []) in Pset.fold (fun z x2 -> if Pset.mem (z, x) r then Pset.add (z, y) x2 else x2) + (relDomain dict_Basic_classes_SetType_a dict_Basic_classes_SetType_a r) + x2))))))) + + +(* ========================================================================== *) +(* reflexiv closures *) +(* ========================================================================== *) + +(*val reflexivTransitiveClosureOn : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> set 'a -> rel 'a 'a*) +let reflexivTransitiveClosureOn dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a r s = (Pset.tc (pairCompare + dict_Basic_classes_SetType_a.setElemCompare_method dict_Basic_classes_SetType_a.setElemCompare_method) (( Pset.(union)(r) ((relIdOn + dict_Basic_classes_SetType_a dict_Basic_classes_Eq_a s))))) + + +(*val reflexivTransitiveClosure : forall 'a. SetType 'a, Eq 'a => rel 'a 'a -> rel 'a 'a*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_set.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_set.ml new file mode 100644 index 00000000..1cd7c3fa --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_set.ml @@ -0,0 +1,290 @@ +(*Generated by Lem from set.lem.*) +(******************************************************************************) +(* A library for sets *) +(* *) +(* It mainly follows the Haskell Set-library *) +(******************************************************************************) + +(* Sets in Lem are a bit tricky. On the one hand, we want efficiently executable sets. + OCaml and Haskell both represent sets by some kind of balancing trees. This means + that sets are finite and an order on the element type is required. + Such sets are constructed by simple, executable operations like inserting or + deleting elements, union, intersection, filtering etc. + + On the other hand, we want to use sets for specifications. This leads often + infinite sets, which are specificied in complicated, perhaps even undecidable + ways. + + The set library in this file, chooses the first approach. It describes + *finite* sets with an underlying order. Infinite sets should in the medium + run be represented by a separate type. Since this would require some significant + changes to Lem, for the moment also infinite sets are represented using this + class. However, a run-time exception might occour when using these sets. + This problem needs adressing in the future. *) + + +(* ========================================================================== *) +(* Header *) +(* ========================================================================== *) + +open Lem_bool +open Lem_basic_classes +open Lem_maybe +open Lem_function +open Lem_num +open Lem_list +open Lem_set_helpers + +(* ----------------------- *) +(* Equality check *) +(* ----------------------- *) + +(*val setEqualBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool*) + +(*val setEqual : forall 'a. SetType 'a => set 'a -> set 'a -> bool*) + +let instance_Basic_classes_Eq_set_dict dict_Basic_classes_SetType_a =({ + + isEqual_method = Pset.equal; + + isInequal_method = (fun s1 s2->not (Pset.equal s1 s2))}) + + + +(* ----------------------- *) +(* compare *) +(* ----------------------- *) + +(*val setCompareBy: forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> ordering*) + +(*val setCompare : forall 'a. SetType 'a => set 'a -> set 'a -> ordering*) + +let instance_Basic_classes_SetType_set_dict dict_Basic_classes_SetType_a =({ + + setElemCompare_method = Pset.compare}) + + +(* ----------------------- *) +(* Empty set *) +(* ----------------------- *) + +(*val empty : forall 'a. SetType 'a => set 'a*) +(*val emptyBy : forall 'a. ('a -> 'a -> ordering) -> set 'a*) + +(* ----------------------- *) +(* any / all *) +(* ----------------------- *) + +(*val any : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> bool*) + +(*val all : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> bool*) + + +(* ----------------------- *) +(* (IN) *) +(* ----------------------- *) + +(*val IN [member] : forall 'a. SetType 'a => 'a -> set 'a -> bool*) +(*val memberBy : forall 'a. ('a -> 'a -> ordering) -> 'a -> set 'a -> bool*) + +(* ----------------------- *) +(* not (IN) *) +(* ----------------------- *) + +(*val NIN [notMember] : forall 'a. SetType 'a => 'a -> set 'a -> bool*) + + + +(* ----------------------- *) +(* Emptyness check *) +(* ----------------------- *) + +(*val null : forall 'a. SetType 'a => set 'a -> bool*) + + +(* ------------------------ *) +(* singleton *) +(* ------------------------ *) + +(*val singleton : forall 'a. SetType 'a => 'a -> set 'a*) + + +(* ----------------------- *) +(* size *) +(* ----------------------- *) + +(*val size : forall 'a. SetType 'a => set 'a -> nat*) + + +(* ----------------------------*) +(* setting up pattern matching *) +(* --------------------------- *) + +(*val set_case : forall 'a 'b. SetType 'a => set 'a -> 'b -> ('a -> 'b) -> 'b -> 'b*) + + +(* ------------------------ *) +(* union *) +(* ------------------------ *) + +(*val unionBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> set 'a*) +(*val union : forall 'a. SetType 'a => set 'a -> set 'a -> set 'a*) + +(* ----------------------- *) +(* insert *) +(* ----------------------- *) + +(*val insert : forall 'a. SetType 'a => 'a -> set 'a -> set 'a*) + +(* ----------------------- *) +(* filter *) +(* ----------------------- *) + +(*val filter : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> set 'a*) +(*let filter P s = {e | forall (e IN s) | P e}*) + + +(* ----------------------- *) +(* partition *) +(* ----------------------- *) + +(*val partition : forall 'a. SetType 'a => ('a -> bool) -> set 'a -> set 'a * set 'a*) +let partition dict_Basic_classes_SetType_a p0 s = (Pset.filter p0 s, Pset.filter (fun e -> not (p0 e)) s) + + +(* ----------------------- *) +(* split *) +(* ----------------------- *) + +(*val split : forall 'a. SetType 'a, Ord 'a => 'a -> set 'a -> set 'a * set 'a*) +let split dict_Basic_classes_SetType_a dict_Basic_classes_Ord_a p s = (Pset.filter ( + dict_Basic_classes_Ord_a.isLess_method p) s, Pset.filter (dict_Basic_classes_Ord_a.isGreater_method p) s) + +(*val splitMember : forall 'a. SetType 'a, Ord 'a => 'a -> set 'a -> set 'a * bool * set 'a*) +let splitMember dict_Basic_classes_SetType_a dict_Basic_classes_Ord_a p s = (Pset.filter ( + dict_Basic_classes_Ord_a.isLess_method p) s, Pset.mem p s, Pset.filter ( + dict_Basic_classes_Ord_a.isGreater_method p) s) + + +(* ------------------------ *) +(* subset and proper subset *) +(* ------------------------ *) + +(*val isSubsetOfBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool*) +(*val isProperSubsetOfBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> bool*) + +(*val isSubsetOf : forall 'a. SetType 'a => set 'a -> set 'a -> bool*) +(*val isProperSubsetOf : forall 'a. SetType 'a => set 'a -> set 'a -> bool*) + + +(* ------------------------ *) +(* delete *) +(* ------------------------ *) + +(*val delete : forall 'a. SetType 'a, Eq 'a => 'a -> set 'a -> set 'a*) +(*val deleteBy : forall 'a. SetType 'a => ('a -> 'a -> bool) -> 'a -> set 'a -> set 'a*) + + +(* ------------------------ *) +(* bigunion *) +(* ------------------------ *) + +(*val bigunion : forall 'a. SetType 'a => set (set 'a) -> set 'a*) +(*val bigunionBy : forall 'a. ('a -> 'a -> ordering) -> set (set 'a) -> set 'a*) + +(*let bigunion bs = {x | forall (s IN bs) (x IN s) | true}*) + + +(* ------------------------ *) +(* difference *) +(* ------------------------ *) + +(*val differenceBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> set 'a*) +(*val difference : forall 'a. SetType 'a => set 'a -> set 'a -> set 'a*) + +(* ------------------------ *) +(* intersection *) +(* ------------------------ *) + +(*val intersection : forall 'a. SetType 'a => set 'a -> set 'a -> set 'a*) +(*val intersectionBy : forall 'a. ('a -> 'a -> ordering) -> set 'a -> set 'a -> set 'a*) + + +(* ------------------------ *) +(* map *) +(* ------------------------ *) + +(*val map : forall 'a 'b. SetType 'a, SetType 'b => ('a -> 'b) -> set 'a -> set 'b*) (* before image *) +(*let map f s = { f e | forall (e IN s) | true }*) + +(*val mapBy : forall 'a 'b. ('b -> 'b -> ordering) -> ('a -> 'b) -> set 'a -> set 'b*) + + +(* ------------------------ *) +(* bigunionMap *) +(* ------------------------ *) + +(* In order to avoid providing an comparison function for sets of sets, + it might be better to combine bigunion and map sometimes into a single operation. *) + +(*val bigunionMap : forall 'a 'b. SetType 'a, SetType 'b => ('a -> set 'b) -> set 'a -> set 'b*) +(*val bigunionMapBy : forall 'a 'b. ('b -> 'b -> ordering) -> ('a -> set 'b) -> set 'a -> set 'b*) + +(* ------------------------ *) +(* min and max *) +(* ------------------------ *) + +(*val findMin : forall 'a. SetType 'a, Eq 'a => set 'a -> maybe 'a*) +(*val findMax : forall 'a. SetType 'a, Eq 'a => set 'a -> maybe 'a*) + + + +(* ------------------------ *) +(* fromList *) +(* ------------------------ *) + +(*val fromList : forall 'a. SetType 'a => list 'a -> set 'a*) (* before from_list *) +(*val fromListBy : forall 'a. ('a -> 'a -> ordering) -> list 'a -> set 'a*) + + +(* ------------------------ *) +(* Sigma *) +(* ------------------------ *) + +(*val sigma : forall 'a 'b. SetType 'a, SetType 'b => set 'a -> ('a -> set 'b) -> set ('a * 'b)*) +(*val sigmaBy : forall 'a 'b. (('a * 'b) -> ('a * 'b) -> ordering) -> set 'a -> ('a -> set 'b) -> set ('a * 'b)*) + +(*let sigma sa sb = { (a, b) | forall (a IN sa) (b IN sb a) | true }*) + + +(* ------------------------ *) +(* cross product *) +(* ------------------------ *) + +(*val cross : forall 'a 'b. SetType 'a, SetType 'b => set 'a -> set 'b -> set ('a * 'b)*) +(*val crossBy : forall 'a 'b. (('a * 'b) -> ('a * 'b) -> ordering) -> set 'a -> set 'b -> set ('a * 'b)*) + +(*let cross s1 s2 = { (e1, e2) | forall (e1 IN s1) (e2 IN s2) | true }*) + + +(* ------------------------ *) +(* finite *) +(* ------------------------ *) + +(*val finite : forall 'a. SetType 'a => set 'a -> bool*) + + +(* ----------------------------*) +(* fixed point *) +(* --------------------------- *) + +(*val leastFixedPoint : forall 'a. SetType 'a + => nat -> (set 'a -> set 'a) -> set 'a -> set 'a*) +let rec leastFixedPoint dict_Basic_classes_SetType_a bound f x = + ( + if(bound = 0) then x else + (let bound'0 =(Nat_num.nat_monus bound ( 1)) in + let fx = (f x) in + if Pset.subset fx x then x else + leastFixedPoint dict_Basic_classes_SetType_a bound'0 f + ( Pset.(union) fx x))) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_set_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_set_extra.ml new file mode 100644 index 00000000..505f2d3e --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_set_extra.ml @@ -0,0 +1,66 @@ +(*Generated by Lem from set_extra.lem.*) +(******************************************************************************) +(* A library for sets *) +(* *) +(* It mainly follows the Haskell Set-library *) +(******************************************************************************) + +(* ========================================================================== *) +(* Header *) +(* ========================================================================== *) + +open Lem_bool +open Lem_basic_classes +open Lem_maybe +open Lem_function +open Lem_num +open Lem_list +open Lem_sorting +open Lem_set + + +(* ----------------------------*) +(* set choose (be careful !) *) +(* --------------------------- *) + +(*val choose : forall 'a. SetType 'a => set 'a -> 'a*) + + +(* ----------------------------*) +(* universal set *) +(* --------------------------- *) + +(*val universal : forall 'a. SetType 'a => set 'a*) + + +(* ----------------------------*) +(* toList *) +(* --------------------------- *) + +(*val toList : forall 'a. SetType 'a => set 'a -> list 'a*) + + +(* ----------------------------*) +(* toOrderedList *) +(* --------------------------- *) + +(* "toOrderedList" returns a sorted list. Therefore the result is (given a suitable order) deterministic. + Therefore, it is much preferred to "toList". However, it still is only defined for finite sets. So, please + use carefully and consider using set-operations instead of translating sets to lists, performing list manipulations + and then transforming back to sets. *) + +(*val toOrderedListBy : forall 'a. ('a -> 'a -> bool) -> set 'a -> list 'a*) + +(*val toOrderedList : forall 'a. SetType 'a, Ord 'a => set 'a -> list 'a*) + +(* ----------------------------*) +(* unbounded fixed point *) +(* --------------------------- *) + +(* Is NOT supported by the coq backend! *) +(*val leastFixedPointUnbounded : forall 'a. SetType 'a => (set 'a -> set 'a) -> set 'a -> set 'a*) +let rec leastFixedPointUnbounded dict_Basic_classes_SetType_a f x = +(let fx = (f x) in + if Pset.subset fx x then x + else leastFixedPointUnbounded + dict_Basic_classes_SetType_a f ( Pset.(union) fx x)) diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_set_helpers.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_set_helpers.ml new file mode 100644 index 00000000..25aa739f --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_set_helpers.ml @@ -0,0 +1,38 @@ +(*Generated by Lem from set_helpers.lem.*) +(******************************************************************************) +(* Helper functions for sets *) +(******************************************************************************) + +(* Usually there is a something.lem file containing the main definitions and a + something_extra.lem one containing functions that might cause problems for + some backends or are just seldomly used. + + For sets the situation is different. folding is not well defined, since it + is only sensibly defined for finite sets and it the traversel + order is underspecified. *) + +(* ========================================================================== *) +(* Header *) +(* ========================================================================== *) + +open Lem_bool +open Lem_basic_classes +open Lem_maybe +open Lem_function +open Lem_num + +(* ------------------------ *) +(* fold *) +(* ------------------------ *) + +(* fold is suspicious, because if given a function, for which + the order, in which the arguments are given, matters, it's + results are undefined. On the other hand, it is very handy to + define other - non suspicious functions. + + Moreover, fold is central for OCaml, size it is used to + compile set comprehensions *) + +(*val fold : forall 'a 'b. ('a -> 'b -> 'b) -> set 'a -> 'b -> 'b*) + + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_sorting.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_sorting.ml new file mode 100644 index 00000000..fa16f70c --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_sorting.ml @@ -0,0 +1,83 @@ +(*Generated by Lem from sorting.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_maybe +open Lem_list +open Lem_num + +(* ------------------------- *) +(* permutations *) +(* ------------------------- *) + +(*val isPermutation : forall 'a. Eq 'a => list 'a -> list 'a -> bool*) +(*val isPermutationBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*) + +let rec isPermutationBy eq l1 l2 = ((match l1 with + | [] -> list_null l2 + | (x :: xs) -> begin + (match list_delete_first (eq x) l2 with + | None -> false + | Some ys -> isPermutationBy eq xs ys + ) + end +)) + + + +(* ------------------------- *) +(* isSorted *) +(* ------------------------- *) + +(* isSortedBy R l + checks, whether the list l is sorted by ordering R. + R should represent an order, i.e. it should be transitive. + Different backends defined "isSorted" slightly differently. However, + the definitions coincide for transitive R. Therefore there is the + following restriction: + + WARNING: Use isSorted and isSortedBy only with transitive relations! +*) + +(*val isSorted : forall 'a. Ord 'a => list 'a -> bool*) +(*val isSortedBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> bool*) + +(* DPM: rejigged the definition with a nested match to get past Coq's termination checker. *) +let rec isSortedBy cmp l = ((match l with + | [] -> true + | x1 :: xs -> + (match xs with + | [] -> true + | x2 :: _ -> (cmp x1 x2 && isSortedBy cmp xs) + ) +)) + + +(* ----------------------- *) +(* insertion sort *) +(* ----------------------- *) + +(*val insert : forall 'a. Ord 'a => 'a -> list 'a -> list 'a*) +(*val insertBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a*) + +(*val insertSort: forall 'a. Ord 'a => list 'a -> list 'a*) +(*val insertSortBy: forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a*) + +let rec insertBy cmp e l = ((match l with + | [] -> [e] + | x :: xs -> if cmp x e then x :: (insertBy cmp e xs) else (e :: (x :: xs)) +)) + +let insertSortBy cmp l = (List.fold_left (fun l e -> insertBy cmp e l) [] l) + + +(* ----------------------- *) +(* general sorting *) +(* ----------------------- *) + +(*val sort: forall 'a. Ord 'a => list 'a -> list 'a*) +(*val sortBy: forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a*) +(*val sortByOrd: forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a*) + + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_string.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_string.ml new file mode 100644 index 00000000..f193f7dd --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_string.ml @@ -0,0 +1,53 @@ +(*Generated by Lem from string.lem.*) + + +open Lem_bool +open Lem_basic_classes +open Lem_list +open Xstring + +(* ------------------------------------------- *) +(* translations between strings and char lists *) +(* ------------------------------------------- *) + +(*val toCharList : string -> list char*) + +(*val toString : list char -> string*) + + +(* ----------------------- *) +(* generating strings *) +(* ----------------------- *) + +(*val makeString : nat -> char -> string*) +(*let makeString len c = toString (replicate len c)*) + +(* ----------------------- *) +(* length *) +(* ----------------------- *) + +(*val stringLength : string -> nat*) + +(* ----------------------- *) +(* string concatenation *) +(* ----------------------- *) + +(*val ^ [stringAppend] : string -> string -> string*) + + +(* ----------------------------*) +(* setting up pattern matching *) +(* --------------------------- *) + +(*val string_case : forall 'a. string -> 'a -> (char -> string -> 'a) -> 'a*) + +(*let string_case s c_empty c_cons = + match (toCharList s) with + | [] -> c_empty + | c :: cs -> c_cons c (toString cs) + end*) + +(*val empty_string : string*) + +(*val cons_string : char -> string -> string*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_string_extra.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_string_extra.ml new file mode 100644 index 00000000..a3c8fe7b --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_string_extra.ml @@ -0,0 +1,91 @@ +(*Generated by Lem from string_extra.lem.*) +(******************************************************************************) +(* String functions *) +(******************************************************************************) + +open Lem_basic_classes +open Lem_num +open Lem_list +open Lem_string +open Lem_list_extra + + +(******************************************************************************) +(* Character's to numbers *) +(******************************************************************************) + +(*val ord : char -> nat*) + +(*val chr : nat -> char*) + +(******************************************************************************) +(* Converting to strings *) +(******************************************************************************) + +type 'a show_class={ + show_method : 'a -> string +} + +(*val natToStringHelper : nat -> list char -> list char*) +let rec natToStringHelper n acc = +(if n = 0 then + acc + else + natToStringHelper (n / 10) (Char.chr ((n mod 10) + 48) :: acc)) + +(*val natToString : nat -> string*) +let natToString n = (Xstring.implode (natToStringHelper n [])) + +let instance_String_extra_Show_nat_dict =({ + + show_method = natToString}) + +(*val naturalToStringHelper : natural -> list char -> list char*) +let rec naturalToStringHelper n acc = +(if Big_int.eq_big_int n(Big_int.big_int_of_int 0) then + acc + else + naturalToStringHelper ( Big_int.div_big_int n(Big_int.big_int_of_int 10)) (Char.chr (Big_int.int_of_big_int ( Big_int.add_big_int (Big_int.mod_big_int n(Big_int.big_int_of_int 10))(Big_int.big_int_of_int 48))) :: acc)) + +(*val naturalToString : natural -> string*) +let naturalToString n = (Xstring.implode (naturalToStringHelper n [])) + +let instance_String_extra_Show_Num_natural_dict =({ + + show_method = naturalToString}) + + +(******************************************************************************) +(* List-like operations *) +(******************************************************************************) + +(*val nth : string -> nat -> char*) +(*let nth s n = List_extra.nth (toCharList s) n*) + +(*val stringConcat : list string -> string*) +(*let stringConcat s = + List.foldr (^) "" s*) + +(******************************************************************************) +(* String comparison *) +(******************************************************************************) + +(*val stringCompare : string -> string -> ordering*) + +let stringLess x y = (Lem.orderingIsLess (compare x y)) +let stringLessEq x y = (not (Lem.orderingIsGreater (compare x y))) +let stringGreater x y = (stringLess y x) +let stringGreaterEq x y = (stringLessEq y x) + +let instance_Basic_classes_Ord_string_dict =({ + + compare_method = compare; + + isLess_method = stringLess; + + isLessEqual_method = stringLessEq; + + isGreater_method = stringGreater; + + isGreaterEqual_method = stringGreaterEq}) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_tuple.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_tuple.ml new file mode 100644 index 00000000..8b7aec27 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_tuple.ml @@ -0,0 +1,41 @@ +(*Generated by Lem from tuple.lem.*) + + +open Lem_bool +open Lem_basic_classes + +(* ----------------------- *) +(* fst *) +(* ----------------------- *) + +(*val fst : forall 'a 'b. 'a * 'b -> 'a*) +(*let fst (v1, v2) = v1*) + +(* ----------------------- *) +(* snd *) +(* ----------------------- *) + +(*val snd : forall 'a 'b. 'a * 'b -> 'b*) +(*let snd (v1, v2) = v2*) + + +(* ----------------------- *) +(* curry *) +(* ----------------------- *) + +(*val curry : forall 'a 'b 'c. ('a * 'b -> 'c) -> ('a -> 'b -> 'c)*) + +(* ----------------------- *) +(* uncurry *) +(* ----------------------- *) + +(*val uncurry : forall 'a 'b 'c. ('a -> 'b -> 'c) -> ('a * 'b -> 'c)*) + + +(* ----------------------- *) +(* swap *) +(* ----------------------- *) + +(*val swap : forall 'a 'b. ('a * 'b) -> ('b * 'a)*) +(*let swap (v1, v2) = (v2, v1)*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/lem_word.ml b/lib/ocaml_rts/linksem/src_lem_library/lem_word.ml new file mode 100644 index 00000000..b446f885 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/lem_word.ml @@ -0,0 +1,731 @@ +(*Generated by Lem from word.lem.*) + + +open Lem_bool +open Lem_maybe +open Lem_num +open Lem_basic_classes +open Lem_list + + +(* ========================================================================== *) +(* Define general purpose word, i.e. sequences of bits of arbitrary length *) +(* ========================================================================== *) + +type bitSequence = BitSeq of + int option * (* length of the sequence, Nothing means infinite length *) + bool * bool (* sign of the word, used to fill up after concrete value is exhausted *) + list (* the initial part of the sequence, least significant bit first *) + +(*val bitSeqEq : bitSequence -> bitSequence -> bool*) +let instance_Basic_classes_Eq_Word_bitSequence_dict =({ + + isEqual_method = (=); + + isInequal_method = (fun n1 n2->not (n1 = n2))}) + +(*val boolListFrombitSeq : nat -> bitSequence -> list bool*) + +let rec boolListFrombitSeqAux n s bl = +(if n = 0 then [] else + (match bl with + | [] -> replicate n s + | b :: bl' -> b :: (boolListFrombitSeqAux (Nat_num.nat_monus n( 1)) s bl') + )) + +let boolListFrombitSeq n (BitSeq( _, s, bl)) = (boolListFrombitSeqAux n s bl) + + +(*val bitSeqFromBoolList : list bool -> maybe bitSequence*) +let bitSeqFromBoolList bl = +((match dest_init bl with + | None -> None + | Some (bl', s) -> Some (BitSeq( (Some (List.length bl)), s, bl')) + )) + + +(* cleans up the representation of a bitSequence without changing its semantics *) +(*val cleanBitSeq : bitSequence -> bitSequence*) +let cleanBitSeq (BitSeq( len, s, bl)) = ((match len with + | None -> (BitSeq( len, s, (List.rev (dropWhile ((=) s) (List.rev bl))))) + | Some n -> (BitSeq( len, s, (List.rev (dropWhile ((=) s) (List.rev (Lem_list.take (Nat_num.nat_monus n( 1)) bl)))))) +)) + + +(*val bitSeqTestBit : bitSequence -> nat -> maybe bool*) +let bitSeqTestBit (BitSeq( len, s, bl)) pos = + ((match len with + | None -> if pos < List.length bl then list_index bl pos else Some s + | Some l -> if (pos >= l) then None else + if ((pos = ( Nat_num.nat_monus l( 1))) || (pos >= List.length bl)) then Some s else + list_index bl pos + )) + +(*val bitSeqSetBit : bitSequence -> nat -> bool -> bitSequence*) +let bitSeqSetBit (BitSeq( len, s, bl)) pos v = +(let bl' = (if (pos < List.length bl) then bl else List.append bl (replicate pos s)) in + let bl'' = (Lem_list.list_update bl' pos v) in + let bs' = (BitSeq( len, s, bl'')) in + cleanBitSeq bs') + + +(*val resizeBitSeq : maybe nat -> bitSequence -> bitSequence*) +let resizeBitSeq new_len bs = +(let (BitSeq( len, s, bl)) = (cleanBitSeq bs) in + let shorten_opt = ((match (new_len, len) with + | (None, _) -> None + | (Some l1, None) -> Some l1 + | (Some l1, Some l2) -> if (l1 < l2) then Some l1 else None + )) in + (match shorten_opt with + | None -> BitSeq( new_len, s, bl) + | Some l1 -> ( + let bl' = (Lem_list.take l1 ( List.append bl [s])) in + (match dest_init bl' with + | None -> (BitSeq( len, s, bl)) (* do nothing if size 0 is requested *) + | Some (bl'', s') -> cleanBitSeq (BitSeq( new_len, s', bl'')) + )) + )) + +(*val bitSeqNot : bitSequence -> bitSequence*) +let bitSeqNot (BitSeq( len, s, bl)) = (BitSeq( len, (not s), (List.map not bl))) + +(*val bitSeqBinop : (bool -> bool -> bool) -> bitSequence -> bitSequence -> bitSequence*) + +(*val bitSeqBinopAux : (bool -> bool -> bool) -> bool -> list bool -> bool -> list bool -> list bool*) +let rec bitSeqBinopAux binop s1 bl1 s2 bl2 = +((match (bl1, bl2) with + | ([], []) -> [] + | (b1 :: bl1', []) -> (binop b1 s2) :: bitSeqBinopAux binop s1 bl1' s2 [] + | ([], b2 :: bl2') -> (binop s1 b2) :: bitSeqBinopAux binop s1 [] s2 bl2' + | (b1 :: bl1', b2 :: bl2') -> (binop b1 b2) :: bitSeqBinopAux binop s1 bl1' s2 bl2' + )) + +let bitSeqBinop binop bs1 bs2 = ( + let (BitSeq( len1, s1, bl1)) = (cleanBitSeq bs1) in + let (BitSeq( len2, s2, bl2)) = (cleanBitSeq bs2) in + + let len = ((match (len1, len2) with + | (Some l1, Some l2) -> Some (max l1 l2) + | _ -> None + )) in + let s = (binop s1 s2) in + let bl = (bitSeqBinopAux binop s1 bl1 s2 bl2) in + cleanBitSeq (BitSeq( len, s, bl)) +) + +let bitSeqAnd = (bitSeqBinop (&&)) +let bitSeqOr = (bitSeqBinop (||)) +let bitSeqXor = (bitSeqBinop (fun b1 b2->not (b1 = b2))) + +(*val bitSeqShiftLeft : bitSequence -> nat -> bitSequence*) +let bitSeqShiftLeft (BitSeq( len, s, bl)) n = (cleanBitSeq (BitSeq( len, s, ( List.append(replicate n false) bl)))) + +(*val bitSeqArithmeticShiftRight : bitSequence -> nat -> bitSequence*) +let bitSeqArithmeticShiftRight bs n = + (let (BitSeq( len, s, bl)) = (cleanBitSeq bs) in + cleanBitSeq (BitSeq( len, s, (drop n bl)))) + +(*val bitSeqLogicalShiftRight : bitSequence -> nat -> bitSequence*) +let bitSeqLogicalShiftRight bs n = + (if (n = 0) then cleanBitSeq bs else + let (BitSeq( len, s, bl)) = (cleanBitSeq bs) in + (match len with + | None -> cleanBitSeq (BitSeq( len, s, (drop n bl))) + | Some l -> cleanBitSeq (BitSeq( len, false, ( List.append(drop n bl) (replicate l s)))) + )) + + +(* integerFromBoolList sign bl creates an integer from a list of bits + (least significant bit first) and an explicitly given sign bit. + It uses two's complement encoding. *) +(*val integerFromBoolList : (bool * list bool) -> integer*) + +let rec integerFromBoolListAux (acc : Big_int.big_int) (bl : bool list) = + ((match bl with + | [] -> acc + | (true :: bl') -> integerFromBoolListAux ( Big_int.add_big_int( Big_int.mult_big_int acc(Big_int.big_int_of_int 2))(Big_int.big_int_of_int 1)) bl' + | (false :: bl') -> integerFromBoolListAux ( Big_int.mult_big_int acc(Big_int.big_int_of_int 2)) bl' + )) + +let integerFromBoolList (sign, bl) = + (if sign then + Big_int.minus_big_int( Big_int.add_big_int(integerFromBoolListAux(Big_int.big_int_of_int 0) (List.rev_map not bl))(Big_int.big_int_of_int 1)) + else integerFromBoolListAux(Big_int.big_int_of_int 0) (List.rev bl)) + +(* [boolListFromInteger i] creates a sign bit and a list of booleans from an integer. The len_opt tells it when to stop.*) +(*val boolListFromInteger : integer -> bool * list bool*) + +let rec boolListFromNatural acc (remainder : Big_int.big_int) = +(if ( Big_int.gt_big_int remainder(Big_int.big_int_of_int 0)) then + (boolListFromNatural (( Big_int.eq_big_int( Big_int.mod_big_int remainder(Big_int.big_int_of_int 2))(Big_int.big_int_of_int 1)) :: acc) + ( Big_int.div_big_int remainder(Big_int.big_int_of_int 2))) + else + List.rev acc) + +let boolListFromInteger (i : Big_int.big_int) = + (if ( Big_int.lt_big_int i(Big_int.big_int_of_int 0)) then + (true, List.map not (boolListFromNatural [] (Big_int.abs_big_int (Big_int.minus_big_int( Big_int.add_big_int i(Big_int.big_int_of_int 1)))))) + else + (false, boolListFromNatural [] (Big_int.abs_big_int i))) + + +(* [bitSeqFromInteger len_opt i] encodes [i] as a bitsequence with [len_opt] bits. If there are not enough + bits, truncation happens *) +(*val bitSeqFromInteger : maybe nat -> integer -> bitSequence*) +let bitSeqFromInteger len_opt i = +(let (s, bl) = (boolListFromInteger i) in + resizeBitSeq len_opt (BitSeq( None, s, bl))) + + +(*val integerFromBitSeq : bitSequence -> integer*) +let integerFromBitSeq bs = +(let (BitSeq( len, s, bl)) = (cleanBitSeq bs) in + integerFromBoolList (s, bl)) + + +(* Now we can via translation to integers map arithmetic operations to bitSequences *) + +(*val bitSeqArithUnaryOp : (integer -> integer) -> bitSequence -> bitSequence*) +let bitSeqArithUnaryOp uop bs = +(let (BitSeq( len, _, _)) = bs in + bitSeqFromInteger len (uop (integerFromBitSeq bs))) + +(*val bitSeqArithBinOp : (integer -> integer -> integer) -> bitSequence -> bitSequence -> bitSequence*) +let bitSeqArithBinOp binop bs1 bs2 = +(let (BitSeq( len1, _, _)) = bs1 in + let (BitSeq( len2, _, _)) = bs2 in + let len = ((match (len1, len2) with + | (Some l1, Some l2) -> Some (max l1 l2) + | _ -> None + )) in + bitSeqFromInteger len (binop (integerFromBitSeq bs1) (integerFromBitSeq bs2))) + +(*val bitSeqArithBinTest : forall 'a. (integer -> integer -> 'a) -> bitSequence -> bitSequence -> 'a*) +let bitSeqArithBinTest binop bs1 bs2 = (binop (integerFromBitSeq bs1) (integerFromBitSeq bs2)) + + +(* now instantiate the number interface for bit-sequences *) + +(*val bitSeqFromNumeral : numeral -> bitSequence*) + +(*val bitSeqLess : bitSequence -> bitSequence -> bool*) +let bitSeqLess bs1 bs2 = (bitSeqArithBinTest Big_int.lt_big_int bs1 bs2) + +(*val bitSeqLessEqual : bitSequence -> bitSequence -> bool*) +let bitSeqLessEqual bs1 bs2 = (bitSeqArithBinTest Big_int.le_big_int bs1 bs2) + +(*val bitSeqGreater : bitSequence -> bitSequence -> bool*) +let bitSeqGreater bs1 bs2 = (bitSeqArithBinTest Big_int.gt_big_int bs1 bs2) + +(*val bitSeqGreaterEqual : bitSequence -> bitSequence -> bool*) +let bitSeqGreaterEqual bs1 bs2 = (bitSeqArithBinTest Big_int.ge_big_int bs1 bs2) + +(*val bitSeqCompare : bitSequence -> bitSequence -> ordering*) +let bitSeqCompare bs1 bs2 = (bitSeqArithBinTest Big_int.compare_big_int bs1 bs2) + +let instance_Basic_classes_Ord_Word_bitSequence_dict =({ + + compare_method = bitSeqCompare; + + isLess_method = bitSeqLess; + + isLessEqual_method = bitSeqLessEqual; + + isGreater_method = bitSeqGreater; + + isGreaterEqual_method = bitSeqGreaterEqual}) + +let instance_Basic_classes_SetType_Word_bitSequence_dict =({ + + setElemCompare_method = bitSeqCompare}) + +(* arithmetic negation, don't mix up with bitwise negation *) +(*val bitSeqNegate : bitSequence -> bitSequence*) +let bitSeqNegate bs = (bitSeqArithUnaryOp Big_int.minus_big_int bs) + +let instance_Num_NumNegate_Word_bitSequence_dict =({ + + numNegate_method = bitSeqNegate}) + + +(*val bitSeqAdd : bitSequence -> bitSequence -> bitSequence*) +let bitSeqAdd bs1 bs2 = (bitSeqArithBinOp Big_int.add_big_int bs1 bs2) + +let instance_Num_NumAdd_Word_bitSequence_dict =({ + + numAdd_method = bitSeqAdd}) + +(*val bitSeqMinus : bitSequence -> bitSequence -> bitSequence*) +let bitSeqMinus bs1 bs2 = (bitSeqArithBinOp Big_int.sub_big_int bs1 bs2) + +let instance_Num_NumMinus_Word_bitSequence_dict =({ + + numMinus_method = bitSeqMinus}) + +(*val bitSeqSucc : bitSequence -> bitSequence*) +let bitSeqSucc bs = (bitSeqArithUnaryOp Big_int.succ_big_int bs) + +let instance_Num_NumSucc_Word_bitSequence_dict =({ + + succ_method = bitSeqSucc}) + +(*val bitSeqPred : bitSequence -> bitSequence*) +let bitSeqPred bs = (bitSeqArithUnaryOp Big_int.pred_big_int bs) + +let instance_Num_NumPred_Word_bitSequence_dict =({ + + pred_method = bitSeqPred}) + +(*val bitSeqMult : bitSequence -> bitSequence -> bitSequence*) +let bitSeqMult bs1 bs2 = (bitSeqArithBinOp Big_int.mult_big_int bs1 bs2) + +let instance_Num_NumMult_Word_bitSequence_dict =({ + + numMult_method = bitSeqMult}) + + +(*val bitSeqPow : bitSequence -> nat -> bitSequence*) +let bitSeqPow bs n = (bitSeqArithUnaryOp (fun i -> Big_int.power_big_int_positive_int i n) bs) + +let instance_Num_NumPow_Word_bitSequence_dict =({ + + numPow_method = bitSeqPow}) + +(*val bitSeqDiv : bitSequence -> bitSequence -> bitSequence*) +let bitSeqDiv bs1 bs2 = (bitSeqArithBinOp Big_int.div_big_int bs1 bs2) + +let instance_Num_NumIntegerDivision_Word_bitSequence_dict =({ + + div_method = bitSeqDiv}) + +let instance_Num_NumDivision_Word_bitSequence_dict =({ + + numDivision_method = bitSeqDiv}) + +(*val bitSeqMod : bitSequence -> bitSequence -> bitSequence*) +let bitSeqMod bs1 bs2 = (bitSeqArithBinOp Big_int.mod_big_int bs1 bs2) + +let instance_Num_NumRemainder_Word_bitSequence_dict =({ + + mod_method = bitSeqMod}) + +(*val bitSeqMin : bitSequence -> bitSequence -> bitSequence*) +let bitSeqMin bs1 bs2 = (bitSeqArithBinOp Big_int.min_big_int bs1 bs2) + +(*val bitSeqMax : bitSequence -> bitSequence -> bitSequence*) +let bitSeqMax bs1 bs2 = (bitSeqArithBinOp Big_int.max_big_int bs1 bs2) + +let instance_Basic_classes_OrdMaxMin_Word_bitSequence_dict =({ + + max_method = bitSeqMax; + + min_method = bitSeqMin}) + + + + +(* ========================================================================== *) +(* Interface for bitoperations *) +(* ========================================================================== *) + +type 'a wordNot_class= { + lnot_method : 'a -> 'a +} + +type 'a wordAnd_class= { + land_method : 'a -> 'a -> 'a +} + +type 'a wordOr_class= { + lor_method : 'a -> 'a -> 'a +} + + +type 'a wordXor_class= { + lxor_method : 'a -> 'a -> 'a +} + +type 'a wordLsl_class= { + lsl_method : 'a -> int -> 'a +} + +type 'a wordLsr_class= { + lsr_method : 'a -> int -> 'a +} + +type 'a wordAsr_class= { + asr_method : 'a -> int -> 'a +} + +(* ----------------------- *) +(* bitSequence *) +(* ----------------------- *) + +let instance_Word_WordNot_Word_bitSequence_dict =({ + + lnot_method = bitSeqNot}) + +let instance_Word_WordAnd_Word_bitSequence_dict =({ + + land_method = bitSeqAnd}) + +let instance_Word_WordOr_Word_bitSequence_dict =({ + + lor_method = bitSeqOr}) + +let instance_Word_WordXor_Word_bitSequence_dict =({ + + lxor_method = bitSeqXor}) + +let instance_Word_WordLsl_Word_bitSequence_dict =({ + + lsl_method = bitSeqShiftLeft}) + +let instance_Word_WordLsr_Word_bitSequence_dict =({ + + lsr_method = bitSeqLogicalShiftRight}) + +let instance_Word_WordAsr_Word_bitSequence_dict =({ + + asr_method = bitSeqArithmeticShiftRight}) + + +(* ----------------------- *) +(* int32 *) +(* ----------------------- *) + +(*val int32Lnot : int32 -> int32*) (* XXX: fix *) + +let instance_Word_WordNot_Num_int32_dict =({ + + lnot_method = Int32.lognot}) + + +(*val int32Lor : int32 -> int32 -> int32*) (* XXX: fix *) + +let instance_Word_WordOr_Num_int32_dict =({ + + lor_method = Int32.logor}) + +(*val int32Lxor : int32 -> int32 -> int32*) (* XXX: fix *) + +let instance_Word_WordXor_Num_int32_dict =({ + + lxor_method = Int32.logxor}) + +(*val int32Land : int32 -> int32 -> int32*) (* XXX: fix *) + +let instance_Word_WordAnd_Num_int32_dict =({ + + land_method = Int32.logand}) + +(*val int32Lsl : int32 -> nat -> int32*) (* XXX: fix *) + +let instance_Word_WordLsl_Num_int32_dict =({ + + lsl_method = Int32.shift_left}) + +(*val int32Lsr : int32 -> nat -> int32*) (* XXX: fix *) + +let instance_Word_WordLsr_Num_int32_dict =({ + + lsr_method = Int32.shift_right_logical}) + + +(*val int32Asr : int32 -> nat -> int32*) (* XXX: fix *) + +let instance_Word_WordAsr_Num_int32_dict =({ + + asr_method = Int32.shift_right}) + + +(* ----------------------- *) +(* int64 *) +(* ----------------------- *) + +(*val int64Lnot : int64 -> int64*) (* XXX: fix *) + +let instance_Word_WordNot_Num_int64_dict =({ + + lnot_method = Int64.lognot}) + +(*val int64Lor : int64 -> int64 -> int64*) (* XXX: fix *) + +let instance_Word_WordOr_Num_int64_dict =({ + + lor_method = Int64.logor}) + +(*val int64Lxor : int64 -> int64 -> int64*) (* XXX: fix *) + +let instance_Word_WordXor_Num_int64_dict =({ + + lxor_method = Int64.logxor}) + +(*val int64Land : int64 -> int64 -> int64*) (* XXX: fix *) + +let instance_Word_WordAnd_Num_int64_dict =({ + + land_method = Int64.logand}) + +(*val int64Lsl : int64 -> nat -> int64*) (* XXX: fix *) + +let instance_Word_WordLsl_Num_int64_dict =({ + + lsl_method = Int64.shift_left}) + +(*val int64Lsr : int64 -> nat -> int64*) (* XXX: fix *) + +let instance_Word_WordLsr_Num_int64_dict =({ + + lsr_method = Int64.shift_right_logical}) + +(*val int64Asr : int64 -> nat -> int64*) (* XXX: fix *) + +let instance_Word_WordAsr_Num_int64_dict =({ + + asr_method = Int64.shift_right}) + + +(* ----------------------- *) +(* Words via bit sequences *) +(* ----------------------- *) + +(*val defaultLnot : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a*) +let defaultLnot fromBitSeq toBitSeq x = (fromBitSeq (bitSeqNegate (toBitSeq x))) + +(*val defaultLand : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a -> 'a*) +let defaultLand fromBitSeq toBitSeq x1 x2 = (fromBitSeq (bitSeqAnd (toBitSeq x1) (toBitSeq x2))) + +(*val defaultLor : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a -> 'a*) +let defaultLor fromBitSeq toBitSeq x1 x2 = (fromBitSeq (bitSeqOr (toBitSeq x1) (toBitSeq x2))) + +(*val defaultLxor : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> 'a -> 'a*) +let defaultLxor fromBitSeq toBitSeq x1 x2 = (fromBitSeq (bitSeqXor (toBitSeq x1) (toBitSeq x2))) + +(*val defaultLsl : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> nat -> 'a*) +let defaultLsl fromBitSeq toBitSeq x n = (fromBitSeq (bitSeqShiftLeft (toBitSeq x) n)) + +(*val defaultLsr : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> nat -> 'a*) +let defaultLsr fromBitSeq toBitSeq x n = (fromBitSeq (bitSeqLogicalShiftRight (toBitSeq x) n)) + +(*val defaultAsr : forall 'a. (bitSequence -> 'a) -> ('a -> bitSequence) -> 'a -> nat -> 'a*) +let defaultAsr fromBitSeq toBitSeq x n = (fromBitSeq (bitSeqArithmeticShiftRight (toBitSeq x) n)) + +(* ----------------------- *) +(* integer *) +(* ----------------------- *) + +(*val integerLnot : integer -> integer*) +let integerLnot i = (Big_int.minus_big_int( Big_int.add_big_int i(Big_int.big_int_of_int 1))) + +let instance_Word_WordNot_Num_integer_dict =({ + + lnot_method = integerLnot}) + + +(*val integerLor : integer -> integer -> integer*) +(*let integerLor i1 i2 = defaultLor integerFromBitSeq (bitSeqFromInteger Nothing) i1 i2*) + +let instance_Word_WordOr_Num_integer_dict =({ + + lor_method = Big_int.or_big_int}) + +(*val integerLxor : integer -> integer -> integer*) +(*let integerLxor i1 i2 = defaultLxor integerFromBitSeq (bitSeqFromInteger Nothing) i1 i2*) + +let instance_Word_WordXor_Num_integer_dict =({ + + lxor_method = Big_int.xor_big_int}) + +(*val integerLand : integer -> integer -> integer*) +(*let integerLand i1 i2 = defaultLand integerFromBitSeq (bitSeqFromInteger Nothing) i1 i2*) + +let instance_Word_WordAnd_Num_integer_dict =({ + + land_method = Big_int.and_big_int}) + +(*val integerLsl : integer -> nat -> integer*) +(*let integerLsl i n = defaultLsl integerFromBitSeq (bitSeqFromInteger Nothing) i n*) + +let instance_Word_WordLsl_Num_integer_dict =({ + + lsl_method = Big_int.shift_left_big_int}) + +(*val integerAsr : integer -> nat -> integer*) +(*let integerAsr i n = defaultAsr integerFromBitSeq (bitSeqFromInteger Nothing) i n*) + +let instance_Word_WordLsr_Num_integer_dict =({ + + lsr_method = Big_int.shift_right_big_int}) + +let instance_Word_WordAsr_Num_integer_dict =({ + + asr_method = Big_int.shift_right_big_int}) + + +(* ----------------------- *) +(* int *) +(* ----------------------- *) + +(* sometimes it is convenient to be able to perform bit-operations on ints. + However, since int is not well-defined (it has different size on different systems), + it should be used very carefully and only for operations that don't depend on the + bitwidth of int *) + +(*val intFromBitSeq : bitSequence -> int*) +let intFromBitSeq bs = (Big_int.int_of_big_int (integerFromBitSeq (resizeBitSeq (Some( 31)) bs))) + + +(*val bitSeqFromInt : int -> bitSequence*) +let bitSeqFromInt i = (bitSeqFromInteger (Some( 31)) (Big_int.big_int_of_int i)) + + +(*val intLnot : int -> int*) +(*let intLnot i = Instance_Num_NumNegate_Num_int.~((Instance_Num_NumAdd_Num_int.+) i 1)*) + +let instance_Word_WordNot_Num_int_dict =({ + + lnot_method = lnot}) + +(*val intLor : int -> int -> int*) +(*let intLor i1 i2 = defaultLor intFromBitSeq bitSeqFromInt i1 i2*) + +let instance_Word_WordOr_Num_int_dict =({ + + lor_method = (lor)}) + +(*val intLxor : int -> int -> int*) +(*let intLxor i1 i2 = defaultLxor intFromBitSeq bitSeqFromInt i1 i2*) + +let instance_Word_WordXor_Num_int_dict =({ + + lxor_method = (lxor)}) + +(*val intLand : int -> int -> int*) +(*let intLand i1 i2 = defaultLand intFromBitSeq bitSeqFromInt i1 i2*) + +let instance_Word_WordAnd_Num_int_dict =({ + + land_method = (land)}) + +(*val intLsl : int -> nat -> int*) +(*let intLsl i n = defaultLsl intFromBitSeq bitSeqFromInt i n*) + +let instance_Word_WordLsl_Num_int_dict =({ + + lsl_method = (lsl)}) + +(*val intAsr : int -> nat -> int*) +(*let intAsr i n = defaultAsr intFromBitSeq bitSeqFromInt i n*) + +let instance_Word_WordAsr_Num_int_dict =({ + + asr_method = (asr)}) + + + +(* ----------------------- *) +(* natural *) +(* ----------------------- *) + +(* some operations work also on positive numbers *) + +(*val naturalFromBitSeq : bitSequence -> natural*) +let naturalFromBitSeq bs = (Big_int.abs_big_int (integerFromBitSeq bs)) + +(*val bitSeqFromNatural : maybe nat -> natural -> bitSequence*) +let bitSeqFromNatural len n = (bitSeqFromInteger len ( n)) + +(*val naturalLor : natural -> natural -> natural*) +(*let naturalLor i1 i2 = defaultLor naturalFromBitSeq (bitSeqFromNatural Nothing) i1 i2*) + +let instance_Word_WordOr_Num_natural_dict =({ + + lor_method = Big_int.or_big_int}) + +(*val naturalLxor : natural -> natural -> natural*) +(*let naturalLxor i1 i2 = defaultLxor naturalFromBitSeq (bitSeqFromNatural Nothing) i1 i2*) + +let instance_Word_WordXor_Num_natural_dict =({ + + lxor_method = Big_int.xor_big_int}) + +(*val naturalLand : natural -> natural -> natural*) +(*let naturalLand i1 i2 = defaultLand naturalFromBitSeq (bitSeqFromNatural Nothing) i1 i2*) + +let instance_Word_WordAnd_Num_natural_dict =({ + + land_method = Big_int.and_big_int}) + +(*val naturalLsl : natural -> nat -> natural*) +(*let naturalLsl i n = defaultLsl naturalFromBitSeq (bitSeqFromNatural Nothing) i n*) + +let instance_Word_WordLsl_Num_natural_dict =({ + + lsl_method = Big_int.shift_left_big_int}) + +(*val naturalAsr : natural -> nat -> natural*) +(*let naturalAsr i n = defaultAsr naturalFromBitSeq (bitSeqFromNatural Nothing) i n*) + +let instance_Word_WordLsr_Num_natural_dict =({ + + lsr_method = Big_int.shift_right_big_int}) + +let instance_Word_WordAsr_Num_natural_dict =({ + + asr_method = Big_int.shift_right_big_int}) + + +(* ----------------------- *) +(* nat *) +(* ----------------------- *) + +(* sometimes it is convenient to be able to perform bit-operations on nats. + However, since nat is not well-defined (it has different size on different systems), + it should be used very carefully and only for operations that don't depend on the + bitwidth of nat *) + +(*val natFromBitSeq : bitSequence -> nat*) +let natFromBitSeq bs = (Big_int.int_of_big_int (naturalFromBitSeq (resizeBitSeq (Some( 31)) bs))) + + +(*val bitSeqFromNat : nat -> bitSequence*) +let bitSeqFromNat i = (bitSeqFromNatural (Some( 31)) (Big_int.big_int_of_int i)) + + +(*val natLor : nat -> nat -> nat*) +(*let natLor i1 i2 = defaultLor natFromBitSeq bitSeqFromNat i1 i2*) + +let instance_Word_WordOr_nat_dict =({ + + lor_method = (lor)}) + +(*val natLxor : nat -> nat -> nat*) +(*let natLxor i1 i2 = defaultLxor natFromBitSeq bitSeqFromNat i1 i2*) + +let instance_Word_WordXor_nat_dict =({ + + lxor_method = (lxor)}) + +(*val natLand : nat -> nat -> nat*) +(*let natLand i1 i2 = defaultLand natFromBitSeq bitSeqFromNat i1 i2*) + +let instance_Word_WordAnd_nat_dict =({ + + land_method = (land)}) + +(*val natLsl : nat -> nat -> nat*) +(*let natLsl i n = defaultLsl natFromBitSeq bitSeqFromNat i n*) + +let instance_Word_WordLsl_nat_dict =({ + + lsl_method = (lsl)}) + +(*val natAsr : nat -> nat -> nat*) +(*let natAsr i n = defaultAsr natFromBitSeq bitSeqFromNat i n*) + +let instance_Word_WordAsr_nat_dict =({ + + asr_method = (asr)}) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/nat_big_num.ml b/lib/ocaml_rts/linksem/src_lem_library/nat_big_num.ml new file mode 100644 index 00000000..2320188c --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/nat_big_num.ml @@ -0,0 +1,18 @@ +module BI = Big_int + +type num = BI.big_int +let (<) = BI.lt_big_int +let (<=) = BI.le_big_int +let (>) = BI.gt_big_int +let (>=) = BI.ge_big_int +let (+) = BI.add_big_int +let (-) x y = + let d = BI.sub_big_int x y in + if d < BI.zero_big_int then + BI.zero_big_int + else + d +let ( * ) = BI.mult_big_int +let (/) = BI.div_big_int +let (mod) = BI.mod_big_int +let string_of_num = BI.string_of_big_int diff --git a/lib/ocaml_rts/linksem/src_lem_library/nat_big_num.mli b/lib/ocaml_rts/linksem/src_lem_library/nat_big_num.mli new file mode 100644 index 00000000..b6f6eb63 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/nat_big_num.mli @@ -0,0 +1,11 @@ +type num +val (<) : num -> num -> bool +val (<=) : num -> num -> bool +val (>) : num -> num -> bool +val (>=) : num -> num -> bool +val (+) : num -> num -> num +val (-) : num -> num -> num +val ( * ) : num -> num -> num +val (/) : num -> num -> num +val (mod) : num -> num -> num +val string_of_num : num -> string diff --git a/lib/ocaml_rts/linksem/src_lem_library/nat_num.ml b/lib/ocaml_rts/linksem/src_lem_library/nat_num.ml new file mode 100755 index 00000000..50165e6d --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/nat_num.ml @@ -0,0 +1,43 @@ +type nat = int +type natural = Big_int.big_int + +let nat_monus x y = + let d = x - y in + if d < 0 then + 0 + else + d + +let natural_monus x y = + (if Big_int.le_big_int x y then + Big_int.zero_big_int + else + (Big_int.sub_big_int x y)) + +let nat_pred x = nat_monus x 1 +let natural_pred x = natural_monus x Big_int.unit_big_int + +let int_mod i n = + let r = i mod n in + if (r < 0) then r + n else r + +let int_div i n = + let r = i / n in + if (i mod n < 0) then r - 1 else r + +let int32_mod i n = + let r = Int32.rem i n in + if (r < Int32.zero) then Int32.add r n else r + +let int32_div i n = + let r = Int32.div i n in + if (Int32.rem i n < Int32.zero) then Int32.pred r else r + +let int64_mod i n = + let r = Int64.rem i n in + if (r < Int64.zero) then Int64.add r n else r + +let int64_div i n = + let r = Int64.div i n in + if (Int64.rem i n < Int64.zero) then Int64.pred r else r + diff --git a/lib/ocaml_rts/linksem/src_lem_library/nat_num.mli b/lib/ocaml_rts/linksem/src_lem_library/nat_num.mli new file mode 100755 index 00000000..d918b9df --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/nat_num.mli @@ -0,0 +1,14 @@ +type nat = int +type natural = Big_int.big_int + +val natural_monus : natural -> natural -> natural +val natural_pred : natural -> natural + +val nat_pred : nat -> nat +val nat_monus : nat -> nat -> nat +val int_div : int -> int -> int +val int32_div : Int32.t -> Int32.t -> Int32.t +val int64_div : Int64.t -> Int64.t -> Int64.t +val int_mod : int -> int -> int +val int32_mod : Int32.t -> Int32.t -> Int32.t +val int64_mod : Int64.t -> Int64.t -> Int64.t diff --git a/lib/ocaml_rts/linksem/src_lem_library/pmap.ml b/lib/ocaml_rts/linksem/src_lem_library/pmap.ml new file mode 100755 index 00000000..9e9f607b --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/pmap.ml @@ -0,0 +1,321 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Modified by Susmit Sarkar 2010-11-30 *) +(* $Id: map.ml 10468 2010-05-25 13:29:43Z frisch $ *) + +(* A map from ordered keys *) + +type ('key,'a) rep = + Empty + | Node of ('key,'a) rep * 'key * 'a * ('key,'a) rep * int + +let height = function + Empty -> 0 + | Node(_,_,_,_,h) -> h + +let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let singleton x d = Node(Empty, x, d, Empty, 1) + +let bal l x d r = + let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node(ll, lv, ld, lr, _) -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node(lrl, lrv, lrd, lrr, _)-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node(rl, rv, rd, rr, _) -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node(rll, rlv, rld, rlr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let empty = Empty + +let is_empty = function Empty -> true | _ -> false + +let rec add cmp x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + let c = cmp x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 then + bal (add cmp x data l) v d r + else + bal l v d (add cmp x data r) + +let rec find cmp x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = cmp x v in + if c = 0 then d + else find cmp x (if c < 0 then l else r) + +let rec mem cmp x = function + Empty -> + false + | Node(l, v, d, r, _) -> + let c = cmp x v in + c = 0 || mem cmp x (if c < 0 then l else r) + +let rec min_binding = function + Empty -> raise Not_found + | Node(Empty, x, d, r, _) -> (x, d) + | Node(l, x, d, r, _) -> min_binding l + +let rec max_binding = function + Empty -> raise Not_found + | Node(l, x, d, Empty, _) -> (x, d) + | Node(l, x, d, r, _) -> max_binding r + +let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node(Empty, x, d, r, _) -> r + | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r + +let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + bal t1 x d (remove_min_binding t2) + +let rec remove cmp x = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let c = cmp x v in + if c = 0 then + merge l r + else if c < 0 then + bal (remove cmp x l) v d r + else + bal l v d (remove cmp x r) + +let rec iter f = function + Empty -> () + | Node(l, v, d, r, _) -> + iter f l; f v d; iter f r + +let rec map f = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let l' = map f l in + let d' = f d in + let r' = map f r in + Node(l', v, d', r', h) + +let rec mapi f = function + Empty -> + Empty + | Node(l, v, d, r, h) -> + let l' = mapi f l in + let d' = f v d in + let r' = mapi f r in + Node(l', v, d', r', h) + +let rec fold f m accu = + match m with + Empty -> accu + | Node(l, v, d, r, _) -> + fold f r (f v d (fold f l accu)) + +let rec for_all p = function + Empty -> true + | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r + +let rec exists p = function + Empty -> false + | Node(l, v, d, r, _) -> p v d || exists p l || exists p r + +let filter cmp p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, d, r, _) -> + filt (filt (if p v d then add cmp v d accu else accu) l) r in + filt Empty s + +let partition cmp p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, d, r, _) -> + part (part (if p v d then (add cmp v d t, f) else (t, add cmp v d f)) l) r in + part (Empty, Empty) s + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + +let rec join cmp l v d r = + match (l, r) with + (Empty, _) -> add cmp v d r + | (_, Empty) -> add cmp v d l + | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> + if lh > rh + 2 then bal ll lv ld (join cmp lr v d r) else + if rh > lh + 2 then bal (join cmp l v d rl) rv rd rr else + create l v d r + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + +let concat cmp t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + join cmp t1 x d (remove_min_binding t2) + +let concat_or_join cmp t1 v d t2 = + match d with + | Some d -> join cmp t1 v d t2 + | None -> concat cmp t1 t2 + +let rec split cmp x = function + Empty -> + (Empty, None, Empty) + | Node(l, v, d, r, _) -> + let c = cmp x v in + if c = 0 then (l, Some d, r) + else if c < 0 then + let (ll, pres, rl) = split cmp x l in (ll, pres, join cmp rl v d r) + else + let (lr, pres, rr) = split cmp x r in (join cmp l v d lr, pres, rr) + +let rec merge cmp f s1 s2 = + match (s1, s2) with + (Empty, Empty) -> Empty + | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> + let (l2, d2, r2) = split cmp v1 s2 in + concat_or_join cmp (merge cmp f l1 l2) v1 (f v1 (Some d1) d2) (merge cmp f r1 r2) + | (_, Node (l2, v2, d2, r2, h2)) -> + let (l1, d1, r1) = split cmp v2 s1 in + concat_or_join cmp (merge cmp f l1 l2) v2 (f v2 d1 (Some d2)) (merge cmp f r1 r2) + | _ -> + assert false + +type ('key,'a) enumeration = End | More of 'key * 'a * ('key,'a) rep * ('key,'a) enumeration + +let rec cons_enum m e = + match m with + Empty -> e + | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) + +let compare cmp_key cmp_a m1 m2 = + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + let c = cmp_key v1 v2 in + if c <> 0 then c else + let c = cmp_a d1 d2 in + if c <> 0 then c else + compare_aux (cons_enum r1 e1) (cons_enum r2 e2) + in compare_aux (cons_enum m1 End) (cons_enum m2 End) + +let equal cmp_key cmp_a m1 m2 = + let rec equal_aux e1 e2 = + match (e1, e2) with + (End, End) -> true + | (End, _) -> false + | (_, End) -> false + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + cmp_key v1 v2 = 0 && cmp_a d1 d2 && + equal_aux (cons_enum r1 e1) (cons_enum r2 e2) + in equal_aux (cons_enum m1 End) (cons_enum m2 End) + +let rec cardinal = function + Empty -> 0 + | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r + +let rec bindings_aux accu = function + Empty -> accu + | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l + +let bindings s = + bindings_aux [] s + +let choose = min_binding + + +(* Wrapper functions now *) + +type ('key,'a) map = {cmp:'key -> 'key -> int; m:('key,'a) rep} + +let empty cmp = {cmp = cmp; m = Empty} +let is_empty m = is_empty m.m +let mem k m = mem m.cmp k m.m +let add k a m = {m with m = add m.cmp k a m.m} +let singleton cmp k a = {cmp = cmp; m = singleton k a} +let remove k m = {m with m = remove m.cmp k m.m} +let merge f a b = {cmp = a.cmp; (* does not matter, a and b should have the same comparison function *) + m = merge a.cmp f a.m b.m;} +let union a b = merge (fun k o1 o2 -> + match (o1, o2) with + | (_, Some v) -> Some v + | (Some v, _) -> Some v + | (_, _) -> None) a b + let compare f a b = compare a.cmp f a.m b.m +let equal f a b = equal a.cmp f a.m b.m +let iter f m = iter f m.m +let fold f m b = fold f m.m b +let for_all f m = for_all f m.m +let exist f m = exists f m.m +let filter f m = {m with m = filter m.cmp f m.m} +let partition f m = + let m1,m2 = partition m.cmp f m.m in + ({m with m = m1},{m with m = m2}) +let cardinal m = cardinal m.m +let domain m = Pset.from_list m.cmp (List.map fst (bindings m.m)) +let range cmp m = Pset.from_list cmp (List.map snd (bindings m.m)) +let bindings_list m = bindings m.m +let bindings cmp m = Pset.from_list cmp (bindings m.m) +let min_binding m = min_binding m.m +let max_binding m = max_binding m.m +let choose m = choose m.m +let split k m = + let (m1,opt,m2) = split m.cmp k m.m in + ({m with m = m1},opt,{m with m = m2}) +let find k m = find m.cmp k m.m +let lookup k m = try Some (find k m) with Not_found -> None +let map f m = {m with m = map f m.m} +let mapi f m = {m with m = mapi f m.m} + +let from_set f s = Pset.fold (fun k m -> (add k (f k) m)) s (empty (Pset.get_elem_compare s)) diff --git a/lib/ocaml_rts/linksem/src_lem_library/pmap.mli b/lib/ocaml_rts/linksem/src_lem_library/pmap.mli new file mode 100755 index 00000000..f2016418 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/pmap.mli @@ -0,0 +1,190 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Modified by Susmit Sarkar 2010-11-30 *) +(* $Id: map.mli 10632 2010-07-24 14:16:58Z garrigue $ *) + +(** Association tables over ordered types. + + This module implements applicative association tables, also known as + finite maps or dictionaries, given a total ordering function + over the keys. + All operations over maps are purely applicative (no side-effects). + The implementation uses balanced binary trees, and therefore searching + and insertion take time logarithmic in the size of the map. +*) + +type ('key,+'a) map + (** The type of maps from type ['key] to type ['a]. *) + +val empty: ('key -> 'key -> int) -> ('key,'a) map + (** The empty map. *) + +val is_empty: ('key,'a) map -> bool + (** Test whether a map is empty or not. *) + +val mem: 'key -> ('key,'a) map -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + +val add: 'key -> 'a -> ('key,'a) map -> ('key,'a) map + (** [add x y m] returns a map containing the same bindings as + [m], plus a binding of [x] to [y]. If [x] was already bound + in [m], its previous binding disappears. *) + +val singleton: ('key -> 'key -> int) -> 'key -> 'a -> ('key,'a) map + (** [singleton x y] returns the one-element map that contains a binding [y] + for [x]. + @since 3.12.0 + *) + +val remove: 'key -> ('key,'a) map -> ('key,'a) map + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. *) + +val merge: + ('key -> 'a option -> 'b option -> 'c option) -> ('key,'a) map -> ('key,'b) map -> ('key,'c) map + (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + @since 3.12.0 + *) + +val union: ('key,'a) map -> ('key,'a) map -> ('key,'a) map + (** [union m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The bindings in m2 take precedence. + @since 3.12.0 + *) + +val compare: ('a -> 'a -> int) -> ('key,'a) map -> ('key,'a) map -> int + (** Total ordering between maps. The first argument is a total ordering + used to compare data associated with equal keys in the two maps. *) + +val equal: ('a -> 'a -> bool) -> ('key,'a) map -> ('key,'a) map -> bool + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + +val iter: ('key -> 'a -> unit) -> ('key,'a) map -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + +val fold: ('key -> 'a -> 'b -> 'b) -> ('key,'a) map -> 'b -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + +val for_all: ('key -> 'a -> bool) -> ('key,'a) map -> bool + (** [for_all p m] checks if all the bindings of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + +val exist: ('key -> 'a -> bool) -> ('key,'a) map -> bool + (** [exists p m] checks if at least one binding of the map + satisfy the predicate [p]. + @since 3.12.0 + *) + +val filter: ('key -> 'a -> bool) -> ('key,'a) map -> ('key,'a) map + (** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. + @since 3.12.0 + *) + +val partition: ('key -> 'a -> bool) -> ('key,'a) map -> ('key,'a) map * ('key,'a) map + (** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + @since 3.12.0 + *) + +val cardinal: ('key,'a) map -> int + (** Return the number of bindings of a map. + @since 3.12.0 + *) + +val bindings_list: ('key,'a) map -> ('key * 'a) list + (** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + @since 3.12.0 + *) + +val bindings: (('key * 'a) -> ('key * 'a) -> int) -> ('key,'a) map -> ('key * 'a) Pset.set + (** Return a set of all bindings of the given map. *) + +(** [domain m] returns the domain of the map [m], i.e. the + set of keys of this map. *) +val domain : ('key,'a) map -> 'key Pset.set + +(** [range m] returns the range of the map [m], i.e. the + set of all values stored in this map. *) +val range : ('a -> 'a -> int) -> ('key,'a) map -> 'a Pset.set + +val min_binding: ('key,'a) map -> ('key * 'a) + (** Return the smallest binding of the given map + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the map is empty. + @since 3.12.0 + *) + +val max_binding: ('key,'a) map -> ('key * 'a) + (** Same as {!Map.S.min_binding}, but returns the largest binding + of the given map. + @since 3.12.0 + *) + +val choose: ('key,'a) map -> ('key * 'a) + (** Return one binding of the given map, or raise [Not_found] if + the map is empty. Which binding is chosen is unspecified, + but equal bindings will be chosen for equal maps. + @since 3.12.0 + *) + +val split: 'key -> ('key,'a) map -> ('key,'a) map * 'a option * ('key,'a) map + (** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + @since 3.12.0 + *) + +val find: 'key -> ('key,'a) map -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) + +val lookup: 'key -> ('key,'a) map -> 'a option + (** [lookup x m] returns the current binding of [x] in [m]. In contrast to [find], + it returns [None] instead of raising an exception, if no such binding exists. *) + +val map: ('a -> 'b) -> ('key,'a) map -> ('key,'b) map + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + +val mapi: ('key -> 'a -> 'b) -> ('key,'a) map -> ('key,'b) map + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) + +val from_set : ('key -> 'v) -> ('key Pset.set) -> ('key, 'v) map diff --git a/lib/ocaml_rts/linksem/src_lem_library/pset.ml b/lib/ocaml_rts/linksem/src_lem_library/pset.ml new file mode 100755 index 00000000..35335e88 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/pset.ml @@ -0,0 +1,522 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Modified by Scott Owens 2010-10-28 *) + +(* $Id: set.ml 6694 2004-11-25 00:06:06Z doligez $ *) + +(* Sets over ordered types *) + +type 'a rep = Empty | Node of 'a rep * 'a * 'a rep * int + +(* Sets are represented by balanced binary trees (the heights of the + children differ by at most 2 *) + +let height = function + Empty -> 0 + | Node(_, _, _, h) -> h + +(* Creates a new node with left son l, value v and right son r. + We must have all elements of l < v < all elements of r. + l and r must be balanced and | height l - height r | <= 2. + Inline expansion of height for better speed. *) + +let create l v r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + +(* Same as create, but performs one step of rebalancing if necessary. + Assumes l and r balanced and | height l - height r | <= 3. + Inline expansion of create for better speed in the most frequent case + where no rebalancing is required. *) + +let bal l v r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Set.bal" + | Node(ll, lv, lr, _) -> + if height ll >= height lr then + create ll lv (create lr v r) + else begin + match lr with + Empty -> invalid_arg "Set.bal" + | Node(lrl, lrv, lrr, _)-> + create (create ll lv lrl) lrv (create lrr v r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Set.bal" + | Node(rl, rv, rr, _) -> + if height rr >= height rl then + create (create l v rl) rv rr + else begin + match rl with + Empty -> invalid_arg "Set.bal" + | Node(rll, rlv, rlr, _) -> + create (create l v rll) rlv (create rlr rv rr) + end + end else + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + +(* Insertion of one element *) + +let rec add cmp x = function + Empty -> Node(Empty, x, Empty, 1) + | Node(l, v, r, _) as t -> + let c = cmp x v in + if c = 0 then t else + if c < 0 then bal (add cmp x l) v r else bal l v (add cmp x r) + +(* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + +let rec join cmp l v r = + match (l, r) with + (Empty, _) -> add cmp v r + | (_, Empty) -> add cmp v l + | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> + if lh > rh + 2 then bal ll lv (join cmp lr v r) else + if rh > lh + 2 then bal (join cmp l v rl) rv rr else + create l v r + +(* Smallest and greatest element of a set *) + +let rec min_elt = function + Empty -> raise Not_found + | Node(Empty, v, r, _) -> v + | Node(l, v, r, _) -> min_elt l + +let rec max_elt = function + Empty -> raise Not_found + | Node(l, v, Empty, _) -> v + | Node(l, v, r, _) -> max_elt r + +(* Remove the smallest element of the given set *) + +let rec remove_min_elt = function + Empty -> invalid_arg "Set.remove_min_elt" + | Node(Empty, v, r, _) -> r + | Node(l, v, r, _) -> bal (remove_min_elt l) v r + +(* Merge two trees l and r into one. + All elements of l must precede the elements of r. + Assume | height l - height r | <= 2. *) + +let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) + +(* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + +let concat cmp t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> join cmp t1 (min_elt t2) (remove_min_elt t2) + +(* Splitting. split x s returns a triple (l, present, r) where + - l is the set of elements of s that are < x + - r is the set of elements of s that are > x + - present is false if s contains no element equal to x, + or true if s contains an element equal to x. *) + +let rec split cmp x = function + Empty -> + (Empty, false, Empty) + | Node(l, v, r, _) -> + let c = cmp x v in + if c = 0 then (l, true, r) + else if c < 0 then + let (ll, pres, rl) = split cmp x l in (ll, pres, join cmp rl v r) + else + let (lr, pres, rr) = split cmp x r in (join cmp l v lr, pres, rr) + +(* Implementation of the set operations *) + +let empty = Empty + +let is_empty = function Empty -> true | _ -> false + +let rec mem cmp x = function + Empty -> false + | Node(l, v, r, _) -> + let c = cmp x v in + c = 0 || mem cmp x (if c < 0 then l else r) + +let singleton x = Node(Empty, x, Empty, 1) + +let rec remove cmp x = function + Empty -> Empty + | Node(l, v, r, _) -> + let c = cmp x v in + if c = 0 then merge l r else + if c < 0 then bal (remove cmp x l) v r else bal l v (remove cmp x r) + +let rec union cmp s1 s2 = + match (s1, s2) with + (Empty, t2) -> t2 + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> + if h1 >= h2 then + if h2 = 1 then add cmp v2 s1 else begin + let (l2, _, r2) = split cmp v1 s2 in + join cmp (union cmp l1 l2) v1 (union cmp r1 r2) + end + else + if h1 = 1 then add cmp v1 s2 else begin + let (l1, _, r1) = split cmp v2 s1 in + join cmp (union cmp l1 l2) v2 (union cmp r1 r2) + end + +let rec inter cmp s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> Empty + | (Node(l1, v1, r1, _), t2) -> + match split cmp v1 t2 with + (l2, false, r2) -> + concat cmp (inter cmp l1 l2) (inter cmp r1 r2) + | (l2, true, r2) -> + join cmp (inter cmp l1 l2) v1 (inter cmp r1 r2) + +let rec diff cmp s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, _), t2) -> + match split cmp v1 t2 with + (l2, false, r2) -> + join cmp (diff cmp l1 l2) v1 (diff cmp r1 r2) + | (l2, true, r2) -> + concat cmp (diff cmp l1 l2) (diff cmp r1 r2) + +type 'a enumeration = End | More of 'a * 'a rep * 'a enumeration + +let rec cons_enum s e = + match s with + Empty -> e + | Node(l, v, r, _) -> cons_enum l (More(v, r, e)) + +let rec compare_aux cmp e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, r1, e1), More(v2, r2, e2)) -> + let c = cmp v1 v2 in + if c <> 0 + then c + else compare_aux cmp (cons_enum r1 e1) (cons_enum r2 e2) + +let compare cmp s1 s2 = + compare_aux cmp (cons_enum s1 End) (cons_enum s2 End) + +let equal cmp s1 s2 = + compare cmp s1 s2 = 0 + +let rec subset cmp s1 s2 = + match (s1, s2) with + Empty, _ -> + true + | _, Empty -> + false + | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> + let c = cmp v1 v2 in + if c = 0 then + subset cmp l1 l2 && subset cmp r1 r2 + else if c < 0 then + subset cmp (Node (l1, v1, Empty, 0)) l2 && subset cmp r1 t2 + else + subset cmp (Node (Empty, v1, r1, 0)) r2 && subset cmp l1 t2 + +let rec iter f = function + Empty -> () + | Node(l, v, r, _) -> iter f l; f v; iter f r + +let rec fold f s accu = + match s with + Empty -> accu + | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) + +let map cmp f s = fold (fun e s -> add cmp (f e) s) s empty + +let map_union cmp f s = fold (fun e s -> union cmp (f e) s) s empty + + +let rec for_all p = function + Empty -> true + | Node(l, v, r, _) -> p v && for_all p l && for_all p r + +let rec exists p = function + Empty -> false + | Node(l, v, r, _) -> p v || exists p l || exists p r + +let filter cmp p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, r, _) -> + filt (filt (if p v then add cmp v accu else accu) l) r in + filt Empty s + +let partition cmp p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, r, _) -> + part (part (if p v then (add cmp v t, f) else (t, add cmp v f)) l) r in + part (Empty, Empty) s + +let rec cardinal = function + Empty -> 0 + | Node(l, v, r, _) -> cardinal l + 1 + cardinal r + +let rec elements_aux accu = function + Empty -> accu + | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l + +let elements s = + elements_aux [] s + +let choose = min_elt + +type 'a set = { cmp : 'a -> 'a -> int; s : 'a rep } + +let empty c = { cmp = c; s = Empty; } + +let is_empty s = is_empty s.s + +let mem x s = mem s.cmp x s.s + +let add x s = { s with s = add s.cmp x s.s } + +let singleton c x = { cmp = c; s = singleton x } + +let remove x s = { s with s = remove s.cmp x s.s } + +let union s1 s2 = { s1 with s = union s1.cmp s1.s s2.s } + +let map_union c f s1 = { cmp = c; s = map_union c (fun x -> (f x).s) s1.s} + +let inter s1 s2 = { s1 with s = inter s1.cmp s1.s s2.s } + +let diff s1 s2 = { s1 with s = diff s1.cmp s1.s s2.s } + +let compare_by cmp s1 s2 = compare cmp s1.s s2.s + +let compare s1 s2 = compare s1.cmp s1.s s2.s + +let equal s1 s2 = equal s1.cmp s1.s s2.s + +let subset s1 s2 = subset s1.cmp s1.s s2.s +let subset_proper s1 s2 = (subset s1 s2) && not (equal s1 s2) + +let iter f s = iter f s.s + +let fold f s a = fold f s.s a + +let map c f s = {cmp = c; s = map c f s.s} + +let for_all p s = for_all p s.s + +let exists p s = exists p s.s + +let filter p s = { s with s = filter s.cmp p s.s } + +let partition p s = + let (r1,r2) = partition s.cmp p s.s in + ({s with s = r1}, {s with s = r2}) + +let cardinal s = cardinal s.s + +let elements s = elements s.s + +let min_elt s = min_elt s.s + +let min_elt_opt s = try Some (min_elt s) with Not_found -> None + +let max_elt s = max_elt s.s + +let max_elt_opt s = try Some (max_elt s) with Not_found -> None + +let choose s = choose s.s + +let set_case s c_emp c_sing c_else = match s.s with + Empty -> c_emp + | Node(Empty, v, Empty, _) -> c_sing v + | _ -> c_else + +let split x s = + let (l,present,r) = split s.cmp x s.s in + ({ s with s = l }, present, { s with s = r }) + +let from_list c l = + List.fold_left (fun s x -> add x s) (empty c) l + +let comprehension1 cmp f p s = + fold (fun x s -> if p x then add (f x) s else s) s (empty cmp) + +let comprehension2 cmp f p s1 s2 = + fold + (fun x1 s -> + fold + (fun x2 s -> + if p x1 x2 then add (f x1 x2) s else s) + s2 + s) + s1 + (empty cmp) + +let comprehension3 cmp f p s1 s2 s3 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + if p x1 x2 x3 then add (f x1 x2 x3) s else s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension4 cmp f p s1 s2 s3 s4 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + if p x1 x2 x3 x4 then add (f x1 x2 x3 x4) s else s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension5 cmp f p s1 s2 s3 s4 s5 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + fold + (fun x5 s -> + if p x1 x2 x3 x4 x5 then add (f x1 x2 x3 x4 x5) s else s) + s5 + s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension6 cmp f p s1 s2 s3 s4 s5 s6 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + fold + (fun x5 s -> + fold + (fun x6 s -> + if p x1 x2 x3 x4 x5 x6 then add (f x1 x2 x3 x4 x5 x6) s else s) + s6 + s) + s5 + s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension7 cmp f p s1 s2 s3 s4 s5 s6 s7 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + fold + (fun x5 s -> + fold + (fun x6 s -> + fold + (fun x7 s -> + if p x1 x2 x3 x4 x5 x6 x7 then add (f x1 x2 x3 x4 x5 x6 x7) s else s) + s7 + s) + s6 + s) + s5 + s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let bigunion c xss = + fold union xss (empty c) + +let sigma c xs ys = + fold (fun x xys -> fold (fun y xys -> add (x,y) xys) (ys x) xys) xs (empty c) + +let cross c xs ys = sigma c xs (fun _ -> ys) + +let rec lfp s f = + let s' = f s in + if subset s' s then + s + else + lfp (union s' s) f + +let tc c r = + let one_step r = fold (fun (x,y) xs -> fold (fun (y',z) xs -> + if c (y,y) (y',y') = 0 then add (x,z) xs else xs) r xs) r (empty c) in + lfp r one_step + + +let get_elem_compare s = s.cmp + diff --git a/lib/ocaml_rts/linksem/src_lem_library/pset.mli b/lib/ocaml_rts/linksem/src_lem_library/pset.mli new file mode 100755 index 00000000..162d5f3b --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/pset.mli @@ -0,0 +1,174 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Modified by Scott Owens 2010-10-28 *) + +(* $Id: set.mli 6974 2005-07-21 14:52:45Z doligez $ *) + +(** Sets over ordered types. + + This module implements the set data structure, given a total ordering + function over the set elements. All operations over sets + are purely applicative (no side-effects). + The implementation uses balanced binary trees, and is therefore + reasonably efficient: insertion and membership take time + logarithmic in the size of the set, for instance. + *) + +type 'a set +(** The type of sets. *) + +val empty: ('a -> 'a -> int) -> 'a set +(** The empty set. *) + +val is_empty: 'a set -> bool +(** Test whether a set is empty or not. *) + +val from_list: ('a -> 'a -> int) -> 'a list -> 'a set + +val mem: 'a -> 'a set -> bool +(** [mem x s] tests whether [x] belongs to the set [s]. *) + +val add: 'a -> 'a set -> 'a set +(** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + +val singleton: ('a -> 'a -> int) -> 'a -> 'a set +(** [singleton x] returns the one-element set containing only [x]. *) + +val remove: 'a -> 'a set -> 'a set +(** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + +val union: 'a set -> 'a set -> 'a set +(** Set union. *) + +val inter: 'a set -> 'a set -> 'a set +(** Set intersection. *) + +(** Set difference. *) +val diff: 'a set -> 'a set -> 'a set + +val compare: 'a set -> 'a set -> int +(** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + +val equal: 'a set -> 'a set -> bool +(** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + +val subset: 'a set -> 'a set -> bool +(** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. This includes the case where [s1] and [s2] are equal. *) + +val subset_proper : 'a set -> 'a set -> bool +(** [subset_proper s1 s2] tests whether the set [s1] is a proper subset of + the set [s2]. *) + +val iter: ('a -> unit) -> 'a set -> unit +(** [iter f s] applies [f] in turn to all elements of [s]. + The elements of [s] are presented to [f] in increasing order + with respect to the ordering over the type of the elements. *) + +val fold: ('a -> 'b -> 'b) -> 'a set -> 'b -> 'b +(** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) + +val map: ('b -> 'b -> int) -> ('a -> 'b) -> 'a set -> 'b set + +val map_union: ('b -> 'b -> int) -> ('a -> 'b set) -> 'a set -> 'b set +(** [map_union cmp f s] does the same as [bigunion cmp (map cmp' f s)]. + Because the set of sets is internally not constructed though the comparison function [cmp'] is + not needed. *) + +val for_all: ('a -> bool) -> 'a set -> bool +(** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + +val exists: ('a -> bool) -> 'a set -> bool +(** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + +val filter: ('a -> bool) -> 'a set -> 'a set +(** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + +val partition: ('a -> bool) -> 'a set -> 'a set * 'a set +(** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + +val cardinal: 'a set -> int +(** Return the number of elements of a set. *) + +val elements: 'a set -> 'a list +(** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Set.Make}. *) + +val min_elt: 'a set -> 'a +(** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) + +val max_elt: 'a set -> 'a +(** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) + +val min_elt_opt: 'a set -> 'a option +(** an optional version of [min_elt] *) + +val max_elt_opt: 'a set -> 'a option +(** an optional version of [max_elt] *) + +val choose: 'a set -> 'a +(** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) + +val set_case: 'a set -> 'b -> ('a -> 'b) -> 'b -> 'b +(** case-split function for sets *) + +val split: 'a -> 'a set -> 'a set * bool * 'a set + (** [split x s] returns a triple [(l, present, r)], where + [l] is the set of elements of [s] that are + strictly less than [x]; + [r] is the set of elements of [s] that are + strictly greater than [x]; + [present] is [false] if [s] contains no element equal to [x], + or [true] if [s] contains an element equal to [x]. *) + +val comprehension1 : ('b -> 'b -> int) -> ('a -> 'b) -> ('a -> bool) -> 'a set -> 'b set +val comprehension2 : ('c -> 'c -> int) -> ('a -> 'b -> 'c) -> ('a -> 'b -> bool) -> 'a set -> 'b set -> 'c set +val comprehension3 : ('d -> 'd -> int) -> ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> bool) -> 'a set -> 'b set -> 'c set -> 'd set +val comprehension4 : ('e -> 'e -> int) -> ('a -> 'b -> 'c -> 'd -> 'e) -> ('a -> 'b -> 'c -> 'd -> bool) -> 'a set -> 'b set -> 'c set -> 'd set -> 'e set +val comprehension5 : ('f -> 'f -> int) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> ('a -> 'b -> 'c -> 'd -> 'e -> bool) -> 'a set -> 'b set -> 'c set -> 'd set -> 'e set -> 'f set +val comprehension6 : ('g -> 'g -> int) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> bool) -> 'a set -> 'b set -> 'c set -> 'd set -> 'e set -> 'f set -> 'g set +val comprehension7 : ('h -> 'h -> int) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> bool) -> 'a set -> 'b set -> 'c set -> 'd set -> 'e set -> 'f set -> 'g set -> 'h set + +val bigunion : ('a -> 'a -> int) -> 'a set set -> 'a set + +val lfp : 'a set -> ('a set -> 'a set) -> 'a set +val tc : ('a * 'a -> 'a * 'a -> int) -> ('a * 'a) set -> ('a * 'a) set + + +val sigma : ('a * 'b -> 'a * 'b -> int) -> 'a set -> ('a -> 'b set) -> ('a * 'b) set +val cross : ('a * 'b -> 'a * 'b -> int) -> 'a set -> 'b set -> ('a * 'b) set + +val get_elem_compare : 'a set -> ('a -> 'a -> int) + +val compare_by: ('a->'a->int) -> 'a set -> 'a set -> int +(** set comparison parameterised by element comparison (ignoring the comparison functions of the argument sets*) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/pset_using_lists.ml b/lib/ocaml_rts/linksem/src_lem_library/pset_using_lists.ml new file mode 100644 index 00000000..1fadd8f7 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/pset_using_lists.ml @@ -0,0 +1,336 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Modified by Scott Owens 2010-10-28 *) +(* Modified by Kyndylan Nienhuis 2013-04-.. *) + +(* $Id: set.ml 6694 2004-11-25 00:06:06Z doligez $ *) + +(* Sets over ordered types *) + + + +(* Implementation of the set operations *) + +type 'a rep = 'a list + +exception Not_implemented + +let rec add cmp x list = + x::list + +let empty = [] + +let is_empty = function [] -> true | _ -> false + +let rec mem cmp x = function + [] -> false + | v::l -> + let c = cmp x v in + c = 0 || mem cmp x l + +let singleton x = [x] + +let rec remove cmp x = function + [] -> [] + | v::l -> + let c = cmp x v in + if c = 0 then remove cmp x l else + v::(remove cmp x l) + +let compare cmp s1 s2 = + raise Not_implemented + +let equal cmp s1 s2 = + compare cmp s1 s2 = 0 + +let rec iter f = function + [] -> () + | v::l -> iter f l; f v + +let rec fold f s accu = + match s with + [] -> accu + | v::l -> f v (fold f l accu) + +let map cmp f s = fold (fun e s -> add cmp (f e) s) s empty + +let rec for_all p = function + [] -> true + | v::l -> p v && for_all p l + +let rec exists p = function + [] -> false + | v::l -> p v || exists p l + +let rec subset cmp s1 s2 = + for_all (fun e -> mem cmp e s2) s1 + +let filter cmp p s = + let rec filt accu = function + | [] -> accu + | v::r -> + filt (if p v then add cmp v accu else accu) r in + filt [] s + +let partition cmp p s = + let rec part (l, r as accu) = function + | [] -> accu + | h::t -> + part (if p h then (add cmp h l, r) else (l, add cmp h r)) t in + part ([], []) s + +let rec union cmp s1 s2 = + match s1 with + [] -> s2 + | v::l -> v::(union cmp l s2) + +let rec inter cmp s1 s2 = + filter cmp (fun e -> mem cmp e s2) s1 + +let rec cardinal cmp = function + [] -> 0 + | h::t -> (cardinal cmp (remove cmp h t)) + 1 + +let elements s = + s + +let diff cmp s s = + raise Not_implemented + +let min_elt s = + raise Not_implemented + +let max_elt s = + raise Not_implemented + +let split cmp x s = + raise Not_implemented + +(* It's not determenistic in the sense that s1.choose = s2.choose given that s1 equals s2 *) +let choose = function + [] -> raise Not_found + | h::_ -> h + +type 'a set = { cmp : 'a -> 'a -> int; s : 'a rep } + +let empty c = { cmp = c; s = []; } + +let is_empty s = is_empty s.s + +let mem x s = mem s.cmp x s.s + +let add x s = { s with s = add s.cmp x s.s } + +let singleton c x = { cmp = c; s = singleton x } + +let remove x s = { s with s = remove s.cmp x s.s } + +let union s1 s2 = { s1 with s = union s1.cmp s1.s s2.s } + +let inter s1 s2 = { s1 with s = inter s1.cmp s1.s s2.s } + +let diff s1 s2 = { s1 with s = diff s1.cmp s1.s s2.s } + +let compare s1 s2 = compare s1.cmp s1.s s2.s + +let equal s1 s2 = equal s1.cmp s1.s s2.s + +let subset s1 s2 = subset s1.cmp s1.s s2.s + +let iter f s = iter f s.s + +let fold f s a = fold f s.s a + +let map c f s = {cmp = c; s = map c f s.s} + +let for_all p s = for_all p s.s + +let exists p s = exists p s.s + +let filter p s = { s with s = filter s.cmp p s.s } + +let partition p s = + let (r1,r2) = partition s.cmp p s.s in + ({s with s = r1}, {s with s = r2}) + +let cardinal s = cardinal s.cmp s.s + +let elements s = elements s.s + +let min_elt s = min_elt s.s + +let max_elt s = max_elt s.s + +let choose s = choose s.s + +let split x s = + let (l,present,r) = split s.cmp x s.s in + ({ s with s = l }, present, { s with s = r }) + +let from_list c l = + {cmp = c; s = l} + +let comprehension1 cmp f p s = + fold (fun x s -> if p x then add (f x) s else s) s (empty cmp) + +let comprehension2 cmp f p s1 s2 = + fold + (fun x1 s -> + fold + (fun x2 s -> + if p x1 x2 then add (f x1 x2) s else s) + s2 + s) + s1 + (empty cmp) + +let comprehension3 cmp f p s1 s2 s3 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + if p x1 x2 x3 then add (f x1 x2 x3) s else s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension4 cmp f p s1 s2 s3 s4 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + if p x1 x2 x3 x4 then add (f x1 x2 x3 x4) s else s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension5 cmp f p s1 s2 s3 s4 s5 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + fold + (fun x5 s -> + if p x1 x2 x3 x4 x5 then add (f x1 x2 x3 x4 x5) s else s) + s5 + s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension6 cmp f p s1 s2 s3 s4 s5 s6 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + fold + (fun x5 s -> + fold + (fun x6 s -> + if p x1 x2 x3 x4 x5 x6 then add (f x1 x2 x3 x4 x5 x6) s else s) + s6 + s) + s5 + s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let comprehension7 cmp f p s1 s2 s3 s4 s5 s6 s7 = + fold + (fun x1 s -> + fold + (fun x2 s -> + fold + (fun x3 s -> + fold + (fun x4 s -> + fold + (fun x5 s -> + fold + (fun x6 s -> + fold + (fun x7 s -> + if p x1 x2 x3 x4 x5 x6 x7 then add (f x1 x2 x3 x4 x5 x6 x7) s else s) + s7 + s) + s6 + s) + s5 + s) + s4 + s) + s3 + s) + s2 + s) + s1 + (empty cmp) + +let bigunion c xss = + fold union xss (empty c) + +let rec lfp s f = + let s' = f s in + if subset s' s then + s + else + lfp (union s' s) f + +let cross c xs ys = + fold (fun x xys -> fold (fun y xys -> add (x,y) xys) ys xys) xs (empty c) + +let rec lfp s f = + let s' = f s in + if subset s' s then + s + else + lfp (union s' s) f + +let tc c r = + let one_step r = fold (fun (x,y) xs -> fold (fun (y',z) xs -> + if y = y' then add (x,z) xs else xs) r xs) r (empty c) in + lfp r one_step diff --git a/lib/ocaml_rts/linksem/src_lem_library/sum.ml b/lib/ocaml_rts/linksem/src_lem_library/sum.ml new file mode 100644 index 00000000..a9ea35ae --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/sum.ml @@ -0,0 +1,4 @@ +type ('a, 'b) sum = + | Inl of ('a) + | Inr of ('b) + diff --git a/lib/ocaml_rts/linksem/src_lem_library/vector.ml b/lib/ocaml_rts/linksem/src_lem_library/vector.ml new file mode 100644 index 00000000..ff9ddb24 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/vector.ml @@ -0,0 +1,35 @@ +open Nat_num + +type 'a vector = Vector of 'a array + +let vconcat (Vector a) (Vector b) = Vector(Array.append a b) + +let vmap f (Vector a) = Vector(Array.map f a) + +let vfold f base (Vector a) = Array.fold_left f base a + +let vzip (Vector a) (Vector b) = + Vector( Array.of_list (List.combine (Array.to_list a) (Array.to_list b))) + +let vmapacc f (Vector a) base = + let rec mapacc vl b = match vl with + | [] -> ([],b) + | v::vl -> let (v',b') = f v b in + let (vl',b'') = mapacc vl b' in + (v'::vl',b'') in + let vls,b = mapacc (Array.to_list a) base in + Vector(Array.of_list vls),b + +let vmapi f (Vector a) = Vector(Array.mapi f a) + +let extend default size (Vector a) = Vector(Array.append (Array.make size default) a) + +let duplicate (Vector a) = Vector(Array.append a (Array.copy a)) + +let vlength (Vector a) = Array.length a + +let vector_access n (Vector a) = a.(n) + +let vector_slice n1 n2 (Vector a) = Vector(Array.sub a n1 n2) + +let make_vector vs l = Vector(Array.of_list vs)
\ No newline at end of file diff --git a/lib/ocaml_rts/linksem/src_lem_library/vector.mli b/lib/ocaml_rts/linksem/src_lem_library/vector.mli new file mode 100644 index 00000000..fbbe11ab --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/vector.mli @@ -0,0 +1,28 @@ +open Nat_num + +type 'a vector = Vector of 'a array + +val vconcat : 'a vector -> 'a vector -> 'a vector + +val vmap : ('a ->'b) -> 'a vector -> 'b vector + +val vfold : ('b -> 'a -> 'b) -> 'b -> 'a vector -> 'b + +val vzip : 'a vector -> 'b vector -> ('a * 'b) vector + +val vmapacc : ('a -> 'c -> ('b * 'c)) -> 'a vector -> 'c -> ('b vector) * 'c + +val vmapi : (nat -> 'a -> 'b) -> 'a vector -> 'b vector + +val extend : 'a -> nat -> 'a vector -> 'a vector + +val duplicate : 'a vector -> 'a vector + +val vlength : 'a vector -> nat + +val vector_access : nat ->'a vector -> 'a + +val vector_slice : nat -> nat ->'a vector -> 'a vector + +val make_vector : 'a list -> nat -> 'a vector + diff --git a/lib/ocaml_rts/linksem/src_lem_library/xstring.ml b/lib/ocaml_rts/linksem/src_lem_library/xstring.ml new file mode 100644 index 00000000..7a705aeb --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/xstring.ml @@ -0,0 +1,22 @@ +let explode s = + let rec exp i l = + if i < 0 then l else exp (i - 1) (s.[i] :: l) in + exp (String.length s - 1) [];; + +let implode l = + let res = String.create (List.length l) in + let rec imp i = function + | [] -> res + | c :: l -> res.[i] <- c; imp (i + 1) l in + imp 0 l;; + +let string_case s c_empty c_cons = begin + let len = String.length s in + if (len = 0) then c_empty else + c_cons (String.get s 0) (String.sub s 1 (len - 1)) +end;; + +let cons_string c s = begin + let cs = String.make 1 c in + cs ^ s +end;; diff --git a/lib/ocaml_rts/linksem/src_lem_library/xstring.mli b/lib/ocaml_rts/linksem/src_lem_library/xstring.mli new file mode 100644 index 00000000..aa9182d7 --- /dev/null +++ b/lib/ocaml_rts/linksem/src_lem_library/xstring.mli @@ -0,0 +1,4 @@ +val explode : string -> char list +val implode : char list -> string +val cons_string : char -> string -> string +val string_case : string -> 'a -> (char -> string -> 'a) -> 'a diff --git a/lib/ocaml_rts/linksem/string_table.ml b/lib/ocaml_rts/linksem/string_table.ml new file mode 100644 index 00000000..fc74e323 --- /dev/null +++ b/lib/ocaml_rts/linksem/string_table.ml @@ -0,0 +1,123 @@ +(*Generated by Lem from string_table.lem.*) +(** The [string_table] module implements string tables. An ELF file may have + * multiple different string tables used for different purposes. A string + * table is a string coupled with a delimiting character. Strings may be indexed + * at any position, not necessarily on a delimiter boundary. + *) + +open Lem_basic_classes +open Lem_list +open Lem_maybe +open Lem_num +open Lem_string +open Byte_sequence + +open Error +open Missing_pervasives +open Show + +(** [string_table] type, represents a string table with a fixed delimiting + * character and underlying string. + *) +type string_table + = Strings of (char * string) + +(** [mk_string_table base sep] constructs a string table using [base] as the + * base string and [sep] as the delimiting character to use to split [base] + * when trying to access the string stored in the table using the functions below. + *) +(*val mk_string_table : string -> char -> string_table*) +let mk_string_table base sep:string_table= + (Strings (sep, base)) + +(** [string_table_of_byte_sequence seq] constructs a string table, using the NUL + * character as terminator, from a byte sequence. *) +(*val string_table_of_byte_sequence : byte_sequence -> string_table*) +let string_table_of_byte_sequence seq:string_table= (mk_string_table (string_of_byte_sequence seq) null_char) + +(** [empty] is the empty string table with an arbitrary choice of delimiter. + *) +(*val empty : string_table*) +let empty0:string_table= (Strings (null_char, Xstring.implode [null_char])) + +(** [get_delimiating_character tbl] returns the delimiting character associated + * with the string table [tbl], used to split the strings. + *) +(*val get_delimiting_character : string_table -> char*) +let get_delimiting_character tbl:char= + ((match tbl with + | Strings (sep, base) -> sep + )) + +(** [get_base_string tbl] returns the base string of the string table [tbl]. + *) +(*val get_base_string : string_table -> string*) +let get_base_string tbl:string= + ((match tbl with + | Strings (sep, base) -> base + )) + +(** [size tbl] returns the size in bytes of the string table [tbl]. + *) +(*val size : string_table -> natural*) +let size0 tbl:Nat_big_num.num= (Nat_big_num.of_int (String.length (get_base_string tbl))) + +(** [concat xs] concatenates several string tables into one providing they all + * have the same delimiting character. + *) +(*val concat : list string_table -> error string_table*) +let concat1 xs:(string_table)error= + ((match xs with + | [] -> return empty0 + | x::xs -> + let delim = (get_delimiting_character x) in + if (List.for_all (fun x -> get_delimiting_character x = delim) (x::xs)) then + let base = (List.fold_right (^) (Lem_list.map get_base_string (x::xs)) "") in + return (mk_string_table base delim) + else + fail "concat: string tables must have same delimiting characters" + )) + +(** [get_string_at index tbl] returns the string starting at character [index] + * from the start of the base string until the first occurrence of the delimiting + * character. + *) +(*val get_string_at : natural -> string_table -> error string*) +let get_string_at index tbl:(string)error= + ((match Ml_bindings.string_suffix index (get_base_string tbl) with + | None -> Fail "get_string_at: index out of range" + | Some suffix -> + let delim = (get_delimiting_character tbl) in + (match Ml_bindings.string_index_of delim suffix with + | Some idx1 -> + (match Ml_bindings.string_prefix idx1 suffix with + | Some s -> Success s + | None -> Fail "get_string_at: index out of range" + ) + | None -> Success suffix + ) + )) + +(*val find_string : string -> string_table -> maybe natural*) +let find_string s t:(Nat_big_num.num)option= + ((match t with + Strings(delim, base) -> Ml_bindings.find_substring (s ^ Xstring.implode [delim]) base + )) + +(*val insert_string : string -> string_table -> (natural * string_table)*) +let insert_string s t:Nat_big_num.num*string_table= +( + (*let _ = errln ("Inserting string `" ^ s ^ "' into a string table") in*)let (inserted_idx, new_strtab) = ((match find_string s t with + None -> (match t with + Strings(delim, base) -> (Nat_big_num.of_int (String.length base), Strings(delim, (base ^ (s ^ (Xstring.implode [delim]))))) + ) + | Some pos -> (pos, t) + )) + in + (*let _ = errln ("Inserted string at idx " ^ (show inserted_idx) ^ ", see: " ^ (show (find_string s new_strtab))) + in*) + (inserted_idx, new_strtab)) + +let instance_Show_Show_String_table_string_table_dict:(string_table)show_class= ({ + + show_method = (fun tbl->Xstring.implode (Lem_list.map (fun c -> if c = '\000' then '\n' else c) (Xstring.explode (get_base_string tbl))))}) diff --git a/lib/ocaml_rts/linksem/test_image.ml b/lib/ocaml_rts/linksem/test_image.ml new file mode 100644 index 00000000..f4a647e4 --- /dev/null +++ b/lib/ocaml_rts/linksem/test_image.ml @@ -0,0 +1,146 @@ +(*Generated by Lem from test_image.lem.*) +open Lem_basic_classes +open Lem_list +open Lem_map +open Lem_maybe +open Lem_set +open Missing_pervasives +open Lem_num + +open Lem_assert_extra + +open Error +open Elf64_file_of_elf_memory_image + +open Elf_relocation +open Elf_header +open Elf_file +open Elf_interpreted_segment +open Elf_program_header_table +open Elf_symbol_table +open Elf_types_native_uint + +open Abi_amd64_relocation +open Abis + +open Elf_memory_image +open Memory_image + +open Command_line +open Input_list +open Linkable_list +open Byte_sequence +open Link + +open Show + +let ref_rec:symbol_reference= ({ ref_symname = "test" (* symbol name *) + ; ref_syment = +({ elf64_st_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_info = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_other = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_shndx = (Uint32.of_string (Nat_big_num.to_string shn_undef)) + ; elf64_st_value = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_size = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + ; ref_sym_scn =(Nat_big_num.of_int 0) + ; ref_sym_idx =(Nat_big_num.of_int 0) + }) + +(* the record representing the symbol reference and relocation site *) +let ref_and_reloc_rec:symbol_reference_and_reloc_site= + ({ + ref = ref_rec + ; maybe_def_bound_to = None + ; maybe_reloc = (Some( + { + ref_relent = + ({ elf64_ra_offset = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_ra_info = (Uint64.of_string (Nat_big_num.to_string r_x86_64_32)) + ; elf64_ra_addend = (Nat_big_num.to_int64(Nat_big_num.of_int 0)) + }) + ; ref_rel_scn =(Nat_big_num.of_int 0) + ; ref_rel_idx =(Nat_big_num.of_int 0) + ; ref_src_scn =(Nat_big_num.of_int 0) + } + )) + }) + +let def_rec:symbol_definition= + ({ def_symname = "test" + ; def_syment = ({ elf64_st_name = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_info = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_other = (Uint32.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_shndx = (Uint32.of_string (Nat_big_num.to_string shn_undef)) + ; elf64_st_value = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + ; elf64_st_size = (Uint64.of_string (Nat_big_num.to_string (Nat_big_num.of_int 0))) + }) + ; def_sym_scn =(Nat_big_num.of_int 0) + ; def_sym_idx =(Nat_big_num.of_int 1) + ; def_linkable_idx =(Nat_big_num.of_int 0) + }) + +(*val meta : nat -> list ((maybe element_range) * elf_range_tag)*) +let meta offset:((string*(Nat_big_num.num*Nat_big_num.num))option*(any_abi_feature)range_tag)list= ([ + (Some (".text", (Nat_big_num.of_int 1,Nat_big_num.of_int 4)), SymbolRef(ref_and_reloc_rec)) + ; (Some (".data", (Nat_big_num.of_int offset,Nat_big_num.of_int 8)), SymbolDef(def_rec)) +]) + + +let img0 (addr : int) (data_size : int) instr_bytes:(any_abi_feature)annotated_memory_image= + (let initial_img = + ({ + elements = (Lem_map.fromList + (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [(".text", { + startpos = (Some(Nat_big_num.of_int 4194304)) + ; length1 = (Some(Nat_big_num.of_int 16)) + ; contents = (Lem_list.map (fun x -> Some x) instr_bytes) + }); + (".data", { + startpos = (Some(Nat_big_num.of_int 4194320)) + ; length1 = (Some (Nat_big_num.of_int data_size)) + ; contents = (Lem_list.map (fun x -> Some x) (Lem_list.replicate data_size (Char.chr (Nat_big_num.to_int (Nat_big_num.of_int 42))))) + }) + ]) + ; by_range = (Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) (meta ( Nat_num.nat_monus addr( 4194316)))) + ; by_tag = (by_tag_from_by_range + (instance_Basic_classes_SetType_Maybe_maybe_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_var_dict + (instance_Basic_classes_SetType_tup2_dict + instance_Basic_classes_SetType_Num_natural_dict + instance_Basic_classes_SetType_Num_natural_dict))) instance_Basic_classes_SetType_var_dict ((Pset.from_list (pairCompare (maybeCompare (pairCompare compare (pairCompare Nat_big_num.compare Nat_big_num.compare))) compare) (meta ( Nat_num.nat_monus addr( 4194316)))))) + }) + in + let ref_input_item + = ("test.o", Reloc(Sequence([])), ((File(Filename("blah"), Command_line.null_input_file_options)), [InCommandLine(Nat_big_num.of_int 0)])) + in + let ref_linkable_item = (RelocELF(initial_img), ref_input_item, Input_list.null_input_options) + in + let bindings_by_name = (Lem_map.fromList + (instance_Map_MapKeyType_var_dict instance_Basic_classes_SetType_var_dict) [ + ("test", [(Nat_big_num.of_int 0, ((Nat_big_num.of_int 0, ref_rec, ref_linkable_item), Some(Nat_big_num.of_int 0, def_rec, ref_linkable_item)))]) + ]) + in + relocate_output_image Abis.sysv_amd64_std_abi bindings_by_name initial_img) + +(* XXX: DPM, no longer needed? +let compute_relocated_bytes () = + let res = + let relocatable_program = + List.map byte_of_natural [72; 199; 4; 37; 0; 0; 0; 0; 5; 0; 0; 0; 72; 139; 4; 37; 0; 0; 0; 0] + in + let ef = elf64_file_of_elf_memory_image sysv_amd64_std_abi id "at_least_some_relocations_relocate.out" (img relocatable_program) in + get_elf64_executable_image ef >>= fun (segs_and_provenance, entry, mach) -> + if mach = elf_ma_x86_64 then + let filtered = List.filter (fun x -> x.elf64_segment_type = elf_pt_load) (List.map (fun (x, y) -> x) segs_and_provenance) in + let filtered = List.map Byte_sequence.byte_list_of_byte_sequence (List.map (fun x -> x.elf64_segment_body) filtered) in + let _ = List.map (fun x -> outln (show x)) filtered in + return () + else + failwith "wrong machine type returned" + in match res with + | Success s -> outln "success" + | Fail e -> errln e + end +*) diff --git a/lib/ocaml_rts/linksem/uint16_wrapper.ml b/lib/ocaml_rts/linksem/uint16_wrapper.ml new file mode 100644 index 00000000..0b26a5c3 --- /dev/null +++ b/lib/ocaml_rts/linksem/uint16_wrapper.ml @@ -0,0 +1,48 @@ +type uint16 = Big_int.big_int + +(* 2^16 - 1 *) +let max_int = Big_int.big_int_of_string "65535" +;; + +let of_bigint (i : Big_int.big_int) = + Big_int.mod_big_int i max_int +;; + +let to_bigint (u : uint16) = u +;; + +let shift_left i s = + Big_int.mod_big_int (Big_int.shift_left_big_int i s) max_int +;; + +let shift_right i s = + Big_int.mod_big_int (Big_int.shift_right_big_int i s) max_int +;; + +let logand l r = + Big_int.mod_big_int (Big_int.and_big_int l r) max_int +;; + +let logor l r = + Big_int.mod_big_int (Big_int.or_big_int l r) max_int +;; + +let of_dual c1 c2 = + let b1 = Big_int.big_int_of_int (Char.code c1) in + let b2 = shift_left (Big_int.big_int_of_int (Char.code c2)) 8 in + Big_int.add_big_int b1 b2 +;; + +let to_bytes u = + let b0 = Char.chr (Big_int.int_of_big_int (logand u (Big_int.big_int_of_string "255"))) in (* 0xFF *) + let b1 = Char.chr (Big_int.int_of_big_int (shift_right (logand u (Big_int.big_int_of_string "65280")) 8)) in (* 0xFF00 *) + b1, b0 +;; + +let to_string (u : uint16) = + Big_int.string_of_big_int u +;; + +let equal u1 u2 = + Big_int.eq_big_int u1 u2 +;;
\ No newline at end of file diff --git a/lib/ocaml_rts/linksem/uint32_wrapper.ml b/lib/ocaml_rts/linksem/uint32_wrapper.ml new file mode 100644 index 00000000..50c295d4 --- /dev/null +++ b/lib/ocaml_rts/linksem/uint32_wrapper.ml @@ -0,0 +1,97 @@ +type uint32 = Nat_big_num.num + +(* 2^32 - 1 *) +let max_int = + Nat_big_num.of_string "4294967295" +;; + +let add l r = + Nat_big_num.modulus (Nat_big_num.add l r) max_int +;; + +let of_char (c : char) : uint32 = + Nat_big_num.of_int (Char.code c) +;; + +let of_int (i : int) = + Nat_big_num.of_int i +;; + +let of_bigint (i : Nat_big_num.num) : uint32 = + Nat_big_num.modulus i max_int +;; + +let of_int32 (i : Int32.t) = + Nat_big_num.of_int32 i +;; + +let to_bigint (u : uint32) : Nat_big_num.num = u +;; + +let shift_left i s = + Nat_big_num.modulus (Nat_big_num.shift_left i s) max_int +;; + +let shift_right i s = + Nat_big_num.modulus (Nat_big_num.shift_right i s) max_int +;; + +let logand l r = + Nat_big_num.modulus (Nat_big_num.bitwise_and l r) max_int +;; + +let logor l r = + Nat_big_num.modulus (Nat_big_num.bitwise_or l r) max_int +;; + +let to_string l = + Nat_big_num.to_string l +;; + +let to_char u = + Char.chr (Nat_big_num.to_int u) +;; + +let equal l r = + Nat_big_num.equal l r +;; + +let of_quad c1 c2 c3 c4 = + let b1 = Nat_big_num.of_int (Char.code c1) in + let b2 = shift_left (Nat_big_num.of_int (Char.code c2)) 8 in + let b3 = shift_left (Nat_big_num.of_int (Char.code c3)) 16 in + let b4 = shift_left (Nat_big_num.of_int (Char.code c4)) 24 in + Nat_big_num.add b1 (Nat_big_num.add b2 (Nat_big_num.add b3 b4)) +;; + +let of_quad_native c1 c2 c3 c4 = + let b1 = Uint32.of_int (Char.code c1) in + let b2 = Uint32.shift_left (Uint32.of_int (Char.code c2)) 8 in + let b3 = Uint32.shift_left (Uint32.of_int (Char.code c3)) 16 in + let b4 = Uint32.shift_left (Uint32.of_int (Char.code c4)) 24 in + Uint32.add b1 (Uint32.add b2 (Uint32.add b3 b4)) +;; + +let of_dual_native c1 c2 = of_quad_native c1 c2 '\000' '\000' +;; + +let to_bytes u : char * char * char * char = + let b0 = Char.chr (Nat_big_num.to_int (logand u (Nat_big_num.of_string "255"))) in + let b1 = Char.chr (Nat_big_num.to_int (shift_right (logand u (Nat_big_num.of_string "65280")) 8)) in + let b2 = Char.chr (Nat_big_num.to_int (shift_right (logand u (Nat_big_num.of_string "16711680")) 16)) in + let b3 = Char.chr (Nat_big_num.to_int (shift_right (logand u (Nat_big_num.of_string "4278190080")) 24)) in + b0, b1, b2, b3 +;; + +let to_bytes_native u : char * char * char * char = + let b0 = Char.chr (Uint32.to_int (Uint32.logand u (Uint32.of_string "255"))) in + let b1 = Char.chr (Uint32.to_int (Uint32.shift_right (Uint32.logand u (Uint32.of_string "65280")) 8)) in + let b2 = Char.chr (Uint32.to_int (Uint32.shift_right (Uint32.logand u (Uint32.of_string "16711680")) 16)) in + let b3 = Char.chr (Uint32.to_int (Uint32.shift_right (Uint32.logand u (Uint32.of_string "4278190080")) 24)) in + b0, b1, b2, b3 +;; + +let to_dual_bytes_native u : char * char = + let (b3, b2, b1, b0) = to_bytes_native u in + b3, b2 +;; diff --git a/lib/ocaml_rts/linksem/uint64_wrapper.ml b/lib/ocaml_rts/linksem/uint64_wrapper.ml new file mode 100644 index 00000000..344ce4be --- /dev/null +++ b/lib/ocaml_rts/linksem/uint64_wrapper.ml @@ -0,0 +1,119 @@ +type uint64 + = Nat_big_num.num + +(* 2^64 - 1 *) +let max_int = + let x = Nat_big_num.of_string "4294967296" in + let y = Nat_big_num.mul x (Nat_big_num.of_int 2) in + Nat_big_num.sub y (Nat_big_num.of_int 1) +;; + +let add l r = + Nat_big_num.modulus (Nat_big_num.add l r) max_int +;; + +let minus l r = + Nat_big_num.modulus (Nat_big_num.sub l r) max_int +;; + +let of_int i = + Nat_big_num.of_int i +;; + +let of_int64 (i : Int64.t) = + Nat_big_num.of_int64 i +;; + +let shift_left i s = + Nat_big_num.modulus (Nat_big_num.shift_left i s) max_int +;; + +let shift_right i s = + Nat_big_num.modulus (Nat_big_num.shift_right i s) max_int +;; + +let logand l r = + Nat_big_num.modulus (Nat_big_num.bitwise_and l r) max_int +;; + +let logor l r = + Nat_big_num.modulus (Nat_big_num.bitwise_or l r) max_int +;; + +let to_string l = + Nat_big_num.to_string l +;; + +let equal l r = + Nat_big_num.equal l r +;; + +let of_oct c1 c2 c3 c4 c5 c6 c7 c8 = + let b1 = Nat_big_num.of_int (Char.code c1) in + let b2 = shift_left (Nat_big_num.of_int (Char.code c2)) 8 in + let b3 = shift_left (Nat_big_num.of_int (Char.code c3)) 16 in + let b4 = shift_left (Nat_big_num.of_int (Char.code c4)) 24 in + let b5 = shift_left (Nat_big_num.of_int (Char.code c5)) 32 in + let b6 = shift_left (Nat_big_num.of_int (Char.code c6)) 40 in + let b7 = shift_left (Nat_big_num.of_int (Char.code c7)) 48 in + let b8 = shift_left (Nat_big_num.of_int (Char.code c8)) 56 in + Nat_big_num.add b1 (Nat_big_num.add b2 + (Nat_big_num.add b3 (Nat_big_num.add b4 + (Nat_big_num.add b5 (Nat_big_num.add b6 + (Nat_big_num.add b7 b8)))))) +;; + +let of_oct_native c1 c2 c3 c4 c5 c6 c7 c8 = + let b1 = Uint64.of_int (Char.code c1) in + let b2 = Uint64.shift_left (Uint64.of_int (Char.code c2)) 8 in + let b3 = Uint64.shift_left (Uint64.of_int (Char.code c3)) 16 in + let b4 = Uint64.shift_left (Uint64.of_int (Char.code c4)) 24 in + let b5 = Uint64.shift_left (Uint64.of_int (Char.code c5)) 32 in + let b6 = Uint64.shift_left (Uint64.of_int (Char.code c6)) 40 in + let b7 = Uint64.shift_left (Uint64.of_int (Char.code c7)) 48 in + let b8 = Uint64.shift_left (Uint64.of_int (Char.code c8)) 56 in + Uint64.add b1 (Uint64.add b2 + (Uint64.add b3 (Uint64.add b4 + (Uint64.add b5 (Uint64.add b6 + (Uint64.add b7 b8)))))) +;; + +let to_bigint (u : uint64) : Nat_big_num.num = + u +;; + +let of_bigint (u : Nat_big_num.num) : uint64 = + Nat_big_num.modulus u max_int +;; + +let to_bytes u : char * char * char * char * char * char * char * char = + let u1 = Nat_big_num.mul (Nat_big_num.of_string "4278190080") (Nat_big_num.of_string "255") in (* 0xFF00000000 *) + let u2 = Nat_big_num.mul (Nat_big_num.of_string "4278190080") (Nat_big_num.of_string "65280") in (* 0xFF0000000000 *) + let u3 = Nat_big_num.mul (Nat_big_num.of_string "4278190080") (Nat_big_num.of_string "16711680") in (* 0xFF000000000000 *) + let u4 = Nat_big_num.mul (Nat_big_num.of_string "4278190080") (Nat_big_num.of_string "4278190080") in (* 0xFF00000000000000 *) + let b0 = Char.chr (Nat_big_num.to_int (logand u (Nat_big_num.of_string "255"))) in (* 0xFF *) + let b1 = Char.chr (Nat_big_num.to_int (shift_right (logand u (Nat_big_num.of_string "65280")) 8)) in (* 0xFF00 *) + let b2 = Char.chr (Nat_big_num.to_int (shift_right (logand u (Nat_big_num.of_string "16711680")) 16)) in (* 0xFF0000 *) + let b3 = Char.chr (Nat_big_num.to_int (shift_right (logand u (Nat_big_num.of_string "4278190080")) 24)) in (* 0xFF000000 *) + let b4 = Char.chr (Nat_big_num.to_int (shift_right (logand u u1) 32)) in (* 0xFF00000000 *) + let b5 = Char.chr (Nat_big_num.to_int (shift_right (logand u u2) 40)) in (* 0xFF0000000000 *) + let b6 = Char.chr (Nat_big_num.to_int (shift_right (logand u u3) 48)) in (* 0xFF000000000000 *) + let b7 = Char.chr (Nat_big_num.to_int (shift_right (logand u u4) 56)) in (* 0xFF00000000000000 *) + b0,b1,b2,b3,b4,b5,b6,b7 +;; + +let to_bytes_native u : char * char * char * char * char * char * char * char = + let u1 = Uint64.mul (Uint64.of_string "4278190080") (Uint64.of_string "255") in (* 0xFF00000000 *) + let u2 = Uint64.mul (Uint64.of_string "4278190080") (Uint64.of_string "65280") in (* 0xFF0000000000 *) + let u3 = Uint64.mul (Uint64.of_string "4278190080") (Uint64.of_string "16711680") in (* 0xFF000000000000 *) + let u4 = Uint64.mul (Uint64.of_string "4278190080") (Uint64.of_string "4278190080") in (* 0xFF00000000000000 *) + let b0 = Char.chr (Uint64.to_int (Uint64.logand u (Uint64.of_string "255"))) in (* 0xFF *) + let b1 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u (Uint64.of_string "65280")) 8)) in (* 0xFF00 *) + let b2 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u (Uint64.of_string "16711680")) 16)) in (* 0xFF0000 *) + let b3 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u (Uint64.of_string "4278190080")) 24)) in (* 0xFF000000 *) + let b4 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u u1) 32)) in (* 0xFF00000000 *) + let b5 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u u2) 40)) in (* 0xFF0000000000 *) + let b6 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u u3) 48)) in (* 0xFF000000000000 *) + let b7 = Char.chr (Uint64.to_int (Uint64.shift_right (Uint64.logand u u4) 56)) in (* 0xFF00000000000000 *) + b0,b1,b2,b3,b4,b5,b6,b7 +;; diff --git a/lib/ocaml_rts/linksem/utility.ml b/lib/ocaml_rts/linksem/utility.ml new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/lib/ocaml_rts/linksem/utility.ml @@ -0,0 +1 @@ + diff --git a/lib/ocaml_rts/sail_lib.ml b/lib/ocaml_rts/sail_lib.ml new file mode 100644 index 00000000..0602a3d0 --- /dev/null +++ b/lib/ocaml_rts/sail_lib.ml @@ -0,0 +1,317 @@ +open Big_int + +type 'a return = { return : 'b . 'a -> 'b } + +let with_return (type t) (f : _ -> t) = + let module M = + struct exception Return of t end + in + let return = { return = (fun x -> raise (M.Return x)); } in + try f return with M.Return x -> x + +type bit = B0 | B1 + +let and_bit = function + | B1, B1 -> B1 + | _, _ -> B0 + +let or_bit = function + | B0, B0 -> B0 + | _, _ -> B1 + +let and_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> and_bit (x, y)) xs ys + +let and_bool (b1, b2) = b1 && b2 + +let or_vec (xs, ys) = + assert (List.length xs = List.length ys); + List.map2 (fun x y -> or_bit (x, y)) xs ys + +let or_bool (b1, b2) = b1 || b2 + +let undefined_bit () = + if Random.bool () then B0 else B1 + +let undefined_bool () = Random.bool () + +let rec undefined_vector (start_index, len, item) = + if eq_big_int len zero_big_int + then [] + else item :: undefined_vector (start_index, sub_big_int len unit_big_int, item) + +let undefined_string () = "" + +let undefined_unit () = () + +let undefined_int () = + big_int_of_int (Random.int 0xFFFF) + +let internal_pick list = + List.nth list (Random.int (List.length list)) + +let eq_int (n, m) = eq_big_int n m + +let rec drop n xs = + match n, xs with + | 0, xs -> xs + | n, [] -> [] + | n, (x :: xs) -> drop (n -1) xs + +let rec take n xs = + match n, xs with + | 0, xs -> [] + | n, (x :: xs) -> x :: take (n - 1) xs + | n, [] -> [] + +let subrange (list, n, m) = + let n = int_of_big_int n in + let m = int_of_big_int m in + List.rev (take (n - (m - 1)) (drop m (List.rev list))) + +let eq_list (xs, ys) = List.for_all2 (fun x y -> x == y) xs ys + +let access (xs, n) = List.nth (List.rev xs) (int_of_big_int n) + +let append (xs, ys) = xs @ ys + +let update (xs, n, x) = + let n = (List.length xs - int_of_big_int n) - 1 in + take n xs @ [x] @ drop (n + 1) xs + +let update_subrange (xs, n, m, ys) = + let rec aux xs o = function + | [] -> xs + | (y :: ys) -> aux (update (xs, o, y)) (sub_big_int o unit_big_int) ys + in + aux xs n ys + + +let length xs = big_int_of_int (List.length xs) + +let big_int_of_bit = function + | B0 -> zero_big_int + | B1 -> unit_big_int + +let uint xs = + let uint_bit x (n, pos) = + add_big_int n (mult_big_int (power_int_positive_int 2 pos) (big_int_of_bit x)), pos + 1 + in + fst (List.fold_right uint_bit xs (zero_big_int, 0)) + +let sint = function + | [] -> zero_big_int + | [msb] -> minus_big_int (big_int_of_bit msb) + | msb :: xs -> + let msb_pos = List.length xs in + let complement = + minus_big_int (mult_big_int (power_int_positive_int 2 msb_pos) (big_int_of_bit msb)) + in + add_big_int complement (uint xs) + +let add (x, y) = add_big_int x y +let sub (x, y) = sub_big_int x y +let mult (x, y) = mult_big_int x y +let quotient (x, y) = fst (quomod_big_int x y) +let modulus (x, y) = snd (quomod_big_int x y) + +let add_bit_with_carry (x, y, carry) = + match x, y, carry with + | B0, B0, B0 -> B0, B0 + | B0, B1, B0 -> B1, B0 + | B1, B0, B0 -> B1, B0 + | B1, B1, B0 -> B0, B1 + | B0, B0, B1 -> B1, B0 + | B0, B1, B1 -> B0, B1 + | B1, B0, B1 -> B0, B1 + | B1, B1, B1 -> B1, B1 + +let sub_bit_with_carry (x, y, carry) = + match x, y, carry with + | B0, B0, B0 -> B0, B0 + | B0, B1, B0 -> B0, B1 + | B1, B0, B0 -> B1, B0 + | B1, B1, B0 -> B0, B0 + | B0, B0, B1 -> B1, B0 + | B0, B1, B1 -> B0, B0 + | B1, B0, B1 -> B1, B1 + | B1, B1, B1 -> B1, B0 + +let not_bit = function + | B0 -> B1 + | B1 -> B0 + +let not_vec xs = List.map not_bit xs + +let add_vec_carry (xs, ys) = + assert (List.length xs = List.length ys); + let (carry, result) = + List.fold_right2 (fun x y (c, result) -> let (z, c) = add_bit_with_carry (x, y, c) in (c, z :: result)) xs ys (B0, []) + in + carry, result + +let add_vec (xs, ys) = snd (add_vec_carry (xs, ys)) + +let rec replicate_bits (bits, n) = + if le_big_int n zero_big_int + then [] + else bits @ replicate_bits (bits, sub_big_int n unit_big_int) + +let identity x = x + +let rec bits_of_big_int bit n = + if not (eq_big_int bit zero_big_int) + then + begin + if gt_big_int (div_big_int n bit) zero_big_int + then B1 :: bits_of_big_int (div_big_int bit (big_int_of_int 2)) (sub_big_int n bit) + else B0 :: bits_of_big_int (div_big_int bit (big_int_of_int 2)) n + end + else [] + +let add_vec_int (v, n) = + let n_bits = bits_of_big_int (power_int_positive_int 2 (List.length v - 1)) n in + add_vec(v, n_bits) + +let sub_vec (xs, ys) = add_vec (xs, add_vec_int (not_vec ys, unit_big_int)) + +let sub_vec_int (v, n) = + let n_bits = bits_of_big_int (power_int_positive_int 2 (List.length v - 1)) n in + sub_vec(v, n_bits) + +let get_slice_int (n, m, o) = + let bits = bits_of_big_int (power_int_positive_big_int 2 (add_big_int n o)) m in + let slice = List.rev (take (int_of_big_int n) (drop (int_of_big_int o) (List.rev bits))) in + slice + +let hex_char = function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + +let list_of_string s = + let rec aux i acc = + if i < 0 then acc + else aux (i-1) (s.[i] :: acc) + in aux (String.length s - 1) [] + +let bits_of_string str = + List.concat (List.map hex_char (list_of_string str)) + +let concat_str (str1, str2) = str1 ^ str2 + +let rec break n = function + | [] -> [] + | (_ :: _ as xs) -> [take n xs] @ break n (drop n xs) + +let string_of_bit = function + | B0 -> "0" + | B1 -> "1" + +let string_of_hex = function + | [B0; B0; B0; B0] -> "0" + | [B0; B0; B0; B1] -> "1" + | [B0; B0; B1; B0] -> "2" + | [B0; B0; B1; B1] -> "3" + | [B0; B1; B0; B0] -> "4" + | [B0; B1; B0; B1] -> "5" + | [B0; B1; B1; B0] -> "6" + | [B0; B1; B1; B1] -> "7" + | [B1; B0; B0; B0] -> "8" + | [B1; B0; B0; B1] -> "9" + | [B1; B0; B1; B0] -> "A" + | [B1; B0; B1; B1] -> "B" + | [B1; B1; B0; B0] -> "C" + | [B1; B1; B0; B1] -> "D" + | [B1; B1; B1; B0] -> "E" + | [B1; B1; B1; B1] -> "F" + +let string_of_bits bits = + if List.length bits mod 4 == 0 + then "0x" ^ String.concat "" (List.map string_of_hex (break 4 bits)) + else "0b" ^ String.concat "" (List.map string_of_bit bits) + +let hex_slice (str, n, m) = + let bits = List.concat (List.map hex_char (list_of_string (String.sub str 2 (String.length str - 2)))) in + let padding = replicate_bits([B0], n) in + let bits = padding @ bits in + let slice = List.rev (take (int_of_big_int n) (drop (int_of_big_int m) (List.rev bits))) in + slice + +let putchar n = + print_char (char_of_int (int_of_big_int n)); + flush stdout + +let rec bits_of_int bit n = + if bit <> 0 + then + begin + if n / bit > 0 + then B1 :: bits_of_int (bit / 2) (n - bit) + else B0 :: bits_of_int (bit / 2) n + end + else [] + +let byte_of_int n = bits_of_int 128 n + +module BigIntHash = + struct + type t = big_int + let equal i j = eq_big_int i j + let hash i = Hashtbl.hash i + end + +module RAM = Hashtbl.Make(BigIntHash) + +let ram : int RAM.t = RAM.create 256 + +let write_ram' (addr_size, data_size, hex_ram, addr, data) = + let data = List.map (fun byte -> int_of_big_int (uint byte)) (break 8 data) in + let rec write_byte i byte = + prerr_endline (Printf.sprintf "W: %s -> 0x%02X" (string_of_big_int (add_big_int addr (big_int_of_int i))) byte); + RAM.add ram (add_big_int addr (big_int_of_int i)) byte + in + List.iteri write_byte (List.rev data) + +let write_ram (addr_size, data_size, hex_ram, addr, data) = + write_ram' (addr_size, data_size, hex_ram, uint addr, data) + +let wram addr byte = + RAM.add ram addr byte + +let read_ram (addr_size, data_size, hex_ram, addr) = + let addr = uint addr in + let rec read_byte i = + if eq_big_int i zero_big_int + then [] + else + begin + let loc = sub_big_int (add_big_int addr i) unit_big_int in + let byte = try RAM.find ram loc with Not_found -> 0 in + prerr_endline (Printf.sprintf "R: %s <- 0x%02X" (string_of_big_int loc) byte); + byte_of_int byte @ read_byte (sub_big_int i unit_big_int) + end + in + read_byte data_size + +(* FIXME: Casts can't be externed *) +let zcast_unit_vec x = [x] + +let shl_int (n, m) = shift_left_big_int n (int_of_big_int m) +let shr_int (n, m) = shift_right_big_int n (int_of_big_int m) + +let debug (str1, n, str2, v) = prerr_endline (str1 ^ string_of_big_int n ^ str2 ^ string_of_bits v) diff --git a/lib/ocaml_rts/spec.ml b/lib/ocaml_rts/spec.ml new file mode 100644 index 00000000..3e551774 --- /dev/null +++ b/lib/ocaml_rts/spec.ml @@ -0,0 +1,4 @@ + +let zmain () = () + +let initialize_registers () = () |