From 678d260f5b236404d39906696caf34c8ad74c4e0 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 1 Sep 2017 15:11:56 +0100 Subject: More test cases for ocaml backend --- test/ocaml/lsl/expect | 4 +++ test/ocaml/lsl/lsl.sail | 31 +++++++++++++++++++ test/ocaml/pattern1/expect | 1 + test/ocaml/pattern1/pattern.sail | 11 +++++++ test/ocaml/prelude.sail | 4 +++ test/ocaml/run_tests.sh | 5 ++- test/run_tests.sh | 7 +++++ test/typecheck/run_tests.sh | 66 ++++++++++++++++++++-------------------- 8 files changed, 95 insertions(+), 34 deletions(-) create mode 100644 test/ocaml/lsl/expect create mode 100644 test/ocaml/lsl/lsl.sail create mode 100644 test/ocaml/pattern1/expect create mode 100644 test/ocaml/pattern1/pattern.sail create mode 100755 test/run_tests.sh diff --git a/test/ocaml/lsl/expect b/test/ocaml/lsl/expect new file mode 100644 index 00000000..c72d1eb8 --- /dev/null +++ b/test/ocaml/lsl/expect @@ -0,0 +1,4 @@ +pass +pass +pass +pass diff --git a/test/ocaml/lsl/lsl.sail b/test/ocaml/lsl/lsl.sail new file mode 100644 index 00000000..fdb9dc43 --- /dev/null +++ b/test/ocaml/lsl/lsl.sail @@ -0,0 +1,31 @@ + +val forall Num 'n, 'n >= 0. [:'n:] -> bit['n] effect pure zeros + +function zeros n = replicate_bits(0b0, sizeof 'n) + +val forall Num 'n, Num 'shift, 'n >= 0. (bit['n], [:'shift:]) -> (bit['n], bit) effect pure lslc + +function lslc (vec, shift) = { + assert(constraint('shift >= 1), "shift must be positive"); + (bit['shift + 'n]) extended := vec : zeros(shift); + (bit['n]) result := extended[sizeof 'n - 1 .. 0]; + (bit) c := extended[sizeof 'n]; + return (result, c) +} + +val forall Num 'n, Num 'shift, 'n >= 0. (bit['n], [:'shift:]) -> bit['n] effect pure lsl + +function lsl (vec, shift) = + if shift == 0 + then vec + else let (result, _) = lslc(vec, shift) in result + +val unit -> unit effect pure main + +function main () = { + print(if lsl(0b0110,1) == 0b1100 then "pass" else "fail"); + print(if lsl(0b1111,2) == 0b1100 then "pass" else "fail"); + print(if lsl(0x0F,4) == 0xF0 then "pass" else "fail"); + let (result, c) = lslc(0xF000,2) in + print(if result == 0xC000 & c == bitone then "pass" else "fail") +} diff --git a/test/ocaml/pattern1/expect b/test/ocaml/pattern1/expect new file mode 100644 index 00000000..2ae28399 --- /dev/null +++ b/test/ocaml/pattern1/expect @@ -0,0 +1 @@ +pass diff --git a/test/ocaml/pattern1/pattern.sail b/test/ocaml/pattern1/pattern.sail new file mode 100644 index 00000000..a2314adc --- /dev/null +++ b/test/ocaml/pattern1/pattern.sail @@ -0,0 +1,11 @@ + +val unit -> unit effect pure main + +function main () = { + vec := 0x4F; + switch vec { + case (0b01 : (bit[2]) x : 0xF) -> + if (x == 0b00) then print("pass") else print("x is incorrect") + case _ -> print("pattern fail") + } +} diff --git a/test/ocaml/prelude.sail b/test/ocaml/prelude.sail index 2526d109..cbe1927d 100644 --- a/test/ocaml/prelude.sail +++ b/test/ocaml/prelude.sail @@ -15,6 +15,10 @@ val extern forall Type 'a, Num 'n. vector<'n - 1, 'n, dec, 'a> -> [:'n:] effect val extern forall Num 'n, Num 'm, Num 'o (* , 'm >= 'o, 'o >= 0, 'n >= 'm + 1 *). (bit['n], [:'m:], [:'o:]) -> bit['m - ('o - 1)] effect pure vector_subrange = "subrange" +(* FIXME: rewriter shouldn't assume this exists *) +val extern forall Num 'n, Num 'm, Num 'o (* , 'm >= 'o, 'o >= 0, 'n >= 'm + 1 *). + (bit['n], [:'m:], [:'o:]) -> bit['m - ('o - 1)] effect pure bitvector_subrange_dec = "subrange" + val extern forall Num 'n, Type 'a. (vector<'n - 1, 'n, dec, 'a>, int) -> 'a effect pure vector_access = "access" val extern forall Num 'n, Type 'a. (vector<'n - 1, 'n, dec, 'a>, int, 'a) -> vector<'n - 1, 'n, dec, 'a> effect pure vector_update = "update" diff --git a/test/ocaml/run_tests.sh b/test/ocaml/run_tests.sh index d01535b6..4454aa48 100755 --- a/test/ocaml/run_tests.sh +++ b/test/ocaml/run_tests.sh @@ -2,6 +2,7 @@ set -e DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +cd $DIR SAILDIR="$DIR/../.." RED='\033[0;31m' @@ -49,7 +50,7 @@ printf "\n" >> $DIR/tests.xml for i in `ls -d */`; do cd $DIR/$i; - if $SAILDIR/sail -o out -ocaml ../prelude.sail `ls *.sail`; + if $SAILDIR/sail -o out -ocaml ../prelude.sail `ls *.sail` 1> /dev/null; then ./out > result; if diff expect result; @@ -66,4 +67,6 @@ do fi done +finish_suite "Ocaml testing" + printf "\n" >> $DIR/tests.xml diff --git a/test/run_tests.sh b/test/run_tests.sh new file mode 100755 index 00000000..380ebb18 --- /dev/null +++ b/test/run_tests.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash +set -e + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" + +$DIR/typecheck/run_tests.sh +$DIR/ocaml/run_tests.sh diff --git a/test/typecheck/run_tests.sh b/test/typecheck/run_tests.sh index e83cc20b..41a19cb4 100755 --- a/test/typecheck/run_tests.sh +++ b/test/typecheck/run_tests.sh @@ -97,43 +97,43 @@ done finish_suite "Expecting fail" -function test_lem { - for i in `ls $DIR/pass/`; - do - # MIPS requires an additional library, Mips_extras_embed. - # It might be useful to allow adding options for specific test cases. - # For now, include the library for all test cases, which doesn't seem to hurt. - if $SAILDIR/sail -lem -lem_lib Mips_extras_embed $DIR/$1/$i 2> /dev/null - then - green "generated lem for $1/$i" "pass" - - cp $MIPS/mips_extras_embed_sequential.lem $DIR/lem/ - mv $SAILDIR/${i%%.*}_embed_types.lem $DIR/lem/ - mv $SAILDIR/${i%%.*}_embed_types_sequential.lem $DIR/lem/ - mv $SAILDIR/${i%%.*}_embed.lem $DIR/lem/ - mv $SAILDIR/${i%%.*}_embed_sequential.lem $DIR/lem/ - # Test sequential embedding for now - # TODO: Add tests for the free monad - if lem -lib $SAILDIR/src/lem_interp -lib $SAILDIR/src/gen_lib/ $DIR/lem/mips_extras_embed_sequential.lem $DIR/lem/${i%%.*}_embed_types_sequential.lem $DIR/lem/${i%%.*}_embed_sequential.lem 2> /dev/null - then - green "typechecking lem for $1/$i" "pass" - else - red "typechecking lem for $1/$i" "fail" - fi - else - red "generated lem for $1/$i" "fail" - red "typechecking lem for $1/$i" "fail" - fi - done -} +# function test_lem { +# for i in `ls $DIR/pass/`; +# do +# # MIPS requires an additional library, Mips_extras_embed. +# # It might be useful to allow adding options for specific test cases. +# # For now, include the library for all test cases, which doesn't seem to hurt. +# if $SAILDIR/sail -lem -lem_lib Mips_extras_embed $DIR/$1/$i 2> /dev/null +# then +# green "generated lem for $1/$i" "pass" + +# cp $MIPS/mips_extras_embed_sequential.lem $DIR/lem/ +# mv $SAILDIR/${i%%.*}_embed_types.lem $DIR/lem/ +# mv $SAILDIR/${i%%.*}_embed_types_sequential.lem $DIR/lem/ +# mv $SAILDIR/${i%%.*}_embed.lem $DIR/lem/ +# mv $SAILDIR/${i%%.*}_embed_sequential.lem $DIR/lem/ +# # Test sequential embedding for now +# # TODO: Add tests for the free monad +# if lem -lib $SAILDIR/src/lem_interp -lib $SAILDIR/src/gen_lib/ $DIR/lem/mips_extras_embed_sequential.lem $DIR/lem/${i%%.*}_embed_types_sequential.lem $DIR/lem/${i%%.*}_embed_sequential.lem 2> /dev/null +# then +# green "typechecking lem for $1/$i" "pass" +# else +# red "typechecking lem for $1/$i" "fail" +# fi +# else +# red "generated lem for $1/$i" "fail" +# red "typechecking lem for $1/$i" "fail" +# fi +# done +# } -test_lem pass +# test_lem pass -finish_suite "Lem generation 1" +# finish_suite "Lem generation 1" -test_lem rtpass +# test_lem rtpass -finish_suite "Lem generation 2" +# finish_suite "Lem generation 2" # function test_ocaml { # for i in `ls $DIR/pass/`; -- cgit v1.2.3 From 8124c487b576661dfa7a0833415d07d0978bc43e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 1 Sep 2017 15:33:24 +0100 Subject: Testing typedef generation for ocaml --- src/rewriter.ml | 2 +- test/ocaml/types/expect | 5 +++++ test/ocaml/types/types.sail | 37 +++++++++++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+), 1 deletion(-) create mode 100644 test/ocaml/types/expect create mode 100644 test/ocaml/types/types.sail diff --git a/src/rewriter.ml b/src/rewriter.ml index 3dc66b04..b180b0a1 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -2510,7 +2510,7 @@ let rewrite_undefined = let rewrite_e_aux (E_aux (e_aux, _) as exp) = match e_aux with | E_lit (L_aux (L_undef, l)) -> - check_exp (env_of exp) (undefined_of_typ (typ_of exp)) (typ_of exp) + check_exp (env_of exp) (undefined_of_typ (Env.expand_synonyms (env_of exp) (typ_of exp))) (typ_of exp) | _ -> exp in let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in diff --git a/test/ocaml/types/expect b/test/ocaml/types/expect new file mode 100644 index 00000000..747ef4c9 --- /dev/null +++ b/test/ocaml/types/expect @@ -0,0 +1,5 @@ +pass +pass +pass +pass +pass diff --git a/test/ocaml/types/types.sail b/test/ocaml/types/types.sail new file mode 100644 index 00000000..be3606d6 --- /dev/null +++ b/test/ocaml/types/types.sail @@ -0,0 +1,37 @@ + +typedef signal = enumerate {Low; High} + +typedef enum_single = enumerate {SingleConstructor} + +typedef byte = bit[8] +typedef b32 = bit[32] +typedef b64 = bit[64] + +register b64 R64 +register b32 R32 +register byte R8 + +register signal SIGNALREG + +typedef TestStruct = const struct { + bit[2] field1; + byte field2; + bool field3 +} + +register TestStruct SREG + +val unit -> unit effect {rreg, wreg} main + +function main () = { + R8 := 0xFF; + SIGNALREG := Low; + print(if SIGNALREG == Low then "pass" else "fail"); + SIGNALREG := High; + print(if SIGNALREG == High then "pass" else "fail"); + SREG.field1 := 0b00; + print(if SREG.field1 == 0b00 then "pass" else "faiL"); + SREG.field1 := 0b11; + print(if SREG.field1 == 0b11 then "pass" else "faiL"); + print("pass") +} -- cgit v1.2.3 From 2625f48417d25ab0493884b2f934887b86d568ab Mon Sep 17 00:00:00 2001 From: Alastair Reid Date: Tue, 5 Sep 2017 15:41:07 +0100 Subject: Fix printing of negative numbers --- src/pretty_print_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 70f5b749..02cc3574 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -212,7 +212,7 @@ let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = and atomic_nexp_typ ((Nexp_aux(n,_)) as ne) = match n with | Nexp_var v -> doc_var v | Nexp_id i -> braces (doc_id i) - | Nexp_constant i -> doc_int i + | Nexp_constant i -> if i < 0 then parens(doc_int i) else doc_int i | Nexp_neg _ | Nexp_exp _ | Nexp_times _ | Nexp_sum _ | Nexp_minus _-> group (parens (nexp ne)) -- cgit v1.2.3 From 842165c1171fde332bd42e7520338c59a797f76b Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 7 Sep 2017 16:54:20 +0100 Subject: Add ocaml run-time and updates to sail for ocaml backend --- lib/ocaml_rts/Makefile | 61 + lib/ocaml_rts/_tags | 6 + lib/ocaml_rts/elf_loader.ml | 132 + .../linksem/abis/aarch64/abi_aarch64_le.ml | 82 + .../abis/aarch64/abi_aarch64_le_elf_header.ml | 60 + .../abis/aarch64/abi_aarch64_le_serialisation.ml | 293 ++ .../aarch64/abi_aarch64_program_header_table.ml | 26 + .../linksem/abis/aarch64/abi_aarch64_relocation.ml | 944 ++++ .../aarch64/abi_aarch64_section_header_table.ml | 25 + .../abis/aarch64/abi_aarch64_symbol_table.ml | 23 + lib/ocaml_rts/linksem/abis/abi_classes.ml | 4 + lib/ocaml_rts/linksem/abis/abi_utilities.ml | 213 + lib/ocaml_rts/linksem/abis/abis.ml | 1420 ++++++ lib/ocaml_rts/linksem/abis/amd64/abi_amd64.ml | 98 + .../linksem/abis/amd64/abi_amd64_elf_header.ml | 60 + .../abis/amd64/abi_amd64_program_header_table.ml | 38 + .../linksem/abis/amd64/abi_amd64_relocation.ml | 355 ++ .../abis/amd64/abi_amd64_section_header_table.ml | 51 + .../linksem/abis/amd64/abi_amd64_serialisation.ml | 282 ++ .../linksem/abis/amd64/abi_amd64_symbol_table.ml | 22 + lib/ocaml_rts/linksem/abis/mips64/abi_mips64.ml | 88 + .../linksem/abis/mips64/abi_mips64_elf_header.ml | 59 + .../abis/mips64/abi_mips64_program_header_table.ml | 38 + .../abis/mips64/abi_mips64_section_header_table.ml | 37 + .../abis/mips64/abi_mips64_serialisation.ml | 282 ++ .../linksem/abis/mips64/abi_mips64_symbol_table.ml | 22 + lib/ocaml_rts/linksem/abis/power64/abi_power64.ml | 46 + .../linksem/abis/power64/abi_power64_dynamic.ml | 40 + .../linksem/abis/power64/abi_power64_elf_header.ml | 48 + .../linksem/abis/power64/abi_power64_relocation.ml | 833 ++++ .../power64/abi_power64_section_header_table.ml | 24 + .../linksem/abis/x86/abi_x86_relocation.ml | 69 + lib/ocaml_rts/linksem/abstract_linker_script.ml | 59 + .../linksem/adaptors/harness_interface.ml | 1154 +++++ lib/ocaml_rts/linksem/adaptors/sail_interface.ml | 250 ++ lib/ocaml_rts/linksem/archive.ml | 150 + lib/ocaml_rts/linksem/byte_sequence.ml | 335 ++ lib/ocaml_rts/linksem/byte_sequence_wrapper.ml | 33 + lib/ocaml_rts/linksem/command_line.ml | 671 +++ lib/ocaml_rts/linksem/default_printing.ml | 28 + lib/ocaml_rts/linksem/dwarf.ml | 4619 ++++++++++++++++++++ .../linksem/elf64_file_of_elf_memory_image.ml | 491 +++ lib/ocaml_rts/linksem/elf_dynamic.ml | 1202 +++++ lib/ocaml_rts/linksem/elf_file.ml | 1198 +++++ lib/ocaml_rts/linksem/elf_header.ml | 1508 +++++++ lib/ocaml_rts/linksem/elf_interpreted_section.ml | 305 ++ lib/ocaml_rts/linksem/elf_interpreted_segment.ml | 167 + lib/ocaml_rts/linksem/elf_memory_image.ml | 315 ++ .../linksem/elf_memory_image_of_elf64_file.ml | 563 +++ lib/ocaml_rts/linksem/elf_note.ml | 196 + lib/ocaml_rts/linksem/elf_program_header_table.ml | 605 +++ lib/ocaml_rts/linksem/elf_relocation.ml | 312 ++ lib/ocaml_rts/linksem/elf_section_header_table.ml | 1187 +++++ lib/ocaml_rts/linksem/elf_symbol_table.ml | 563 +++ lib/ocaml_rts/linksem/elf_types_native_uint.ml | 706 +++ lib/ocaml_rts/linksem/endianness.ml | 35 + lib/ocaml_rts/linksem/error.ml | 112 + .../linksem/gnu_extensions/gnu_ext_abi.ml | 131 + .../linksem/gnu_extensions/gnu_ext_dynamic.ml | 531 +++ .../linksem/gnu_extensions/gnu_ext_note.ml | 268 ++ .../gnu_extensions/gnu_ext_program_header_table.ml | 34 + .../gnu_extensions/gnu_ext_section_header_table.ml | 151 + .../gnu_ext_section_to_segment_mapping.ml | 265 ++ .../gnu_extensions/gnu_ext_symbol_versioning.ml | 294 ++ .../gnu_extensions/gnu_ext_types_native_uint.ml | 12 + lib/ocaml_rts/linksem/hex_printing.ml | 68 + lib/ocaml_rts/linksem/input_list.ml | 317 ++ lib/ocaml_rts/linksem/link.ml | 1005 +++++ lib/ocaml_rts/linksem/linkable_list.ml | 568 +++ lib/ocaml_rts/linksem/linker_script.ml | 2783 ++++++++++++ lib/ocaml_rts/linksem/main_elf.ml | 374 ++ lib/ocaml_rts/linksem/main_link.ml | 158 + lib/ocaml_rts/linksem/memory_image.ml | 839 ++++ lib/ocaml_rts/linksem/memory_image_orderings.ml | 329 ++ lib/ocaml_rts/linksem/missing_pervasives.ml | 590 +++ .../linksem/missing_pervasivesAuxiliary.ml | 42 + lib/ocaml_rts/linksem/ml_bindings.ml | 156 + lib/ocaml_rts/linksem/multimap.ml | 215 + lib/ocaml_rts/linksem/multimapAuxiliary.ml | 129 + lib/ocaml_rts/linksem/scratch.ml | 28 + lib/ocaml_rts/linksem/show.ml | 123 + lib/ocaml_rts/linksem/src_lem_library/bit.ml | 19 + lib/ocaml_rts/linksem/src_lem_library/bit.mli | 8 + lib/ocaml_rts/linksem/src_lem_library/either.ml | 24 + lib/ocaml_rts/linksem/src_lem_library/lem.ml | 103 + .../linksem/src_lem_library/lem_assert_extra.ml | 28 + .../linksem/src_lem_library/lem_basic_classes.ml | 323 ++ lib/ocaml_rts/linksem/src_lem_library/lem_bool.ml | 66 + .../linksem/src_lem_library/lem_either.ml | 87 + .../linksem/src_lem_library/lem_function.ml | 53 + .../linksem/src_lem_library/lem_function_extra.ml | 15 + lib/ocaml_rts/linksem/src_lem_library/lem_list.ml | 722 +++ .../linksem/src_lem_library/lem_list_extra.ml | 85 + lib/ocaml_rts/linksem/src_lem_library/lem_map.ml | 154 + .../linksem/src_lem_library/lem_map_extra.ml | 41 + lib/ocaml_rts/linksem/src_lem_library/lem_maybe.ml | 98 + .../linksem/src_lem_library/lem_maybe_extra.ml | 14 + lib/ocaml_rts/linksem/src_lem_library/lem_num.ml | 901 ++++ .../linksem/src_lem_library/lem_pervasives.ml | 18 + .../src_lem_library/lem_pervasives_extra.ml | 12 + .../linksem/src_lem_library/lem_relation.ml | 424 ++ lib/ocaml_rts/linksem/src_lem_library/lem_set.ml | 290 ++ .../linksem/src_lem_library/lem_set_extra.ml | 66 + .../linksem/src_lem_library/lem_set_helpers.ml | 38 + .../linksem/src_lem_library/lem_sorting.ml | 83 + .../linksem/src_lem_library/lem_string.ml | 53 + .../linksem/src_lem_library/lem_string_extra.ml | 91 + lib/ocaml_rts/linksem/src_lem_library/lem_tuple.ml | 41 + lib/ocaml_rts/linksem/src_lem_library/lem_word.ml | 731 ++++ .../linksem/src_lem_library/nat_big_num.ml | 18 + .../linksem/src_lem_library/nat_big_num.mli | 11 + lib/ocaml_rts/linksem/src_lem_library/nat_num.ml | 43 + lib/ocaml_rts/linksem/src_lem_library/nat_num.mli | 14 + lib/ocaml_rts/linksem/src_lem_library/pmap.ml | 321 ++ lib/ocaml_rts/linksem/src_lem_library/pmap.mli | 190 + lib/ocaml_rts/linksem/src_lem_library/pset.ml | 522 +++ lib/ocaml_rts/linksem/src_lem_library/pset.mli | 174 + .../linksem/src_lem_library/pset_using_lists.ml | 336 ++ lib/ocaml_rts/linksem/src_lem_library/sum.ml | 4 + lib/ocaml_rts/linksem/src_lem_library/vector.ml | 35 + lib/ocaml_rts/linksem/src_lem_library/vector.mli | 28 + lib/ocaml_rts/linksem/src_lem_library/xstring.ml | 22 + lib/ocaml_rts/linksem/src_lem_library/xstring.mli | 4 + lib/ocaml_rts/linksem/string_table.ml | 123 + lib/ocaml_rts/linksem/test_image.ml | 146 + lib/ocaml_rts/linksem/uint16_wrapper.ml | 48 + lib/ocaml_rts/linksem/uint32_wrapper.ml | 97 + lib/ocaml_rts/linksem/uint64_wrapper.ml | 119 + lib/ocaml_rts/linksem/utility.ml | 1 + lib/ocaml_rts/sail_lib.ml | 317 ++ lib/ocaml_rts/spec.ml | 4 + src/initial_check.ml | 6 + src/ocaml_backend.ml | 35 +- src/type_check.ml | 2 + src/type_check.mli | 1 + test/ocaml/types/types.sail | 7 + 136 files changed, 39159 insertions(+), 12 deletions(-) create mode 100644 lib/ocaml_rts/Makefile create mode 100644 lib/ocaml_rts/_tags create mode 100644 lib/ocaml_rts/elf_loader.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_elf_header.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_le_serialisation.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_program_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_relocation.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_section_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/aarch64/abi_aarch64_symbol_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/abi_classes.ml create mode 100644 lib/ocaml_rts/linksem/abis/abi_utilities.ml create mode 100644 lib/ocaml_rts/linksem/abis/abis.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64_elf_header.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64_program_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64_relocation.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64_section_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64_serialisation.ml create mode 100644 lib/ocaml_rts/linksem/abis/amd64/abi_amd64_symbol_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/mips64/abi_mips64.ml create mode 100644 lib/ocaml_rts/linksem/abis/mips64/abi_mips64_elf_header.ml create mode 100644 lib/ocaml_rts/linksem/abis/mips64/abi_mips64_program_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/mips64/abi_mips64_section_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/mips64/abi_mips64_serialisation.ml create mode 100644 lib/ocaml_rts/linksem/abis/mips64/abi_mips64_symbol_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/power64/abi_power64.ml create mode 100644 lib/ocaml_rts/linksem/abis/power64/abi_power64_dynamic.ml create mode 100644 lib/ocaml_rts/linksem/abis/power64/abi_power64_elf_header.ml create mode 100644 lib/ocaml_rts/linksem/abis/power64/abi_power64_relocation.ml create mode 100644 lib/ocaml_rts/linksem/abis/power64/abi_power64_section_header_table.ml create mode 100644 lib/ocaml_rts/linksem/abis/x86/abi_x86_relocation.ml create mode 100644 lib/ocaml_rts/linksem/abstract_linker_script.ml create mode 100644 lib/ocaml_rts/linksem/adaptors/harness_interface.ml create mode 100644 lib/ocaml_rts/linksem/adaptors/sail_interface.ml create mode 100644 lib/ocaml_rts/linksem/archive.ml create mode 100644 lib/ocaml_rts/linksem/byte_sequence.ml create mode 100644 lib/ocaml_rts/linksem/byte_sequence_wrapper.ml create mode 100644 lib/ocaml_rts/linksem/command_line.ml create mode 100644 lib/ocaml_rts/linksem/default_printing.ml create mode 100644 lib/ocaml_rts/linksem/dwarf.ml create mode 100644 lib/ocaml_rts/linksem/elf64_file_of_elf_memory_image.ml create mode 100644 lib/ocaml_rts/linksem/elf_dynamic.ml create mode 100644 lib/ocaml_rts/linksem/elf_file.ml create mode 100644 lib/ocaml_rts/linksem/elf_header.ml create mode 100644 lib/ocaml_rts/linksem/elf_interpreted_section.ml create mode 100644 lib/ocaml_rts/linksem/elf_interpreted_segment.ml create mode 100644 lib/ocaml_rts/linksem/elf_memory_image.ml create mode 100644 lib/ocaml_rts/linksem/elf_memory_image_of_elf64_file.ml create mode 100644 lib/ocaml_rts/linksem/elf_note.ml create mode 100644 lib/ocaml_rts/linksem/elf_program_header_table.ml create mode 100644 lib/ocaml_rts/linksem/elf_relocation.ml create mode 100644 lib/ocaml_rts/linksem/elf_section_header_table.ml create mode 100644 lib/ocaml_rts/linksem/elf_symbol_table.ml create mode 100644 lib/ocaml_rts/linksem/elf_types_native_uint.ml create mode 100644 lib/ocaml_rts/linksem/endianness.ml create mode 100644 lib/ocaml_rts/linksem/error.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_abi.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_dynamic.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_note.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_program_header_table.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_header_table.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_section_to_segment_mapping.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_symbol_versioning.ml create mode 100644 lib/ocaml_rts/linksem/gnu_extensions/gnu_ext_types_native_uint.ml create mode 100644 lib/ocaml_rts/linksem/hex_printing.ml create mode 100644 lib/ocaml_rts/linksem/input_list.ml create mode 100644 lib/ocaml_rts/linksem/link.ml create mode 100644 lib/ocaml_rts/linksem/linkable_list.ml create mode 100644 lib/ocaml_rts/linksem/linker_script.ml create mode 100644 lib/ocaml_rts/linksem/main_elf.ml create mode 100644 lib/ocaml_rts/linksem/main_link.ml create mode 100644 lib/ocaml_rts/linksem/memory_image.ml create mode 100644 lib/ocaml_rts/linksem/memory_image_orderings.ml create mode 100644 lib/ocaml_rts/linksem/missing_pervasives.ml create mode 100644 lib/ocaml_rts/linksem/missing_pervasivesAuxiliary.ml create mode 100644 lib/ocaml_rts/linksem/ml_bindings.ml create mode 100644 lib/ocaml_rts/linksem/multimap.ml create mode 100644 lib/ocaml_rts/linksem/multimapAuxiliary.ml create mode 100644 lib/ocaml_rts/linksem/scratch.ml create mode 100644 lib/ocaml_rts/linksem/show.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/bit.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/bit.mli create mode 100644 lib/ocaml_rts/linksem/src_lem_library/either.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_assert_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_basic_classes.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_bool.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_either.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_function.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_function_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_list.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_list_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_map.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_map_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_maybe.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_maybe_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_num.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_pervasives.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_pervasives_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_relation.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_set.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_set_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_set_helpers.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_sorting.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_string.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_string_extra.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_tuple.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/lem_word.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/nat_big_num.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/nat_big_num.mli create mode 100755 lib/ocaml_rts/linksem/src_lem_library/nat_num.ml create mode 100755 lib/ocaml_rts/linksem/src_lem_library/nat_num.mli create mode 100755 lib/ocaml_rts/linksem/src_lem_library/pmap.ml create mode 100755 lib/ocaml_rts/linksem/src_lem_library/pmap.mli create mode 100755 lib/ocaml_rts/linksem/src_lem_library/pset.ml create mode 100755 lib/ocaml_rts/linksem/src_lem_library/pset.mli create mode 100644 lib/ocaml_rts/linksem/src_lem_library/pset_using_lists.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/sum.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/vector.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/vector.mli create mode 100644 lib/ocaml_rts/linksem/src_lem_library/xstring.ml create mode 100644 lib/ocaml_rts/linksem/src_lem_library/xstring.mli create mode 100644 lib/ocaml_rts/linksem/string_table.ml create mode 100644 lib/ocaml_rts/linksem/test_image.ml create mode 100644 lib/ocaml_rts/linksem/uint16_wrapper.ml create mode 100644 lib/ocaml_rts/linksem/uint32_wrapper.ml create mode 100644 lib/ocaml_rts/linksem/uint64_wrapper.ml create mode 100644 lib/ocaml_rts/linksem/utility.ml create mode 100644 lib/ocaml_rts/sail_lib.ml create mode 100644 lib/ocaml_rts/spec.ml 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 @@ +: use_nums, use_str, use_unix, debug +: include +: include +: include +: -traverse +: -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 + 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 + + * ... 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 = "!\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 "); + (["--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. 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 + 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 ^ " \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 ^ " \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 -> "" + )) + +(*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 forms is used to represent a signed or unsigned integer, it +can be hard for a consumer to discover the context necessary to determine which +interpretation is intended. Producers are therefore strongly encouraged to use +DW_FORM_sdata or DW_FORM_udata for signed and unsigned integers respectively, +rather than DW_FORM_data. +no kidding - if we get an AV_constantN for DW_AT_high_pc, should it be interpreted as signed or unsigned? *) + + +let rec closest_enclosing_frame_base dloc (base_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 -> " \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 -> "\n" + )) in + (match esl with + | Success sl -> + name1 ^ (" @ " ^ (pp_single_location sl ^"\n")) + + | Fail e -> name1 ^ (" @ " ^ ("\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 ("",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 -> "" + | 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 will usually be non-final (overridable). + * Output needs to call . BUT the trick is as follows: + * the reloc is swizzled so that it binds to the PLT slot ; + * 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 . + * The binding is final because 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 " + )) + 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 () = () diff --git a/src/initial_check.ml b/src/initial_check.ml index 74faba25..e9695dd4 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -1079,6 +1079,12 @@ let generate_undefineds vs_ids (Defs defs) = mk_fundef [mk_funcl (prepend_id "undefined_" id) pat (mk_exp (E_record (mk_fexps (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields))))]] + | TD_variant (id, _, typq, tus, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> + [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id)); + mk_fundef [mk_funcl (prepend_id "undefined_" id) + (mk_pat (P_lit (mk_lit L_unit))) + (mk_exp (E_app (mk_id "internal_pick", + [])))]] | _ -> [] in let rec undefined_defs = function diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 8b88a07e..2509f8ef 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -88,7 +88,13 @@ let ocaml_lit (L_aux (lit_aux, _)) = let rec ocaml_pat ctx (P_aux (pat_aux, _) as pat) = match pat_aux with - | P_id id -> zencode ctx id + | P_id id -> + begin + match Env.lookup_id id (pat_env_of pat) with + | Local (Immutable, _) | Unbound -> zencode ctx id + | Enum _ -> zencode_upper ctx id + | _ -> failwith "Ocaml: Cannot pattern match on mutable variable or register" + end | P_lit lit -> ocaml_lit lit | P_typ (_, pat) -> ocaml_pat ctx pat | P_tup pats -> parens (separate_map (comma ^^ space) (ocaml_pat ctx) pats) @@ -110,7 +116,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = | E_block [] -> string "()" | E_block exps -> begin_end (ocaml_block ctx exps) | E_field (exp, id) -> ocaml_atomic_exp ctx exp ^^ dot ^^ zencode ctx id - | E_exit exp -> string "failwith" ^^ space ^^ dquotes (string (String.escaped (string_of_exp exp))) + | E_exit exp -> string "exit 0" | E_case (exp, pexps) -> begin_end (separate space [string "match"; ocaml_atomic_exp ctx exp; string "with"] ^/^ ocaml_pexps ctx pexps) @@ -218,12 +224,12 @@ let rec ocaml_funcl_matches ctx = function let ocaml_funcls ctx = function | [] -> failwith "Ocaml: empty function" | [FCL_aux (FCL_Funcl (id, pat, exp),_)] -> - separate space [string "let"; zencode ctx id; ocaml_pat ctx pat; equals; string "with_return (fun r ->"] + separate space [string "let rec"; zencode ctx id; ocaml_pat ctx pat; equals; string "with_return (fun r ->"] ^//^ ocaml_exp ctx exp ^^ rparen | funcls -> let id = funcls_id funcls in - separate space [string "let"; zencode ctx id; equals; string "function"] + separate space [string "let rec"; zencode ctx id; equals; string "function"] ^//^ ocaml_funcl_matches ctx funcls let ocaml_fundef ctx (FD_aux (FD_function (_, _, _, funcls), _)) = @@ -311,8 +317,10 @@ let ocaml_defs (Defs defs) = let ocaml_main spec = concat [separate space [string "open"; string (String.capitalize spec)] ^^ ocaml_def_end; + separate space [string "open"; string "Elf_loader"] ^^ ocaml_def_end; separate space [string "let"; string "()"; equals] ^//^ (string "Random.self_init ();" + ^/^ string "load_elf ();" ^/^ string "initialize_registers ();" ^/^ string "zmain ()") ] @@ -328,20 +336,23 @@ let ocaml_compile spec defs = if Sys.file_exists "_sbuild" then () else Unix.mkdir "_sbuild" 0o775; let cwd = Unix.getcwd () in Unix.chdir "_sbuild"; - let _ = Unix.system ("cp " ^ sail_lib_dir ^ "/sail_lib.ml .") in + let _ = Unix.system ("cp -r " ^ sail_lib_dir ^ "/ocaml_rts/. .") in let out_chan = open_out (spec ^ ".ml") in ocaml_pp_defs out_chan defs; close_out out_chan; if IdSet.mem (mk_id "main") (Initial_check.val_spec_ids defs) then - let out_chan = open_out "main.ml" in - ToChannel.pretty 1. 80 out_chan (ocaml_main spec); - close_out out_chan; - let _ = Unix.system "ocamlbuild -lib nums main.native" in - let _ = Unix.system ("cp main.native " ^ cwd ^ "/" ^ spec) in - () + begin + print_endline "Generating main"; + let out_chan = open_out "main.ml" in + ToChannel.pretty 1. 80 out_chan (ocaml_main spec); + close_out out_chan; + let _ = Unix.system "ocamlbuild -pkg zarith -pkg uint main.native" in + let _ = Unix.system ("cp main.native " ^ cwd ^ "/" ^ spec) in + () + end else - let _ = Unix.system ("ocamlbuild -lib nums " ^ spec ^ ".cmo") in + let _ = Unix.system ("ocamlbuild -pkg zarith -pkg uint " ^ spec ^ ".cmo") in (); Unix.chdir cwd diff --git a/src/type_check.ml b/src/type_check.ml index 4eb0688b..636d4049 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1573,6 +1573,8 @@ let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot) let pat_typ_of (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot) +let pat_env_of (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) + (* Flow typing *) let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with diff --git a/src/type_check.mli b/src/type_check.mli index 857e0019..fa75b156 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -201,6 +201,7 @@ val typ_of : tannot exp -> typ val typ_of_annot : Ast.l * tannot -> typ val pat_typ_of : tannot pat -> typ +val pat_env_of : tannot pat -> Env.t val effect_of : tannot exp -> effect val effect_of_annot : tannot -> effect diff --git a/test/ocaml/types/types.sail b/test/ocaml/types/types.sail index be3606d6..8f50e057 100644 --- a/test/ocaml/types/types.sail +++ b/test/ocaml/types/types.sail @@ -21,6 +21,13 @@ typedef TestStruct = const struct { register TestStruct SREG +typedef option = const union forall Type 'a. { + None; + 'a Some +} + +register (option) OREG + val unit -> unit effect {rreg, wreg} main function main () = { -- cgit v1.2.3 From af478ccda9894883427447cb954fc883efbd2217 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 8 Sep 2017 15:54:57 +0100 Subject: Fixed bug when printing Typ_args in Lem AST output --- src/pretty_print_lem_ast.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 5edf9d12..68745bf9 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -208,9 +208,9 @@ and pp_format_effects_lem (Effect_aux(e,l)) = and pp_format_typ_arg_lem (Typ_arg_aux(t,l)) = "(Typ_arg_aux " ^ (match t with - | Typ_arg_typ(t) -> "(Typ_arg_typ " ^ pp_format_typ_lem t ^ ")" - | Typ_arg_nexp(n) -> "(Typ_arg_nexp " ^ pp_format_nexp_lem n ^ ")" - | Typ_arg_order(o) -> "(Typ_arg_order " ^ pp_format_ord_lem o ^ ")"); + | Typ_arg_typ(t) -> "(Typ_arg_typ " ^ pp_format_typ_lem t ^ ")" + | Typ_arg_nexp(n) -> "(Typ_arg_nexp " ^ pp_format_nexp_lem n ^ ")" + | Typ_arg_order(o) -> "(Typ_arg_order " ^ pp_format_ord_lem o ^ ")") ^ (pp_format_l_lem l) ^ ")" and pp_format_nexp_constraint_lem (NC_aux(nc,l)) = "(NC_aux " ^ -- cgit v1.2.3 From aa1f89abb2f42d085bd123147144c9c5c7ceb22f Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 13 Sep 2017 16:27:34 +0100 Subject: Work on improving Sail error messages - Modified how sail type error messages are displayed. The typechecker, rather than immediately outputing a string has a datatype for error types, which are the pretty-printed using a PPrint pretty-printer. Needs more work for all the error messages. - Error messages now attempt to highlight the part of the file where the error occurred, by printing the line the error is on and highlighting where the error message is in red. Again, this needs to be made more robust, especially when the error messages span multiple lines. Other things - Improved new parser and lexer. Made the lexer & parser handling of colons simpler and more intuitive. - Added some more typechecking test cases --- src/ast_util.mli | 2 + src/initial_check.ml | 6 +-- src/lexer2.mll | 2 - src/parser2.mly | 57 +++++++-------------- src/reporting_basic.ml | 59 ++++++++++++++++------ src/type_check.ml | 80 ++++++++++++++++++++++-------- src/type_check.mli | 4 +- test/typecheck/fail/mismatch_return.sail | 7 +++ test/typecheck/fail/pure_record_arity.sail | 25 ++++++++++ test/typecheck/fail/vector_append_old.sail | 14 ++++++ test/typecheck/pass/exist_subrange.sail | 12 +++++ test/typecheck/pass/exist_true.sail | 7 +++ test/typecheck/pass/pure_record2.sail | 22 ++++++++ test/typecheck/pass/pure_record3.sail | 25 ++++++++++ test/typecheck/pass/vec_pat1.sail | 2 +- test/typecheck/pass/vector_append.sail | 6 +-- 16 files changed, 243 insertions(+), 87 deletions(-) create mode 100644 test/typecheck/fail/mismatch_return.sail create mode 100644 test/typecheck/fail/pure_record_arity.sail create mode 100644 test/typecheck/fail/vector_append_old.sail create mode 100644 test/typecheck/pass/exist_subrange.sail create mode 100644 test/typecheck/pass/exist_true.sail create mode 100644 test/typecheck/pass/pure_record2.sail create mode 100644 test/typecheck/pass/pure_record3.sail diff --git a/src/ast_util.mli b/src/ast_util.mli index e6823ee9..6164fc17 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -44,6 +44,8 @@ open Ast +val no_annot : unit annot + val mk_id : string -> id val mk_kid : string -> kid val mk_ord : order_aux -> order diff --git a/src/initial_check.ml b/src/initial_check.ml index 4c0a0db4..1f7840d0 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -1010,7 +1010,7 @@ let initial_kind_env = ] let typschm_of_string order str = - let typschm = Parser2.typschm Lexer2.token (Lexing.from_string str) in + let typschm = Parser2.typschm_eof Lexer2.token (Lexing.from_string str) in let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in typschm @@ -1057,14 +1057,14 @@ let generate_undefineds vs_ids (Defs defs) = if (IdSet.mem id vs_ids) then [] else [val_spec_of_string dec_ord id str] in let undefined_builtins = List.concat - [gen_vs (mk_id "internal_pick") "forall 'a:Type. list('a) -> 'a effect {undef}"; + [gen_vs (mk_id "internal_pick") "forall ('a:Type). list('a) -> 'a effect {undef}"; gen_vs (mk_id "undefined_bool") "unit -> bool effect {undef}"; gen_vs (mk_id "undefined_bit") "unit -> bit effect {undef}"; gen_vs (mk_id "undefined_int") "unit -> int effect {undef}"; gen_vs (mk_id "undefined_string") "unit -> string effect {undef}"; gen_vs (mk_id "undefined_range") "forall 'n 'm. (atom('n), atom('m)) -> range('n,'m) effect {undef}"; (* FIXME: How to handle inc/dec order correctly? *) - gen_vs (mk_id "undefined_vector") "forall 'n 'm 'a:Type. (atom('n), atom('m), 'a) -> vector('n, 'm, dec,'a) effect {undef}"; + gen_vs (mk_id "undefined_vector") "forall 'n 'm ('a:Type). (atom('n), atom('m), 'a) -> vector('n, 'm, dec,'a) effect {undef}"; gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"] in let undefined_td = function diff --git a/src/lexer2.mll b/src/lexer2.mll index f5350ea8..a1717d62 100644 --- a/src/lexer2.mll +++ b/src/lexer2.mll @@ -235,8 +235,6 @@ rule token = parse with Not_found -> raise (LexError ("Operator fixity undeclared", Lexing.lexeme_start_p lexbuf)) } | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } - | (tyvar_start startident ident* as i) ":" { TyDecl(r i) } - | (startident ident* as i) ":" { Decl(r i) } | tyvar_start startident ident* as i { TyVar(r i) } | startident ident* as i { if M.mem i kw_table then (M.find i kw_table) () diff --git a/src/parser2.mly b/src/parser2.mly index 42e13721..02a8f09c 100644 --- a/src/parser2.mly +++ b/src/parser2.mly @@ -139,7 +139,7 @@ let rec desugar_rchain chain s e = /*Terminals with content*/ -%token Id TyVar Decl TyDecl +%token Id TyVar %token Num %token String Bin Hex Real @@ -153,9 +153,8 @@ let rec desugar_rchain chain s e = %token Op0r Op1r Op2r Op3r Op4r Op5r Op6r Op7r Op8r Op9r %start file -%start typschm -%type typschm -%type defs +%start typschm_eof +%type typschm_eof %type file %% @@ -233,10 +232,6 @@ op7r: Op7r { mk_id (Id $1) $startpos $endpos } op8r: Op8r { mk_id (Id $1) $startpos $endpos } op9r: Op9r { mk_id (Id $1) $startpos $endpos } -decl: - | Decl - { mk_id (Id $1) $startpos $endpos } - id_list: | id { [$1] } @@ -247,10 +242,6 @@ kid: | TyVar { mk_kid $1 $startpos $endpos } -tydecl: - | TyDecl - { mk_kid $1 $startpos $endpos } - kid_list: | kid { [$1] } @@ -515,8 +506,6 @@ kind: { K_aux (K_kind [$1], loc $startpos $endpos) } kopt: - | tydecl kind - { KOpt_aux (KOpt_kind ($2, $1), loc $startpos $endpos) } | Lparen kid Colon kind Rparen { KOpt_aux (KOpt_kind ($4, $2), loc $startpos $endpos) } | kid @@ -589,6 +578,10 @@ typschm: | Forall typquant Dot typ MinusGt typ Effect effect_set { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } +typschm_eof: + | typschm Eof + { $1 } + pat: | atomic_pat { $1 } @@ -612,14 +605,10 @@ atomic_pat: { mk_pat (P_id $1) $startpos $endpos } | kid { mk_pat (P_var $1) $startpos $endpos } - | tydecl typ - { mk_pat (P_typ ($2, mk_pat (P_var $1) $startpos $endpos($1))) $startpos $endpos } | id Lparen pat_list Rparen { mk_pat (P_app ($1, $3)) $startpos $endpos } | pat Colon typ { mk_pat (P_typ ($3, $1)) $startpos $endpos } - | decl typ - { mk_pat (P_typ ($2, mk_pat (P_id $1) $startpos $endpos($1))) $startpos $endpos } | Lparen pat Rparen { $2 } @@ -646,27 +635,21 @@ lit: { mk_lit (L_string $1) $startpos $endpos } exp: - | cast_exp Colon typ - { mk_exp (E_cast ($3, $1)) $startpos $endpos } - | cast_exp - { $1 } - -cast_exp: | exp0 { $1 } - | atomic_exp Eq cast_exp + | atomic_exp Eq exp { mk_exp (E_assign ($1, $3)) $startpos $endpos } - | Let_ letbind In cast_exp + | Let_ letbind In exp { mk_exp (E_let ($2, $4)) $startpos $endpos } | Lcurly block Rcurly { mk_exp (E_block $2) $startpos $endpos } - | Return cast_exp + | Return exp { mk_exp (E_return $2) $startpos $endpos } - | Throw cast_exp + | Throw exp { mk_exp (E_throw $2) $startpos $endpos } - | If_ exp Then cast_exp Else cast_exp + | If_ exp Then exp Else exp { mk_exp (E_if ($2, $4, $6)) $startpos $endpos } - | If_ exp Then cast_exp + | If_ exp Then exp { mk_exp (E_if ($2, $4, mk_lit_exp L_unit $endpos($4) $endpos($4))) $startpos $endpos } | Match exp Lcurly case_list Rcurly { mk_exp (E_case ($2, $4)) $startpos $endpos } @@ -856,12 +839,14 @@ block: { LB_aux (LB_val_implicit ($1, $3), loc $startpos $endpos) } atomic_exp: + | atomic_exp Colon atomic_typ + { mk_exp (E_cast ($3, $1)) $startpos $endpos } | lit { mk_exp (E_lit $1) $startpos $endpos } - | decl atomic_typ - { mk_exp (E_cast ($2, mk_exp (E_id $1) $startpos $endpos($1))) $startpos $endpos } | id { mk_exp (E_id $1) $startpos $endpos } + | kid + { mk_exp (E_sizeof (mk_typ (ATyp_var $1) $startpos $endpos)) $startpos $endpos } | id Unit { mk_exp (E_app ($1, [mk_lit_exp L_unit $startpos($2) $endpos])) $startpos $endpos } | id Lparen exp_list Rparen @@ -922,8 +907,6 @@ enum: { $1 :: $3 } struct_field: - | decl typ - { ($2, $1) } | id Colon typ { ($3, $1) } @@ -936,8 +919,6 @@ struct_fields: { $1 :: $3 } type_union: - | decl typ - { Tu_aux (Tu_ty_id ($2, $1), loc $startpos $endpos) } | id Colon typ { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } | id @@ -960,14 +941,10 @@ let_def: { $2 } val_spec_def: - | Val decl typschm - { mk_vs (VS_val_spec ($3, $2)) $startpos $endpos } | Val id Colon typschm { mk_vs (VS_val_spec ($4, $2)) $startpos $endpos } register_def: - | Register decl typ - { mk_reg_dec (DEC_reg ($3, $2)) $startpos $endpos } | Register id Colon typ { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } diff --git a/src/reporting_basic.ml b/src/reporting_basic.ml index 69c5c084..2bd5d5bc 100644 --- a/src/reporting_basic.ml +++ b/src/reporting_basic.ml @@ -87,19 +87,48 @@ (* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (**************************************************************************) -let format_pos ff p = ( - Format.fprintf ff "File \"%s\", line %d, character %d:\n" - p.Lexing.pos_fname p.Lexing.pos_lnum (p.Lexing.pos_cnum - p.Lexing.pos_bol); - Format.pp_print_flush ff ()) - - -let format_pos2 ff p1 p2 = ( - Format.fprintf ff "File \"%s\", line %d, character %d to line %d, character %d" - p1.Lexing.pos_fname - p1.Lexing.pos_lnum (p1.Lexing.pos_cnum - p1.Lexing.pos_bol + 1) - p2.Lexing.pos_lnum (p2.Lexing.pos_cnum - p2.Lexing.pos_bol); - Format.pp_print_flush ff () -) +let format_pos ff p = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d:\n" + p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol); + Format.pp_print_flush ff () + end + +let rec skip_lines in_chan = function + | n when n <= 0 -> () + | n -> input_line in_chan; skip_lines in_chan (n - 1) + +let termcode n = "\x1B[" ^ string_of_int n ^ "m" + +let print_code ff fname lnum1 cnum1 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s%s" + (Str.string_before line cnum1) + (termcode 41) + (Str.string_before (Str.string_after line cnum1) (cnum2 - cnum1)) + (termcode 49) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; print_endline (Printexc.to_string e)) + end + with _ -> () + +let format_pos2 ff p1 p2 = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d\n\n" + p1.pos_fname + p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) + p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + print_code ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol); + Format.pp_print_flush ff () + end (* reads the part between p1 and p2 from the file *) @@ -171,12 +200,12 @@ let loc_to_string l = type pos_or_loc = Loc of Parse_ast.l | LocD of Parse_ast.l * Parse_ast.l | Pos of Lexing.position let print_err_internal fatal verb_loc p_l m1 m2 = + Format.eprintf "%s at " m1; let _ = (match p_l with Pos p -> print_err_pos p | Loc l -> print_err_loc l | LocD (l1,l2) -> print_err_loc l1; Format.fprintf Format.err_formatter " and "; print_err_loc l2) in - let m12 = if String.length m2 = 0 then "" else ": " in - Format.eprintf " %s%s%s\n" m1 m12 m2; + Format.eprintf "%s\n" m2; if verb_loc then (match p_l with Loc l -> format_loc_source Format.err_formatter l; Format.pp_print_newline Format.err_formatter (); | _ -> ()); diff --git a/src/type_check.ml b/src/type_check.ml index 636d4049..f952d0d6 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -65,9 +65,47 @@ let typ_print m = if !opt_tc_debug > 0 then prerr_endline (indent !depth ^ m) el let typ_warning m = prerr_endline ("Warning: " ^ m) -exception Type_error of l * string;; +type type_error = + (* First parameter is the error that caused us to start doing type + coercions, the second is the errors encountered by all possible + coerctions *) + | Err_no_casts of type_error * type_error list + | Err_subtype of typ * typ * n_constraint list + | Err_other of string + +let pp_type_error err = + let open PPrint in + let rec pp_err = function + | Err_no_casts (trigger, []) -> + (string "Tried performing type coercion because" ^//^ pp_err trigger) + ^/^ string "No possible coercions" + | Err_no_casts (trigger, errs) -> + (string "Tried performing type coerction because" ^//^ pp_err trigger) + | Err_subtype (typ1, typ2, []) -> + separate space [ string (string_of_typ typ1); + string "is not a subtype of"; + string (string_of_typ typ2) ] + | Err_subtype (typ1, typ2, constrs) -> + separate space [ string (string_of_typ typ1); + string "is not a subtype of"; + string (string_of_typ typ2) ] + ^/^ string "in context" + ^//^ string (string_of_list ", " string_of_n_constraint constrs) + | Err_other str -> string str + in + pp_err err + +let rec string_of_type_error err = + let open PPrint in + let b = Buffer.create 20 in + ToBuffer.pretty 1. 120 b (pp_type_error err); + "\n" ^ Buffer.contents b + +exception Type_error of l * type_error;; + +let typ_error l m = raise (Type_error (l, Err_other m)) -let typ_error l m = raise (Type_error (l, m)) +let typ_raise l err = raise (Type_error (l, err)) let deinfix = function | Id_aux (Id v, l) -> Id_aux (DeIid v, l) @@ -1447,9 +1485,7 @@ let rec subtyp l env typ1 typ2 = | _, None -> if subtyp_tnf env (normalize_typ env typ1) (normalize_typ env typ2) then () - else typ_error l (string_of_typ typ1 - ^ " is not a subtype of " ^ string_of_typ typ2 - ^ " in context " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)) + else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env)) let typ_equality l env typ1 typ2 = subtyp l env typ1 typ2; subtyp l env typ2 typ1 @@ -1782,7 +1818,7 @@ let crule r env exp typ = let checked_exp = r env exp typ in decr depth; checked_exp with - | Type_error (l, m) -> decr depth; typ_error l m + | Type_error (l, err) -> decr depth; typ_raise l err let irule r env exp = incr depth; @@ -1792,7 +1828,7 @@ let irule r env exp = decr depth; inferred_exp with - | Type_error (l, m) -> decr depth; typ_error l m + | Type_error (l, err) -> decr depth; typ_raise l err let strip_exp : 'a exp -> unit exp = function exp -> map_exp_annot (fun (l, _) -> (l, ())) exp let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) -> (l, ())) pat @@ -1928,7 +1964,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ | (f :: fs) -> begin typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); try crule check_exp env (E_aux (E_app (f, xs), (l, ()))) typ with - | Type_error (_, m) -> typ_print ("Error : " ^ m); try_overload fs + | Type_error (_, err) -> typ_print ("Error : " ^ string_of_type_error err); try_overload fs end in try_overload (Env.get_overloads f env) @@ -1991,15 +2027,15 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in - let rec try_casts m = function - | [] -> typ_error l ("No valid casts:\n" ^ m) + let rec try_casts trigger errs = function + | [] -> typ_raise l (Err_no_casts (trigger, errs)) | (cast :: casts) -> begin typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ); try let checked_cast = crule check_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) typ in annot_exp (E_cast (typ, checked_cast)) typ with - | Type_error (_, m) -> try_casts m casts + | Type_error (_, err) -> try_casts trigger (err :: errs) casts end in begin @@ -2007,10 +2043,10 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = typ_debug ("PERFORMING TYPE COERCION: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ); subtyp l env (typ_of annotated_exp) typ; annotated_exp with - | Type_error (_, m) when Env.allow_casts env -> + | Type_error (_, trigger) when Env.allow_casts env -> let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in - try_casts "" casts - | Type_error (l, m) -> typ_error l ("Subtype error " ^ m) + try_casts trigger [] casts + | Type_error (l, err) -> typ_error l "Subtype error" end (* type_coercion_unify env exp typ attempts to coerce exp to a type @@ -2021,8 +2057,8 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in - let rec try_casts m = function - | [] -> unify_error l ("No valid casts resulted in unification:\n" ^ m) + let rec try_casts = function + | [] -> unify_error l "No valid casts resulted in unification" | (cast :: casts) -> begin typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification"); try @@ -2030,8 +2066,8 @@ and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = let ityp = typ_of inferred_cast in annot_exp (E_cast (ityp, inferred_cast)) ityp, unify l env typ ityp with - | Type_error (_, m) -> try_casts m casts - | Unification_error (_, m) -> try_casts m casts + | Type_error (_, err) -> try_casts casts + | Unification_error (_, err) -> try_casts casts end in begin @@ -2041,7 +2077,7 @@ and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = with | Unification_error (_, m) when Env.allow_casts env -> let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in - try_casts "" casts + try_casts casts end and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) = @@ -2497,7 +2533,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = | (f :: fs) -> begin typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); try irule infer_exp env (E_aux (E_app (f, xs), (l, ()))) with - | Type_error (_, m) -> typ_print ("Error: " ^ m); try_overload fs + | Type_error (_, err) -> typ_print ("Overload error"); try_overload fs end in try_overload (Env.get_overloads f env) @@ -3125,7 +3161,7 @@ let mk_synonym typq typ = typ_subst_typ (kopt_kid kopt) (unaux_typ arg) typ, ncs | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> let typ, ncs = subst_args kopts args in - typ_subst_order (kopt_kid kopt) (unaux_order arg) typ, ncs + typ_subst_order (kopt_kid kopt) (unaux_order arg) typ, ncs | [], [] -> typ, ncs | _, Typ_arg_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments" | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments" @@ -3193,4 +3229,4 @@ let rec check' env (Defs defs) = let check env defs = try check' env defs with - | Type_error (l, m) -> raise (Reporting_basic.err_typ l m) + | Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) diff --git a/src/type_check.mli b/src/type_check.mli index fa75b156..ca2fb90c 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -47,7 +47,9 @@ open Ast_util val opt_tc_debug : int ref val opt_no_effects : bool ref -exception Type_error of l * string;; +type type_error + +exception Type_error of l * type_error;; type mut = Immutable | Mutable diff --git a/test/typecheck/fail/mismatch_return.sail b/test/typecheck/fail/mismatch_return.sail new file mode 100644 index 00000000..85b8b636 --- /dev/null +++ b/test/typecheck/fail/mismatch_return.sail @@ -0,0 +1,7 @@ + +val unit -> unit effect pure test + +function int test () = +{ + () +} diff --git a/test/typecheck/fail/pure_record_arity.sail b/test/typecheck/fail/pure_record_arity.sail new file mode 100644 index 00000000..846df2c3 --- /dev/null +++ b/test/typecheck/fail/pure_record_arity.sail @@ -0,0 +1,25 @@ +default Order dec + +typedef State = const struct forall Type 'a, Nat 'n. { + vector<0, 'n, dec, 'a> N; + vector<0, 1, dec, bit> Z; +} + +register State procState + +let (State) myStateM = { + (State) r := undefined; + r.N := 0b1; + r.Z := 0b1; + r +} + +let (State) myState = { N = 0b1; Z = 0b1 } + +val unit -> unit effect {undef} test + +function test () = { + (State) myState1 := undefined; + (State) myState2 := { N = undefined; Z = 0b1 }; + (State) myState3 := { myState2 with N = 0b0 } +} diff --git a/test/typecheck/fail/vector_append_old.sail b/test/typecheck/fail/vector_append_old.sail new file mode 100644 index 00000000..fb6018b9 --- /dev/null +++ b/test/typecheck/fail/vector_append_old.sail @@ -0,0 +1,14 @@ + +val extern forall Nat 'n1, Nat 'l1, Nat 'n2, Nat 'l2, Order 'o, 'l1 >= 0, 'l2 >= 0. + (vector<'n1,'l1,'o,bit>, vector<'n2,'l2,'o,bit>) -> vector<'n1,'l1 + 'l2,'o,bit> effect pure vector_append = "bitvector_concat" + +default Order inc + +val (bit[4], bit[4]) -> bit[8] effect pure test + +function bit[8] test (v1, v2) = +{ + zv := vector_append(v1, v2); + zv := v1 : v2; + zv +} diff --git a/test/typecheck/pass/exist_subrange.sail b/test/typecheck/pass/exist_subrange.sail new file mode 100644 index 00000000..de867b75 --- /dev/null +++ b/test/typecheck/pass/exist_subrange.sail @@ -0,0 +1,12 @@ +default Order dec + +val forall Num 'n, Num 'm, Num 'o (* , 'm >= 'o, 'o >= 0, 'n >= 'm + 1 *). + (bit['n], [:'m:], [:'o:]) -> bit['m - ('o - 1)] effect pure vector_subrange + +function unit test ((bit[6]) xs) = +{ + (int) len := 4; + (exist 'n. [:'n:]) len := 5; + ys := xs[len .. 0]; + () +} diff --git a/test/typecheck/pass/exist_true.sail b/test/typecheck/pass/exist_true.sail new file mode 100644 index 00000000..a30fb87b --- /dev/null +++ b/test/typecheck/pass/exist_true.sail @@ -0,0 +1,7 @@ + +function unit test () = +{ + (exist 'n. [:'n:]) x := 4; + (exist 'n, true. [:'n:]) y := 5; + () +} diff --git a/test/typecheck/pass/pure_record2.sail b/test/typecheck/pass/pure_record2.sail new file mode 100644 index 00000000..a0a85313 --- /dev/null +++ b/test/typecheck/pass/pure_record2.sail @@ -0,0 +1,22 @@ +default Order dec + +typedef State = const struct forall Type 'a, Nat 'n. { + vector<0, 'n, dec, 'a> N; + vector<0, 1, dec, bit> Z; +} + +let (State) myStateM = { + (State) r := undefined; + r.N := 0b1; + r.Z := 0b1; + r +} + +let (State) myState = { N = 0b1; Z = 0b1 } + +val unit -> unit effect {undef} test + +function test () = { + (State) myState2 := { N = undefined; Z = 0b1 }; + (State) myState3 := { myState2 with N = 0b0 } +} diff --git a/test/typecheck/pass/pure_record3.sail b/test/typecheck/pass/pure_record3.sail new file mode 100644 index 00000000..61d74ebf --- /dev/null +++ b/test/typecheck/pass/pure_record3.sail @@ -0,0 +1,25 @@ +default Order dec + +typedef State = const struct forall Type 'a, Nat 'n. { + vector<0, 'n, dec, 'a> N; + vector<0, 1, dec, bit> Z; +} + +register State procState + +let (State) myStateM = { + (State) r := undefined; + r.N := 0b1; + r.Z := 0b1; + r +} + +let (State) myState = { N = 0b1; Z = 0b1 } + +val unit -> unit effect {undef} test + +function test () = { + (State) myState1 := undefined; + (State) myState2 := { N = undefined; Z = 0b1 }; + (State) myState3 := { myState2 with N = 0b0 } +} diff --git a/test/typecheck/pass/vec_pat1.sail b/test/typecheck/pass/vec_pat1.sail index fe9b4a0a..b22f0029 100644 --- a/test/typecheck/pass/vec_pat1.sail +++ b/test/typecheck/pass/vec_pat1.sail @@ -10,7 +10,7 @@ val forall Num 'n, Num 'm, Num 'o, Num 'p. effect pure bitvector_concat overload (deinfix +) [bv_add] -overload vector_append [bitvector_concat] +overload append [bitvector_concat] val (bit[3], bit[3]) -> bit[3] effect pure test diff --git a/test/typecheck/pass/vector_append.sail b/test/typecheck/pass/vector_append.sail index 17db3fbd..df610fb1 100644 --- a/test/typecheck/pass/vector_append.sail +++ b/test/typecheck/pass/vector_append.sail @@ -1,14 +1,14 @@ val extern forall Nat 'n1, Nat 'l1, Nat 'n2, Nat 'l2, Order 'o, 'l1 >= 0, 'l2 >= 0. - (vector<'n1,'l1,'o,bit>, vector<'n2,'l2,'o,bit>) -> vector<'n1,'l1 + 'l2,'o,bit> effect pure vector_append = "bitvector_concat" + (vector<'n1,'l1,'o,bit>, vector<'n2,'l2,'o,bit>) -> vector<'n1,'l1 + 'l2,'o,bit> effect pure append = "bitvector_concat" default Order inc val (bit[4], bit[4]) -> bit[8] effect pure test - + function bit[8] test (v1, v2) = { - zv := vector_append(v1, v2); + zv := append(v1, v2); zv := v1 : v2; zv } -- cgit v1.2.3 From 3914be09d200eb92ed1e317123f56667d597b5a7 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Wed, 13 Sep 2017 17:19:13 +0100 Subject: Fix a regression when writing to a register via a reference in a vector such as GPR This was wrongly translated as an update of the vector of references. --- src/Makefile | 2 +- src/ast_util.ml | 20 +++++++++++++++ src/ast_util.mli | 3 +++ src/pretty_print_lem.ml | 19 +++++++++++--- src/pretty_print_lem_ast.ml | 2 +- src/rewriter.ml | 62 +++++++++++++++++++-------------------------- 6 files changed, 66 insertions(+), 42 deletions(-) diff --git a/src/Makefile b/src/Makefile index 6cfcf874..1bac0b71 100644 --- a/src/Makefile +++ b/src/Makefile @@ -177,7 +177,7 @@ _build/cheri_embed_types_sequential.lem: $(CHERI_SAILS) ./sail.native _build/Cheri_embed_sequential.thy: _build/cheri_embed_types_sequential.lem cd _build ;\ - lem -isa -outdir . ../lem_interp/sail_impl_base.lem ../gen_lib/state.lem $(MIPS_SAIL_DIR)/mips_extras_embed_sequential.lem cheri_embed_types_sequential.lem cheri_embed_sequential.lem + lem -isa -outdir . -lib ../lem_interp -lib ../gen_lib $(MIPS_SAIL_DIR)/mips_extras_embed_sequential.lem cheri_embed_types_sequential.lem cheri_embed_sequential.lem _build/mips_all.sail: $(MIPS_SAILS) cat $(MIPS_SAILS) > $@ diff --git a/src/ast_util.ml b/src/ast_util.ml index aef1a05d..2f630021 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -618,6 +618,22 @@ let rec simplify_nexp (Nexp_aux (nexp, l)) = | Nexp_exp of nexp (* exponential *) | Nexp_neg of nexp (* For internal use *) *) +let rec lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = + let rewrap e_aux = E_aux (e_aux, annot) in + match lexp_aux with + | LEXP_id id | LEXP_cast (_, id) -> rewrap (E_id id) + | LEXP_tup les -> + let get_id (LEXP_aux(lexp,((l,_) as annot)) as le) = match lexp with + | LEXP_id id | LEXP_cast (_, id) -> E_aux (E_id id, annot) + | _ -> + raise (Reporting_basic.err_unreachable l + ("Unsupported sub-lexp " ^ string_of_lexp le ^ " in tuple")) in + rewrap (E_tuple (List.map get_id les)) + | LEXP_vector (lexp, e) -> rewrap (E_vector_access (lexp_to_exp lexp, e)) + | LEXP_vector_range (lexp, e1, e2) -> rewrap (E_vector_subrange (lexp_to_exp lexp, e1, e2)) + | LEXP_field (lexp, id) -> rewrap (E_field (lexp_to_exp lexp, id)) + | LEXP_memory (id, exps) -> rewrap (E_app (id, exps)) + let rec is_number (Typ_aux (t,_)) = match t with | Typ_app (Id_aux (Id "range", _),_) @@ -625,6 +641,10 @@ let rec is_number (Typ_aux (t,_)) = | Typ_app (Id_aux (Id "atom", _),_) -> true | _ -> false +let is_reftyp (Typ_aux (typ_aux, _)) = match typ_aux with + | Typ_app (id, _) -> string_of_id id = "register" || string_of_id id = "reg" + | _ -> false + let rec is_vector_typ = function | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_;_]), _) -> true | Typ_aux (Typ_app (Id_aux (Id "register",_), [Typ_arg_aux (Typ_arg_typ rtyp,_)]), _) -> diff --git a/src/ast_util.mli b/src/ast_util.mli index 6164fc17..246e0ebd 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -203,7 +203,10 @@ val nexp_identical : nexp -> nexp -> bool val is_nexp_constant : nexp -> bool val simplify_nexp : nexp -> nexp +val lexp_to_exp : 'a lexp -> 'a exp + val is_number : typ -> bool +val is_reftyp : typ -> bool val is_vector_typ : typ -> bool val is_bit_typ : typ -> bool val is_bitvector_typ : typ -> bool diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 5e0d39a0..e2c8c0ac 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -418,10 +418,21 @@ let doc_exp_lem, doc_let_lem = (align (doc_lexp_deref_lem sequential mwords early_ret le ^^ space ^^ parens (string "update_reg_field_bit" ^/^ field_ref ^/^ expY e2) ^/^ expY e))) | _ -> - liftR ((prefix 2 1) - (string "update_reg") - (doc_lexp_deref_lem sequential mwords early_ret le ^^ space ^^ - parens (string "update_reg_bit" ^/^ expY e2) ^/^ expY e)) + (match le with + | LEXP_aux (_, (_, Some (_, Typ_aux (Typ_app (vector, [_; _; _; Typ_arg_aux (Typ_arg_typ etyp, _)]), _), _))) + when is_reftyp etyp && string_of_id vector = "vector" -> + (* Special case vectors of register references *) + let deref = + parens (separate space [ + string "access"; + expY (lexp_to_exp le); + expY e2 + ]) in + liftR ((prefix 2 1) (string "write_reg") (deref ^/^ expY e)) + | _ -> + liftR ((prefix 2 1) (string "update_reg") + (doc_lexp_deref_lem sequential mwords early_ret le ^^ space ^^ + parens (string "update_reg_bit" ^/^ expY e2) ^/^ expY e))) ) (* | LEXP_field (le,id) when is_bit_typ t -> liftR ((prefix 2 1) diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 68745bf9..73f06d1a 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -210,7 +210,7 @@ and pp_format_typ_arg_lem (Typ_arg_aux(t,l)) = (match t with | Typ_arg_typ(t) -> "(Typ_arg_typ " ^ pp_format_typ_lem t ^ ")" | Typ_arg_nexp(n) -> "(Typ_arg_nexp " ^ pp_format_nexp_lem n ^ ")" - | Typ_arg_order(o) -> "(Typ_arg_order " ^ pp_format_ord_lem o ^ ")") ^ + | Typ_arg_order(o) -> "(Typ_arg_order " ^ pp_format_ord_lem o ^ ")") ^ " " ^ (pp_format_l_lem l) ^ ")" and pp_format_nexp_constraint_lem (NC_aux(nc,l)) = "(NC_aux " ^ diff --git a/src/rewriter.ml b/src/rewriter.ml index 78b29200..d6a6aa2f 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -2209,29 +2209,19 @@ let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with | Some (_, _, eff) -> effectful_effs eff | _ -> false -let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = match lexp with - | LEXP_id id | LEXP_cast (_, id) -> - (le, E_aux (E_id id, annot), (fun exp -> exp)) - | LEXP_tup les -> - let get_id (LEXP_aux(lexp,((l,_) as annot)) as le) = match lexp with - | LEXP_id id | LEXP_cast (_, id) -> E_aux (E_id id, annot) - | _ -> - raise (Reporting_basic.err_unreachable l - ("Unsupported sub-lexp " ^ string_of_lexp le ^ " in tuple")) in - (le, E_aux (E_tuple (List.map get_id les), annot), (fun exp -> exp)) +let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = + match lexp with + | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) | LEXP_vector (lexp, e) -> - let (lexp, access, rexp) = rewrite_local_lexp lexp in - (lexp, E_aux (E_vector_access (access, e), annot), - (fun exp -> rexp (E_aux (E_vector_update (access, e, exp), annot)))) + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) | LEXP_vector_range (lexp, e1, e2) -> - let (lexp, access, rexp) = rewrite_local_lexp lexp in - (lexp, E_aux (E_vector_subrange (access, e1, e2), annot), - (fun exp -> rexp (E_aux (E_vector_update_subrange (access, e1, e2, exp), annot)))) + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) | LEXP_field (lexp, id) -> - let (lexp, access, rexp) = rewrite_local_lexp lexp in + let (lhs, rhs) = rewrite_local_lexp lexp in let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in - (lexp, E_aux (E_field (access, id), annot), - (fun exp -> rexp (E_aux (E_record_update (access, field_update exp), annot)))) + (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), annot)))) | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) (*Expects to be called after rewrite_defs; thus the following should not appear: @@ -2250,7 +2240,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f | [] -> [] | (E_aux(E_assign(le,e), ((l, Some (env,typ,eff)) as annot)) as exp)::exps when lexp_is_local_intro le env && not (lexp_is_effectful le) -> - let (le', _, re') = rewrite_local_lexp le in + let (le', re') = rewrite_local_lexp le in let e' = re' (rewrite_base e) in let exps' = walker exps in let effects = union_eff_exps exps' in @@ -2303,7 +2293,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f rewrap (E_block (walker exps)) | E_assign(le,e) when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> - let (le', _, re') = rewrite_local_lexp le in + let (le', re') = rewrite_local_lexp le in let e' = re' (rewrite_base e) in let block = E_aux (E_block [], simple_annot l unit_typ) in fix_eff_exp (E_aux (E_internal_let(le', e', block), annot)) @@ -2635,7 +2625,7 @@ let rewrite_simple_assignments defs = let env = env_of_annot annot in match e_aux with | E_assign (lexp, exp) -> - let (lexp, _, rhs) = rewrite_local_lexp lexp in + let (lexp, rhs) = rewrite_local_lexp lexp in let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in check_exp env assign unit_typ | _ -> E_aux (e_aux, annot) @@ -2977,9 +2967,9 @@ let rewrite_defs_effectful_let_expressions = let e_let (lb,body) = match lb with | LB_aux (LB_val_implicit (P_aux (P_wild, _), E_aux (E_assign ((LEXP_aux (_, annot) as le), exp), _)), _) - when lexp_is_local le (env_of_annot annot) -> + when lexp_is_local le (env_of_annot annot) && not (lexp_is_effectful le) -> (* Rewrite assignments to local variables into let bindings *) - let (lhs, _, rhs) = rewrite_local_lexp le in + let (lhs, rhs) = rewrite_local_lexp le in E_let (LB_aux (LB_val_implicit (pat_of_local_lexp lhs, rhs exp), annot), body) | LB_aux (LB_val_explicit (_,pat,exp'),annot') | LB_aux (LB_val_implicit (pat,exp'),annot') -> @@ -3023,28 +3013,28 @@ let eqidtyp (id1,_) (id2,_) = name1 = name2 let find_introduced_vars exp = - let lEXP_aux ((ids,lexp),annot) = - let ids = match lexp, annot with - | LEXP_id id, (_, Some (env, _, _)) - | LEXP_cast (_, id), (_, Some (env, _, _)) + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_internal_let (LEXP_aux (LEXP_id id, _), _, _), (_, Some (env, _, _)) + | E_internal_let (LEXP_aux (LEXP_cast (_, id), _), _, _), (_, Some (env, _, _)) when id_is_unbound id env -> IdSet.add id ids | _ -> ids in - (ids, LEXP_aux (lexp, annot)) in + (ids, E_aux (e_aux, annot)) in fst (fold_exp - { (compute_exp_alg IdSet.empty IdSet.union) with lEXP_aux = lEXP_aux } exp) + { (compute_exp_alg IdSet.empty IdSet.union) with e_aux = e_aux } exp) let find_updated_vars exp = let intros = find_introduced_vars exp in - let lEXP_aux ((ids,lexp),annot) = - let ids = match lexp, annot with - | LEXP_id id, (_, Some (env, _, _)) - | LEXP_cast (_, id), (_, Some (env, _, _)) + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_assign (LEXP_aux (LEXP_id id, _), _), (_, Some (env, _, _)) + | E_assign (LEXP_aux (LEXP_cast (_, id), _), _), (_, Some (env, _, _)) when id_is_local_var id env && not (IdSet.mem id intros) -> (id, annot) :: ids | _ -> ids in - (ids, LEXP_aux (lexp, annot)) in + (ids, E_aux (e_aux, annot)) in dedup eqidtyp (fst (fold_exp - { (compute_exp_alg [] (@)) with lEXP_aux = lEXP_aux } exp)) + { (compute_exp_alg [] (@)) with e_aux = e_aux } exp)) let swaptyp typ (l,tannot) = match tannot with | Some (env, typ', eff) -> (l, Some (env, typ, eff)) -- cgit v1.2.3 From cb90735550541fa6752aaad82ff809d84e6c5f88 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Wed, 13 Sep 2017 19:03:31 +0100 Subject: Fix some more test cases --- lib/prelude_wrappers.sail | 4 ++-- src/pretty_print_lem.ml | 23 ++++++++++++++++------- src/rewriter.ml | 15 ++++++++++++++- test/typecheck/pass/lexp_memory.sail | 5 ++++- test/typecheck/pass/mips_CP0Cause_BD_assign1.sail | 9 +++++++-- test/typecheck/pass/mips_CP0Cause_BD_assign2.sail | 9 +++++++-- test/typecheck/pass/set_mark.sail | 7 ++++++- test/typecheck/pass/set_mark2.sail | 8 +++++++- test/typecheck/pass/varity.sail | 4 ++++ test/typecheck/pass/vector_synonym_cast.sail | 2 +- 10 files changed, 68 insertions(+), 18 deletions(-) diff --git a/lib/prelude_wrappers.sail b/lib/prelude_wrappers.sail index 4568f6ab..1d85b4ff 100644 --- a/lib/prelude_wrappers.sail +++ b/lib/prelude_wrappers.sail @@ -1,5 +1,5 @@ -val extern forall Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec -val extern forall Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,inc,bit> effect pure to_vec_inc +val extern forall Num 'l, Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec +val extern forall Num 'l, Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,inc,bit> effect pure to_vec_inc function forall Num 'n, Num 'm. (vector<'m - 1,'m,dec,bit>) to_vec (n) = to_vec_dec ((sizeof 'm) - 1, sizeof 'm, n) function forall Num 'm. (vector<'m - 1,'m,dec,bit>) to_svec (n) = to_vec_dec ((sizeof 'm) - 1, sizeof 'm, n) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index e2c8c0ac..1bfb19aa 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -530,14 +530,19 @@ let doc_exp_lem, doc_let_lem = if contains_bitvector_typ t && not (contains_t_pp_var t) then (align epp ^^ (doc_tannot_lem sequential mwords (effectful eff) t), true) else (epp, aexp_needed) in - if aexp_needed then parens (align taepp) else taepp + if aexp_needed then parens (align taepp) else taepp*) | Id_aux (Id "length",_) -> + (* Another temporary hack: The sizeof rewriting introduces calls to + "length", and the disambiguation between the length function on + bitvectors and vectors of other element types should be done by + the type checker, but type checking after rewriting steps is + currently broken. *) let [arg] = args in let targ = typ_of arg in - let call = if is_bitvector_typ targ then "bvlength" else "length" in + let call = if mwords && is_bitvector_typ targ then "bvlength" else "length" in let epp = separate space [string call;expY arg] in if aexp_needed then parens (align epp) else epp - | Id_aux (Id "bool_not", _) -> + (*)| Id_aux (Id "bool_not", _) -> let [a] = args in let epp = align (string "~" ^^ expY a) in if aexp_needed then parens (align epp) else epp *) @@ -709,7 +714,9 @@ let doc_exp_lem, doc_let_lem = | _ -> parens (separate_map comma expN exps)) | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> let recordtyp = match annot with - | Some (env, Typ_aux (Typ_id tid,_), _) when Env.is_record tid env -> + | Some (env, Typ_aux (Typ_id tid,_), _) + | Some (env, Typ_aux (Typ_app (tid, _), _), _) + when Env.is_record tid env -> tid | _ -> raise (report l ("cannot get record type from annot " ^ string_of_annot annot ^ " of exp " ^ string_of_exp full_exp)) in let epp = anglebars (space ^^ (align (separate_map @@ -717,9 +724,11 @@ let doc_exp_lem, doc_let_lem = (doc_fexp sequential mwords early_ret recordtyp) fexps)) ^^ space) in if aexp_needed then parens epp else epp | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> - let (E_aux (_, (_, eannot))) = e in - let recordtyp = match eannot with - | Some (env, Typ_aux (Typ_id tid,_), _) when Env.is_record tid env -> + (* let (E_aux (_, (_, eannot))) = e in *) + let recordtyp = match annot with + | Some (env, Typ_aux (Typ_id tid,_), _) + | Some (env, Typ_aux (Typ_app (tid, _), _), _) + when Env.is_record tid env -> tid | _ -> raise (report l ("cannot get record type from annot " ^ string_of_annot annot ^ " of exp " ^ string_of_exp full_exp)) in anglebars (doc_op (string "with") (expY e) (separate_map semi_sp (doc_fexp sequential mwords early_ret recordtyp) fexps)) diff --git a/src/rewriter.ml b/src/rewriter.ml index d6a6aa2f..62ea6be7 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -2220,8 +2220,9 @@ let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) | LEXP_field (lexp, id) -> let (lhs, rhs) = rewrite_local_lexp lexp in + let (LEXP_aux (_, recannot)) = lexp in let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in - (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), annot)))) + (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), recannot)))) | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) (*Expects to be called after rewrite_defs; thus the following should not appear: @@ -2946,6 +2947,18 @@ let rewrite_defs_letbind_effects = let _ = reset_fresh_name_counter () in FCL_aux (FCL_Funcl (id,pat,n_exp_term newreturn exp),annot) in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in + let rewrite_def rewriters = function + | DEF_val (LB_aux (lb, annot)) -> + let rewrap lb = DEF_val (LB_aux (lb, annot)) in + begin + match lb with + | LB_val_implicit (pat, exp) -> + rewrap (LB_val_implicit (pat, n_exp_term (effectful exp) exp)) + | LB_val_explicit (ts, pat, exp) -> + rewrap (LB_val_explicit (ts, pat, n_exp_term (effectful exp) exp)) + end + | DEF_fundef fdef -> DEF_fundef (rewrite_fun rewriters fdef) + | d -> d in rewrite_defs_base {rewrite_exp = rewrite_exp ; rewrite_pat = rewrite_pat diff --git a/test/typecheck/pass/lexp_memory.sail b/test/typecheck/pass/lexp_memory.sail index 83313ac7..cc84130f 100644 --- a/test/typecheck/pass/lexp_memory.sail +++ b/test/typecheck/pass/lexp_memory.sail @@ -48,7 +48,10 @@ val forall Num 'n, Num 'm, Order 'ord. (vector<'n,'m,'ord,bit>, vector<'n,'m,'or overload (deinfix ==) [eq_vec] -val cast forall Nat 'n, Nat 'l, Order 'ord. [|0:1|] -> vector<'n,'l,'ord,bit> effect pure cast_01_vec +val extern forall Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec + +val cast forall Nat 'n, Nat 'l. [|0:1|] -> vector<'n,'l,dec,bit> effect pure cast_01_vec +function forall Num 'n, Num 'l. (vector<'n,'l,dec,bit>) cast_01_vec i = to_vec_dec (sizeof 'n, sizeof 'l, i) val cast forall Nat 'n, Nat 'm, Order 'ord. vector<'n,'m,'ord,bit> -> [|0:2**'m - 1|] effect pure unsigned val cast forall Type 'a. register<'a> -> 'a effect {rreg} reg_deref diff --git a/test/typecheck/pass/mips_CP0Cause_BD_assign1.sail b/test/typecheck/pass/mips_CP0Cause_BD_assign1.sail index 7808b2c0..0160dd8a 100644 --- a/test/typecheck/pass/mips_CP0Cause_BD_assign1.sail +++ b/test/typecheck/pass/mips_CP0Cause_BD_assign1.sail @@ -1,5 +1,10 @@ -val cast forall Nat 'n, Order 'ord. [:1:] -> vector<'n,1,'ord,bit> effect pure cast_1_vec -val cast forall Nat 'n, Order 'ord. [:0:] -> vector<'n,1,'ord,bit> effect pure cast_0_vec +val cast forall Num 'n. [:1:] -> vector<'n,1,dec,bit> effect pure cast_1_vec +val cast forall Num 'n. [:0:] -> vector<'n,1,dec,bit> effect pure cast_0_vec + +val extern forall Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec + +function forall Num 'n. (vector<'n,1,dec,bit>) cast_1_vec i = to_vec_dec (sizeof 'n, 1, i) +function forall Num 'n. (vector<'n,1,dec,bit>) cast_0_vec i = to_vec_dec (sizeof 'n, 1, i) default Order dec diff --git a/test/typecheck/pass/mips_CP0Cause_BD_assign2.sail b/test/typecheck/pass/mips_CP0Cause_BD_assign2.sail index 26f161e2..847bca60 100644 --- a/test/typecheck/pass/mips_CP0Cause_BD_assign2.sail +++ b/test/typecheck/pass/mips_CP0Cause_BD_assign2.sail @@ -1,6 +1,11 @@ -val cast forall Nat 'n, Order 'ord. [:1:] -> vector<'n,1,'ord,bit> effect pure cast_1_vec -val cast forall Nat 'n, Order 'ord. [:0:] -> vector<'n,1,'ord,bit> effect pure cast_0_vec +val cast forall Num 'n. [:1:] -> vector<'n,1,dec,bit> effect pure cast_1_vec +val cast forall Num 'n. [:0:] -> vector<'n,1,dec,bit> effect pure cast_0_vec +val extern forall Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec + +function forall Num 'n. (vector<'n,1,dec,bit>) cast_1_vec i = to_vec_dec (sizeof 'n, 1, i) +function forall Num 'n. (vector<'n,1,dec,bit>) cast_0_vec i = to_vec_dec (sizeof 'n, 1, i) + default Order dec typedef CauseReg = register bits [ 31 : 0 ] { diff --git a/test/typecheck/pass/set_mark.sail b/test/typecheck/pass/set_mark.sail index 7bc7370b..af0b5ba2 100644 --- a/test/typecheck/pass/set_mark.sail +++ b/test/typecheck/pass/set_mark.sail @@ -1,5 +1,10 @@ -val cast forall Num 'n, Num 'm, Order 'ord. [:0:] -> vector<'n,'m,'ord,bit> effect pure cast_0_vec +val extern forall Num 'l, Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec + +val cast forall Num 'n, Num 'm. [:0:] -> vector<'n,'m,dec,bit> effect pure cast_0_vec +function forall Num 'n, Num 'm. (vector<'n,'m,dec,bit>) cast_0_vec i = to_vec_dec (sizeof 'n, sizeof 'm, i) + +default Order dec function forall Num 'N, 'N IN {32}. bit['N] Foo32( (bit['N]) x) = x diff --git a/test/typecheck/pass/set_mark2.sail b/test/typecheck/pass/set_mark2.sail index cabfb1af..591c17ad 100644 --- a/test/typecheck/pass/set_mark2.sail +++ b/test/typecheck/pass/set_mark2.sail @@ -1,4 +1,10 @@ -val cast forall Num 'n, Num 'm, Order 'ord. [:0:] -> vector<'n,'m,'ord,bit> effect pure cast_0_vec + +val extern forall Num 'l, Num 'm. ([:'l:], [:'m:], int) -> vector<'l,'m,dec,bit> effect pure to_vec_dec + +val cast forall Num 'n, Num 'm. [:0:] -> vector<'n,'m,dec,bit> effect pure cast_0_vec +function forall Num 'n, Num 'm. (vector<'n,'m,dec,bit>) cast_0_vec i = to_vec_dec (sizeof 'n, sizeof 'm, i) + +default Order dec function forall Nat 'N, 'N IN {32, 64}. bit['N] Foo32( (bit['N]) x) = x diff --git a/test/typecheck/pass/varity.sail b/test/typecheck/pass/varity.sail index d196f777..750d70eb 100644 --- a/test/typecheck/pass/varity.sail +++ b/test/typecheck/pass/varity.sail @@ -3,6 +3,10 @@ val int -> unit effect pure f1 val (int, int) -> unit effect pure f2 val (int, int, int) -> unit effect pure f3 +function f1 (i1) = () +function f2 (i1, i2) = () +function f3 (i1, i2, i3) = () + overload f [f1; f2; f3] val unit -> unit effect pure test diff --git a/test/typecheck/pass/vector_synonym_cast.sail b/test/typecheck/pass/vector_synonym_cast.sail index f1de42e9..bd0acaa6 100644 --- a/test/typecheck/pass/vector_synonym_cast.sail +++ b/test/typecheck/pass/vector_synonym_cast.sail @@ -1,7 +1,7 @@ typedef vecsyn = vector<0,1,dec,bit> -val cast vector<1,1,dec,bit> -> vector<0,1,dec,bit> effect pure adjust_dec +val cast vector<1,1,dec,bit> -> vector<0,1,dec,bit> effect pure norm_dec val vector<1,1,dec,bit> -> vecsyn effect pure test -- cgit v1.2.3 From 4e7a568bb57337d41dda893044ed84b66e62752f Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Thu, 14 Sep 2017 13:55:17 +0100 Subject: Fix bug in topological sorting --- src/rewriter.ml | 2 +- src/spec_analysis.ml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/rewriter.ml b/src/rewriter.ml index 62ea6be7..fed8408d 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -3429,7 +3429,7 @@ let rewrite_defs_remove_e_assign = let recheck_defs defs = fst (check initial_env defs) let rewrite_defs_lem =[ - (* top_sort_defs; *) + top_sort_defs; rewrite_trivial_sizeof; rewrite_sizeof; rewrite_defs_remove_vector_concat; diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 5281ef27..d349037e 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -350,6 +350,7 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. b,used,set | E_exit e -> fv_of_exp consider_var bound used set e | E_assert(c,m) -> list_fv bound used set [c;m] + | E_return e -> fv_of_exp consider_var bound used set e | _ -> bound,used,set and fv_of_pes consider_var bound used set pes = -- cgit v1.2.3