diff options
| author | Robert Norton | 2016-04-13 15:49:06 +0100 |
|---|---|---|
| committer | Robert Norton | 2016-04-13 16:04:01 +0100 |
| commit | f9345ad67348f715754a8d6aba9510fa55aeb74d (patch) | |
| tree | a9a19a0ee390af03ad6968b37bcd1ce15b338ff0 /src | |
| parent | b5b74f9fca5a760cb388b1f9ed7873f73b983c45 (diff) | |
Copy run_with_elf to make run_with_elf_cheri and revert run_with_elf to mips version. Temporary 'solution' to building mips and cheri builds until proper factorising can take place.
Diffstat (limited to 'src')
| -rw-r--r-- | src/Makefile | 7 | ||||
| -rw-r--r-- | src/lem_interp/run_with_elf.ml | 41 | ||||
| -rw-r--r-- | src/lem_interp/run_with_elf_cheri.ml | 1094 |
3 files changed, 1101 insertions, 41 deletions
diff --git a/src/Makefile b/src/Makefile index afaf28d3..c010b992 100644 --- a/src/Makefile +++ b/src/Makefile @@ -39,6 +39,9 @@ _build/mips_extras.lem: ../mips/mips_extras.lem _build/run_with_elf.ml: lem_interp/run_with_elf.ml mkdir -p _build cp $< $@ +_build/run_with_elf_cheri.ml: lem_interp/run_with_elf_cheri.ml + mkdir -p _build + cp $< $@ _build/mips.lem: $(MIPS_SAILS) ./sail.native mkdir -p _build @@ -56,8 +59,8 @@ _build/cheri.lem: $(CHERI_SAILS) ./sail.native run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(LEMLIBOCAML)/dependencies/zarith -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(LEMLIBOCAML)/dependencies/zarith/zarith.cmxa $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native -run_cheri.native: _build/cheri.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter - env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(LEMLIBOCAML)/dependencies/zarith -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(LEMLIBOCAML)/dependencies/zarith/zarith.cmxa $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/cheri.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_cheri.native +run_cheri.native: _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml interpreter + env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(LEMLIBOCAML)/dependencies/zarith -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(LEMLIBOCAML)/dependencies/zarith/zarith.cmxa $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml -o run_cheri.native mips: elf run_mips.native diff --git a/src/lem_interp/run_with_elf.ml b/src/lem_interp/run_with_elf.ml index a7d1c1de..75ed3b33 100644 --- a/src/lem_interp/run_with_elf.ml +++ b/src/lem_interp/run_with_elf.ml @@ -495,43 +495,6 @@ let mips_register_data_all = [ ("CP0LLBit", (D_decreasing, 1, 0)); ] -let cheri_register_data_all = mips_register_data_all @ [ - ("CapCause", (D_decreasing, 16, 15)); - ("PCC", (D_decreasing, 257, 256)); - ("C00", (D_decreasing, 257, 256)); - ("C01", (D_decreasing, 257, 256)); - ("C02", (D_decreasing, 257, 256)); - ("C03", (D_decreasing, 257, 256)); - ("C04", (D_decreasing, 257, 256)); - ("C05", (D_decreasing, 257, 256)); - ("C06", (D_decreasing, 257, 256)); - ("C07", (D_decreasing, 257, 256)); - ("C08", (D_decreasing, 257, 256)); - ("C09", (D_decreasing, 257, 256)); - ("C10", (D_decreasing, 257, 256)); - ("C11", (D_decreasing, 257, 256)); - ("C12", (D_decreasing, 257, 256)); - ("C13", (D_decreasing, 257, 256)); - ("C14", (D_decreasing, 257, 256)); - ("C15", (D_decreasing, 257, 256)); - ("C16", (D_decreasing, 257, 256)); - ("C17", (D_decreasing, 257, 256)); - ("C18", (D_decreasing, 257, 256)); - ("C19", (D_decreasing, 257, 256)); - ("C20", (D_decreasing, 257, 256)); - ("C21", (D_decreasing, 257, 256)); - ("C22", (D_decreasing, 257, 256)); - ("C23", (D_decreasing, 257, 256)); - ("C24", (D_decreasing, 257, 256)); - ("C25", (D_decreasing, 257, 256)); - ("C26", (D_decreasing, 257, 256)); - ("C27", (D_decreasing, 257, 256)); - ("C28", (D_decreasing, 257, 256)); - ("C29", (D_decreasing, 257, 256)); - ("C30", (D_decreasing, 257, 256)); - ("C31", (D_decreasing, 257, 256)); -] - let initial_stack_and_reg_data_of_MIPS_elf_file e_entry all_data_memory = let initial_stack_data = [] in let initial_register_abi_data : (string * Interp_interface.register_value) list = [] in @@ -632,7 +595,7 @@ let initial_system_state_of_elf_file name = let (initial_stack_data, initial_register_abi_data) = initial_stack_and_reg_data_of_MIPS_elf_file e_entry !data_mem in - (Cheri.defs, + (Mips.defs, (Mips_extras.read_memory_functions, Mips_extras.memory_writes, [], @@ -644,7 +607,7 @@ let initial_system_state_of_elf_file name = startaddr, initial_stack_data, initial_register_abi_data, - cheri_register_data_all) + mips_register_data_all) | _ -> failwith (Printf.sprintf "Sail sequential interpreter can't handle the e_machine value %s, only EM_PPC64, EM_AARCH64 and EM_MIPS are supported." (Nat_big_num.to_string e_machine)) in diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml new file mode 100644 index 00000000..5e7986c2 --- /dev/null +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -0,0 +1,1094 @@ +open Printf ;; +open Format ;; +open Big_int ;; +open Interp_ast ;; +open Interp_interface ;; +open Interp_inter_imp ;; +open Run_interp_model ;; + +open Sail_interface ;; + +module StringMap = Map.Make(String) + +let file = ref "" ;; + +let rec foldli f acc ?(i=0) = function + | [] -> acc + | x::xs -> foldli f (f i acc x) ~i:(i+1) xs +;; + +let endian = ref E_big_endian ;; + +let hex_to_big_int s = big_int_of_int64 (Int64.of_string s) ;; + +let data_mem = (ref Mem.empty : (memory_byte Run_interp_model.Mem.t) ref) ;; +let prog_mem = (ref Mem.empty : (memory_byte Run_interp_model.Mem.t) ref) ;; +let tag_mem = (ref Mem.empty : (memory_byte Run_interp_model.Mem.t) ref);; +let reg = ref Reg.empty ;; + +let add_mem byte addr mem = + assert(byte >= 0 && byte < 256); + (*Printf.printf "add_mem %s: 0x%02x\n" (Uint64.to_string_hex (Uint64.of_string (Nat_big_num.to_string addr))) byte;*) + let mem_byte = memory_byte_of_int byte in + mem := Mem.add addr mem_byte !mem + +let get_reg reg name = + let reg_content = Reg.find name reg in reg_content + +let rec load_memory_segment' (bytes,addr) mem = + match bytes with + | [] -> () + | byte::bytes' -> + let data_byte = Char.code byte in + let addr' = Nat_big_num.succ addr in + begin add_mem data_byte addr mem; + load_memory_segment' (bytes',addr') mem + end + +let rec load_memory_segment (segment: Elf_interpreted_segment.elf64_interpreted_segment) mem = + let (Byte_sequence.Sequence bytes) = segment.Elf_interpreted_segment.elf64_segment_body in + let addr = segment.Elf_interpreted_segment.elf64_segment_paddr in + load_memory_segment' (bytes,addr) mem + + +let rec load_memory_segments segments = + begin match segments with + | [] -> () + | segment::segments' -> + let (x,w,r) = segment.Elf_interpreted_segment.elf64_segment_flags in + begin + (if x + then load_memory_segment segment prog_mem + else load_memory_segment segment data_mem); + load_memory_segments segments' + end + end + +let rec read_mem mem address length = + if length = 0 + then [] + else + let byte = + try Mem.find address mem with + | Not_found -> failwith "start address not found" + in + byte :: (read_mem mem (Nat_big_num.succ address) (length - 1)) + +let register_state_zero register_data rbn : register_value = + let (dir,width,start_index) = + try List.assoc rbn register_data with + | Not_found -> failwith ("register_state_zero lookup failed (" ^ rbn) + in register_value_zeros dir width start_index + +type model = PPC | AArch64 | MIPS +(* +let ppc_register_data_all = [ + (*Pseudo registers*) + ("CIA", (D_increasing, 64, 0)); + ("NIA", (D_increasing, 64, 0)); + ("mode64bit", (D_increasing, 1, 0)); + ("bigendianmode", (D_increasing, 1, 0)); + (* special registers *) + ("CR", (D_increasing, 32, 32)); + ("CTR", (D_increasing, 64, 0 )); + ("LR", (D_increasing, 64, 0 )); + ("XER", (D_increasing, 64, 0 )); + ("VRSAVE",(D_increasing, 32, 32)); + ("FPSCR", (D_increasing, 64, 0 )); + ("VSCR", (D_increasing, 32, 96)); + + (* general purpose registers *) + ("GPR0", (D_increasing, 64, 0 )); + ("GPR1", (D_increasing, 64, 0 )); + ("GPR2", (D_increasing, 64, 0 )); + ("GPR3", (D_increasing, 64, 0 )); + ("GPR4", (D_increasing, 64, 0 )); + ("GPR5", (D_increasing, 64, 0 )); + ("GPR6", (D_increasing, 64, 0 )); + ("GPR7", (D_increasing, 64, 0 )); + ("GPR8", (D_increasing, 64, 0 )); + ("GPR9", (D_increasing, 64, 0 )); + ("GPR10", (D_increasing, 64, 0 )); + ("GPR11", (D_increasing, 64, 0 )); + ("GPR12", (D_increasing, 64, 0 )); + ("GPR13", (D_increasing, 64, 0 )); + ("GPR14", (D_increasing, 64, 0 )); + ("GPR15", (D_increasing, 64, 0 )); + ("GPR16", (D_increasing, 64, 0 )); + ("GPR17", (D_increasing, 64, 0 )); + ("GPR18", (D_increasing, 64, 0 )); + ("GPR19", (D_increasing, 64, 0 )); + ("GPR20", (D_increasing, 64, 0 )); + ("GPR21", (D_increasing, 64, 0 )); + ("GPR22", (D_increasing, 64, 0 )); + ("GPR23", (D_increasing, 64, 0 )); + ("GPR24", (D_increasing, 64, 0 )); + ("GPR25", (D_increasing, 64, 0 )); + ("GPR26", (D_increasing, 64, 0 )); + ("GPR27", (D_increasing, 64, 0 )); + ("GPR28", (D_increasing, 64, 0 )); + ("GPR29", (D_increasing, 64, 0 )); + ("GPR30", (D_increasing, 64, 0 )); + ("GPR31", (D_increasing, 64, 0 )); + (* vector registers *) + ("VR0", (D_increasing, 128, 0 )); + ("VR1", (D_increasing, 128, 0 )); + ("VR2", (D_increasing, 128, 0 )); + ("VR3", (D_increasing, 128, 0 )); + ("VR4", (D_increasing, 128, 0 )); + ("VR5", (D_increasing, 128, 0 )); + ("VR6", (D_increasing, 128, 0 )); + ("VR7", (D_increasing, 128, 0 )); + ("VR8", (D_increasing, 128, 0 )); + ("VR9", (D_increasing, 128, 0 )); + ("VR10", (D_increasing, 128, 0 )); + ("VR11", (D_increasing, 128, 0 )); + ("VR12", (D_increasing, 128, 0 )); + ("VR13", (D_increasing, 128, 0 )); + ("VR14", (D_increasing, 128, 0 )); + ("VR15", (D_increasing, 128, 0 )); + ("VR16", (D_increasing, 128, 0 )); + ("VR17", (D_increasing, 128, 0 )); + ("VR18", (D_increasing, 128, 0 )); + ("VR19", (D_increasing, 128, 0 )); + ("VR20", (D_increasing, 128, 0 )); + ("VR21", (D_increasing, 128, 0 )); + ("VR22", (D_increasing, 128, 0 )); + ("VR23", (D_increasing, 128, 0 )); + ("VR24", (D_increasing, 128, 0 )); + ("VR25", (D_increasing, 128, 0 )); + ("VR26", (D_increasing, 128, 0 )); + ("VR27", (D_increasing, 128, 0 )); + ("VR28", (D_increasing, 128, 0 )); + ("VR29", (D_increasing, 128, 0 )); + ("VR30", (D_increasing, 128, 0 )); + ("VR31", (D_increasing, 128, 0 )); + (* floating-point registers *) + ("FPR0", (D_increasing, 64, 0 )); + ("FPR1", (D_increasing, 64, 0 )); + ("FPR2", (D_increasing, 64, 0 )); + ("FPR3", (D_increasing, 64, 0 )); + ("FPR4", (D_increasing, 64, 0 )); + ("FPR5", (D_increasing, 64, 0 )); + ("FPR6", (D_increasing, 64, 0 )); + ("FPR7", (D_increasing, 64, 0 )); + ("FPR8", (D_increasing, 64, 0 )); + ("FPR9", (D_increasing, 64, 0 )); + ("FPR10", (D_increasing, 64, 0 )); + ("FPR11", (D_increasing, 64, 0 )); + ("FPR12", (D_increasing, 64, 0 )); + ("FPR13", (D_increasing, 64, 0 )); + ("FPR14", (D_increasing, 64, 0 )); + ("FPR15", (D_increasing, 64, 0 )); + ("FPR16", (D_increasing, 64, 0 )); + ("FPR17", (D_increasing, 64, 0 )); + ("FPR18", (D_increasing, 64, 0 )); + ("FPR19", (D_increasing, 64, 0 )); + ("FPR20", (D_increasing, 64, 0 )); + ("FPR21", (D_increasing, 64, 0 )); + ("FPR22", (D_increasing, 64, 0 )); + ("FPR23", (D_increasing, 64, 0 )); + ("FPR24", (D_increasing, 64, 0 )); + ("FPR25", (D_increasing, 64, 0 )); + ("FPR26", (D_increasing, 64, 0 )); + ("FPR27", (D_increasing, 64, 0 )); + ("FPR28", (D_increasing, 64, 0 )); + ("FPR29", (D_increasing, 64, 0 )); + ("FPR30", (D_increasing, 64, 0 )); + ("FPR31", (D_increasing, 64, 0 )); +] + +let initial_stack_and_reg_data_of_PPC_elf_file e_entry all_data_memory = + (* set up initial registers, per 3.4.1 of 64-bit PowerPC ELF Application Binary Interface Supplement 1.9 *) + + let auxiliary_vector_space = Nat_big_num.of_string "17592186042368" (*"0xffffffff800"*) in + (* notionally there should be at least an AT_NULL auxiliary vector entry there, but our examples will never read it *) + + (* take start of stack roughly where running gdb on hello5 on bim says it is*) + let initial_GPR1_stack_pointer = Nat_big_num.of_string "17592186040320" (*"0xffffffff000"*) in + let initial_GPR1_stack_pointer_value = + Interp_interface.register_value_of_integer 64 0 Interp_interface.D_increasing initial_GPR1_stack_pointer in + (* ELF says we need an initial zero doubleword there *) + let initial_stack_data = + (* the code actually uses the stack, both above and below, so we map a bit more memory*) + (* this is a fairly big but arbitrary chunk *) + (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in + [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) + (* this is the stack memory that test 1938 actually uses *) + [ ("initial_stack_data1", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128), + Lem_list.replicate 8 0 ); + ("initial_stack_data2", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 8), + Lem_list.replicate 8 0 ); + ("initial_stack_data3", Nat_big_num.add initial_GPR1_stack_pointer (Nat_big_num.of_int 16), + Lem_list.replicate 8 0 )] in + + (* read TOC from the second field of the function descriptor pointed to by e_entry*) + let initial_GPR2_TOC = + Interp_interface.register_value_of_address + (Interp_interface.address_of_byte_list + (List.map (fun b -> match b with Some b -> b | None -> failwith "Address had undefined") + (List.map byte_of_byte_lifted + (read_mem all_data_memory + (Nat_big_num.add (Nat_big_num.of_int 8) e_entry) 8)))) + Interp_interface.D_increasing in + (* these initial register values are all mandated to be zero, but that's handled by the generic zeroing below + let initial_GPR3_argc = (Nat_big_num.of_int 0) in + let initial_GPR4_argv = (Nat_big_num.of_int 0) in + let initial_GPR5_envp = (Nat_big_num.of_int 0) in + let initial_FPSCR = (Nat_big_num.of_int 0) in + *) + let initial_register_abi_data : (string * Interp_interface.register_value) list = + [ ("GPR1", initial_GPR1_stack_pointer_value); + ("GPR2", initial_GPR2_TOC); + (* + ("GPR3", initial_GPR3_argc); + ("GPR4", initial_GPR4_argv); + ("GPR5", initial_GPR5_envp); + ("FPSCR", initial_FPSCR); + *) + ] in + + (initial_stack_data, initial_register_abi_data) + + +let aarch64_reg bit_count name = (name, (D_decreasing, bit_count, bit_count - 1)) + +let aarch64_PC_data = [aarch64_reg 64 "_PC"] + +(* most of the PSTATE fields are aliases to other registers so they + don't appear here *) +let aarch64_PSTATE_data = [ + aarch64_reg 1 "PSTATE_nRW"; + aarch64_reg 1 "PSTATE_E"; + aarch64_reg 5 "PSTATE_M"; +] + +let aarch64_general_purpose_registers_data = [ + aarch64_reg 64 "R0"; + aarch64_reg 64 "R1"; + aarch64_reg 64 "R2"; + aarch64_reg 64 "R3"; + aarch64_reg 64 "R4"; + aarch64_reg 64 "R5"; + aarch64_reg 64 "R6"; + aarch64_reg 64 "R7"; + aarch64_reg 64 "R8"; + aarch64_reg 64 "R9"; + aarch64_reg 64 "R10"; + aarch64_reg 64 "R11"; + aarch64_reg 64 "R12"; + aarch64_reg 64 "R13"; + aarch64_reg 64 "R14"; + aarch64_reg 64 "R15"; + aarch64_reg 64 "R16"; + aarch64_reg 64 "R17"; + aarch64_reg 64 "R18"; + aarch64_reg 64 "R19"; + aarch64_reg 64 "R20"; + aarch64_reg 64 "R21"; + aarch64_reg 64 "R22"; + aarch64_reg 64 "R23"; + aarch64_reg 64 "R24"; + aarch64_reg 64 "R25"; + aarch64_reg 64 "R26"; + aarch64_reg 64 "R27"; + aarch64_reg 64 "R28"; + aarch64_reg 64 "R29"; + aarch64_reg 64 "R30"; +] + +let aarch64_SIMD_registers_data = [ + aarch64_reg 128 "V0"; + aarch64_reg 128 "V1"; + aarch64_reg 128 "V2"; + aarch64_reg 128 "V3"; + aarch64_reg 128 "V4"; + aarch64_reg 128 "V5"; + aarch64_reg 128 "V6"; + aarch64_reg 128 "V7"; + aarch64_reg 128 "V8"; + aarch64_reg 128 "V9"; + aarch64_reg 128 "V10"; + aarch64_reg 128 "V11"; + aarch64_reg 128 "V12"; + aarch64_reg 128 "V13"; + aarch64_reg 128 "V14"; + aarch64_reg 128 "V15"; + aarch64_reg 128 "V16"; + aarch64_reg 128 "V17"; + aarch64_reg 128 "V18"; + aarch64_reg 128 "V19"; + aarch64_reg 128 "V20"; + aarch64_reg 128 "V21"; + aarch64_reg 128 "V22"; + aarch64_reg 128 "V23"; + aarch64_reg 128 "V24"; + aarch64_reg 128 "V25"; + aarch64_reg 128 "V26"; + aarch64_reg 128 "V27"; + aarch64_reg 128 "V28"; + aarch64_reg 128 "V29"; + aarch64_reg 128 "V30"; + aarch64_reg 128 "V31"; +] + +let aarch64_special_purpose_registers_data = [ + aarch64_reg 32 "CurrentEL"; + aarch64_reg 32 "DAIF"; + aarch64_reg 32 "NZCV"; + aarch64_reg 64 "SP_EL0"; + aarch64_reg 64 "SP_EL1"; + aarch64_reg 64 "SP_EL2"; + aarch64_reg 64 "SP_EL3"; + aarch64_reg 32 "SPSel"; + aarch64_reg 32 "SPSR_EL1"; + aarch64_reg 32 "SPSR_EL2"; + aarch64_reg 32 "SPSR_EL3"; + aarch64_reg 64 "ELR_EL1"; + aarch64_reg 64 "ELR_EL2"; + aarch64_reg 64 "ELR_EL3"; +] + +let aarch64_general_system_control_registers_data = [ + aarch64_reg 64 "HCR_EL2"; + aarch64_reg 64 "ID_AA64MMFR0_EL1"; + aarch64_reg 64 "RVBAR_EL1"; + aarch64_reg 64 "RVBAR_EL2"; + aarch64_reg 64 "RVBAR_EL3"; + aarch64_reg 32 "SCR_EL3"; + aarch64_reg 32 "SCTLR_EL1"; + aarch64_reg 32 "SCTLR_EL2"; + aarch64_reg 32 "SCTLR_EL3"; + aarch64_reg 64 "TCR_EL1"; + aarch64_reg 32 "TCR_EL2"; + aarch64_reg 32 "TCR_EL3"; +] + +let aarch64_debug_registers_data = [ + aarch64_reg 32 "DBGPRCR_EL1"; + aarch64_reg 32 "OSDLR_EL1"; +] + +let aarch64_performance_monitors_registers_data = [] +let aarch64_generic_timer_registers_data = [] +let aarch64_generic_interrupt_controller_CPU_interface_registers_data = [] + +let aarch64_external_debug_registers_data = [ + aarch64_reg 32 "EDSCR"; +] + +let aarch32_general_system_control_registers_data = [ + aarch64_reg 32 "SCR"; +] + +let aarch32_debug_registers_data = [ + aarch64_reg 32 "DBGOSDLR"; + aarch64_reg 32 "DBGPRCR"; +] + +let aarch64_register_data_all = + aarch64_PC_data @ + aarch64_PSTATE_data @ + aarch64_general_purpose_registers_data @ + aarch64_SIMD_registers_data @ + aarch64_special_purpose_registers_data @ + aarch64_general_system_control_registers_data @ + aarch64_debug_registers_data @ + aarch64_performance_monitors_registers_data @ + aarch64_generic_timer_registers_data @ + aarch64_generic_interrupt_controller_CPU_interface_registers_data @ + aarch64_external_debug_registers_data @ + aarch32_general_system_control_registers_data @ + aarch32_debug_registers_data + +let initial_stack_and_reg_data_of_AAarch64_elf_file e_entry all_data_memory = + let (reg_SP_EL0_direction, reg_SP_EL0_width, reg_SP_EL0_initial_index) = + List.assoc "SP_EL0" aarch64_register_data_all in + + (* we compiled a small program that prints out SP and run it a few + times on the Nexus9, these are the results: + 0x0000007fe7f903e0 + 0x0000007fdcdbf3f0 + 0x0000007fcbe1ba90 + 0x0000007fcf378280 + 0x0000007fdd54b8d0 + 0x0000007fd961bc10 + 0x0000007ff3be6350 + 0x0000007fd6bf6ef0 + 0x0000007fff7676f0 + 0x0000007ff2c34560 *) + let initial_SP_EL0 = Nat_big_num.of_string "549739036672" (*"0x0000007fff000000"*) in + let initial_SP_EL0_value = + Interp_interface.register_value_of_integer + reg_SP_EL0_width + reg_SP_EL0_initial_index + reg_SP_EL0_direction + initial_SP_EL0 + in + + (* ELF says we need an initial zero doubleword there *) + (* the code actually uses the stack, both above and below, so we map a bit more memory*) + let initial_stack_data = + (* this is a fairly big but arbitrary chunk: *) + (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in + [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) + + [ ("initial_stack_data1", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 16), Lem_list.replicate 8 0); + ("initial_stack_data2", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 8), Lem_list.replicate 8 0) + ] + in + + let initial_register_abi_data : (string * Interp_interface.register_value) list = + [("SP_EL0", initial_SP_EL0_value)] + in + + (initial_stack_data, initial_register_abi_data) +*) + +let mips_register_data_all = [ + (*Pseudo registers*) + ("branchPending", (D_decreasing, 1, 0)); + ("inBranchDelay", (D_decreasing, 1, 0)); + ("delayedPC", (D_decreasing, 64, 63)); + ("nextPC", (D_decreasing, 64, 63)); + (* General purpose registers *) + ("GPR00", (D_decreasing, 64, 63)); + ("GPR01", (D_decreasing, 64, 63)); + ("GPR02", (D_decreasing, 64, 63)); + ("GPR03", (D_decreasing, 64, 63)); + ("GPR04", (D_decreasing, 64, 63)); + ("GPR05", (D_decreasing, 64, 63)); + ("GPR06", (D_decreasing, 64, 63)); + ("GPR07", (D_decreasing, 64, 63)); + ("GPR08", (D_decreasing, 64, 63)); + ("GPR09", (D_decreasing, 64, 63)); + ("GPR10", (D_decreasing, 64, 63)); + ("GPR11", (D_decreasing, 64, 63)); + ("GPR12", (D_decreasing, 64, 63)); + ("GPR13", (D_decreasing, 64, 63)); + ("GPR14", (D_decreasing, 64, 63)); + ("GPR15", (D_decreasing, 64, 63)); + ("GPR16", (D_decreasing, 64, 63)); + ("GPR17", (D_decreasing, 64, 63)); + ("GPR18", (D_decreasing, 64, 63)); + ("GPR19", (D_decreasing, 64, 63)); + ("GPR20", (D_decreasing, 64, 63)); + ("GPR21", (D_decreasing, 64, 63)); + ("GPR22", (D_decreasing, 64, 63)); + ("GPR23", (D_decreasing, 64, 63)); + ("GPR24", (D_decreasing, 64, 63)); + ("GPR25", (D_decreasing, 64, 63)); + ("GPR26", (D_decreasing, 64, 63)); + ("GPR27", (D_decreasing, 64, 63)); + ("GPR28", (D_decreasing, 64, 63)); + ("GPR29", (D_decreasing, 64, 63)); + ("GPR30", (D_decreasing, 64, 63)); + ("GPR31", (D_decreasing, 64, 63)); + (* special registers for mul/div *) + ("HI", (D_decreasing, 64, 63)); + ("LO", (D_decreasing, 64, 63)); + (* control registers *) + ("CP0Status", (D_decreasing, 32, 31)); + ("CP0Cause", (D_decreasing, 32, 31)); + ("CP0EPC", (D_decreasing, 64, 63)); + ("CP0LLAddr", (D_decreasing, 64, 63)); + ("CP0LLBit", (D_decreasing, 1, 0)); +] + +let cheri_register_data_all = mips_register_data_all @ [ + ("CapCause", (D_decreasing, 16, 15)); + ("PCC", (D_decreasing, 257, 256)); + ("C00", (D_decreasing, 257, 256)); + ("C01", (D_decreasing, 257, 256)); + ("C02", (D_decreasing, 257, 256)); + ("C03", (D_decreasing, 257, 256)); + ("C04", (D_decreasing, 257, 256)); + ("C05", (D_decreasing, 257, 256)); + ("C06", (D_decreasing, 257, 256)); + ("C07", (D_decreasing, 257, 256)); + ("C08", (D_decreasing, 257, 256)); + ("C09", (D_decreasing, 257, 256)); + ("C10", (D_decreasing, 257, 256)); + ("C11", (D_decreasing, 257, 256)); + ("C12", (D_decreasing, 257, 256)); + ("C13", (D_decreasing, 257, 256)); + ("C14", (D_decreasing, 257, 256)); + ("C15", (D_decreasing, 257, 256)); + ("C16", (D_decreasing, 257, 256)); + ("C17", (D_decreasing, 257, 256)); + ("C18", (D_decreasing, 257, 256)); + ("C19", (D_decreasing, 257, 256)); + ("C20", (D_decreasing, 257, 256)); + ("C21", (D_decreasing, 257, 256)); + ("C22", (D_decreasing, 257, 256)); + ("C23", (D_decreasing, 257, 256)); + ("C24", (D_decreasing, 257, 256)); + ("C25", (D_decreasing, 257, 256)); + ("C26", (D_decreasing, 257, 256)); + ("C27", (D_decreasing, 257, 256)); + ("C28", (D_decreasing, 257, 256)); + ("C29", (D_decreasing, 257, 256)); + ("C30", (D_decreasing, 257, 256)); + ("C31", (D_decreasing, 257, 256)); +] + +let initial_stack_and_reg_data_of_MIPS_elf_file e_entry all_data_memory = + let initial_stack_data = [] in + let initial_cap_val_int = Nat_big_num.of_string "115792089264276142078167421332581561412618036492862375629811892344162380414975" (*"0x100000000fffffffe00000000000000000000000000000000ffffffffffffffff"*) in + let initial_cap_val_reg = Interp_interface.register_value_of_integer 257 256 D_decreasing initial_cap_val_int in + let initial_register_abi_data : (string * Interp_interface.register_value) list = [ + ("PCC", initial_cap_val_reg); + ("C00", initial_cap_val_reg); + ("C01", initial_cap_val_reg); + ("C02", initial_cap_val_reg); + ("C03", initial_cap_val_reg); + ("C04", initial_cap_val_reg); + ("C05", initial_cap_val_reg); + ("C06", initial_cap_val_reg); + ("C07", initial_cap_val_reg); + ("C08", initial_cap_val_reg); + ("C09", initial_cap_val_reg); + ("C10", initial_cap_val_reg); + ("C11", initial_cap_val_reg); + ("C12", initial_cap_val_reg); + ("C13", initial_cap_val_reg); + ("C14", initial_cap_val_reg); + ("C15", initial_cap_val_reg); + ("C16", initial_cap_val_reg); + ("C17", initial_cap_val_reg); + ("C18", initial_cap_val_reg); + ("C19", initial_cap_val_reg); + ("C20", initial_cap_val_reg); + ("C21", initial_cap_val_reg); + ("C22", initial_cap_val_reg); + ("C23", initial_cap_val_reg); + ("C24", initial_cap_val_reg); + ("C25", initial_cap_val_reg); + ("C26", initial_cap_val_reg); + ("C27", initial_cap_val_reg); + ("C28", initial_cap_val_reg); + ("C29", initial_cap_val_reg); + ("C30", initial_cap_val_reg); + ("C31", initial_cap_val_reg); + ] in + (initial_stack_data, initial_register_abi_data) + +let initial_reg_file reg_data init = + List.iter (fun (reg_name, _) -> reg := Reg.add reg_name (init reg_name) !reg) reg_data + +let initial_system_state_of_elf_file name = + + (* call ELF analyser on file *) + match Sail_interface.populate_and_obtain_global_symbol_init_info name with + | Error.Fail s -> failwith ("populate_and_obtain_global_symbol_init_info: " ^ s) + | Error.Success + ((elf_epi: Sail_interface.executable_process_image), + (symbol_map: Elf_file.global_symbol_init_info)) + -> + let (segments, e_entry, e_machine) = + begin match elf_epi with + | ELF_Class_32 _ -> failwith "cannot handle ELF_Class_32" + | ELF_Class_64 (segments,e_entry,e_machine) -> + (* 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,e_entry,e_machine) + end + in + + (* construct program memory and start address *) + begin + prog_mem := Mem.empty; + data_mem := Mem.empty; + tag_mem := Mem.empty; + load_memory_segments segments; + (* + debugf "prog_mem\n"; + Mem.iter (fun k v -> debugf "%s\n" (Mem.to_string k v)) !prog_mem; + debugf "data_mem\n"; + Mem.iter (fun k v -> debugf "%s\n" (Mem.to_string k v)) !data_mem; + *) + let (isa_defs, isa_memory_access, isa_externs, isa_model, model_reg_d, startaddr, + initial_stack_data, initial_register_abi_data, register_data_all) = + match Nat_big_num.to_int e_machine with +(* | 21 (* EM_PPC64 *) -> + let startaddr = + let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in + match Abi_power64.abi_power64_compute_program_entry_point segments e_entry with + | Error.Fail s -> failwith "Failed computing entry point" + | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) + in + let (initial_stack_data, initial_register_abi_data) = + initial_stack_and_reg_data_of_PPC_elf_file e_entry !data_mem in + + (Power.defs, + (Power_extras.read_memory_functions,Power_extras.memory_writes,[],[],Power_extras.barrier_functions), + Power_extras.power_externs, + PPC, + D_increasing, + startaddr, + initial_stack_data, + initial_register_abi_data, + ppc_register_data_all) + + | 183 (* EM_AARCH64 *) -> + let startaddr = + let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in + match Abi_aarch64_le.abi_aarch64_le_compute_program_entry_point segments e_entry with + | Error.Fail s -> failwith "Failed computing entry point" + | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) + in + + let (initial_stack_data, initial_register_abi_data) = + initial_stack_and_reg_data_of_AAarch64_elf_file e_entry !data_mem in + + (ArmV8.defs, + (ArmV8_extras.aArch64_read_memory_functions, + ArmV8_extras.aArch64_memory_writes, + ArmV8_extras.aArch64_memory_eas, + ArmV8_extras.aArch64_memory_vals, + ArmV8_extras.aArch64_barrier_functions), + [], + AArch64, + D_decreasing, + startaddr, + initial_stack_data, + initial_register_abi_data, + aarch64_register_data_all) *) + | 8 (* EM_MIPS *) -> + let startaddr = + let e_entry = Uint64.of_string (Nat_big_num.to_string e_entry) in + match Abi_mips64.abi_mips64_compute_program_entry_point segments e_entry with + | Error.Fail s -> failwith "Failed computing entry point" + | Error.Success s -> s + in + let (initial_stack_data, initial_register_abi_data) = + initial_stack_and_reg_data_of_MIPS_elf_file e_entry !data_mem in + + (Cheri.defs, + (Mips_extras.read_memory_functions, + Mips_extras.memory_writes, + [], + [], + Mips_extras.barrier_functions), + [], + MIPS, + D_decreasing, + startaddr, + initial_stack_data, + initial_register_abi_data, + cheri_register_data_all) + + | _ -> failwith (Printf.sprintf "Sail sequential interpreter can't handle the e_machine value %s, only EM_PPC64, EM_AARCH64 and EM_MIPS are supported." (Nat_big_num.to_string e_machine)) + in + + (* pull the object symbols from the symbol table *) + let symbol_table : (string * Nat_big_num.num * int * word8 list (*their bytes*)) list = + let rec convert_symbol_table symbol_map = + begin match symbol_map with + | [] -> [] + | ((name: string), + ((typ: Nat_big_num.num), + (size: Nat_big_num.num (*number of bytes*)), + (address: Nat_big_num.num), + (mb: Byte_sequence.byte_sequence option (*present iff type=stt_object*)), + (binding: Nat_big_num.num))) + (* (mb: Byte_sequence_wrapper.t option (*present iff type=stt_object*)) )) *) + ::symbol_map' -> + if Nat_big_num.equal typ Elf_symbol_table.stt_object && not (Nat_big_num.equal size (Nat_big_num.of_int 0)) + then + ( + (* an object symbol - map *) + (*Printf.printf "*** size %d ***\n" (Nat_big_num.to_int size);*) + let bytes = + (match mb with + | None -> raise (Failure "this cannot happen") + | Some (Sequence bytes) -> + List.map (fun (c:char) -> Char.code c) bytes) in + (name, address, List.length bytes, bytes):: convert_symbol_table symbol_map' + ) + else + (* not an object symbol or of zero size - ignore *) + convert_symbol_table symbol_map' + end + in + (List.map (fun (n,a,bs) -> (n,a,List.length bs,bs)) initial_stack_data) @ convert_symbol_table symbol_map + in + + (* invert the symbol table to use for pp *) + let symbol_table_pp : ((Interp_interface.address * int) * string) list = + (* map symbol to (bindings, footprint), + if a symbol appears more then onece keep the one with higher + precedence (stb_global > stb_weak > stb_local) *) + let map = + List.fold_left + (fun map (name, (typ, size, address, mb, binding)) -> + if String.length name <> 0 && + (if String.length name = 1 then Char.code (String.get name 0) <> 0 else true) && + not (Nat_big_num.equal address (Nat_big_num.of_int 0)) + then + try + let (binding', _) = StringMap.find name map in + if Nat_big_num.equal binding' Elf_symbol_table.stb_local || + Nat_big_num.equal binding Elf_symbol_table.stb_global + then + StringMap.add name (binding, + (Interp_interface.address_of_integer address, Nat_big_num.to_int size)) map + else map + with Not_found -> + StringMap.add name (binding, + (Interp_interface.address_of_integer address, Nat_big_num.to_int size)) map + + else map + ) + StringMap.empty + symbol_map + in + + List.map (fun (name, (binding, fp)) -> (fp, name)) (StringMap.bindings map) + in + + + (* Now we examine the rest of the data memory, + removing the footprint of the symbols and chunking it into aligned chunks *) + + let rec remove_symbols_from_data_memory data_mem symbols = + match symbols with + | [] -> data_mem + | (name,address,size,bs)::symbols' -> + let data_mem' = + Mem.filter + (fun a v -> + not (Nat_big_num.greater_equal a address && + Nat_big_num.less a (Nat_big_num.add (Nat_big_num.of_int (List.length bs)) address))) + data_mem in + remove_symbols_from_data_memory data_mem' symbols' in + + let trimmed_data_memory : (Nat_big_num.num * memory_byte) list = + Mem.bindings (remove_symbols_from_data_memory !data_mem symbol_table) in + + (* make sure that's ordered increasingly.... *) + let trimmed_data_memory = + List.sort (fun (a,b) (a',b') -> Nat_big_num.compare a a') trimmed_data_memory in + + let aligned a n = (* a mod n = 0 *) + let n_big = Nat_big_num.of_int n in + Nat_big_num.equal (Nat_big_num.modulus a n_big) ((Nat_big_num.of_int 0)) in + + let isplus a' a n = (* a' = a+n *) + Nat_big_num.equal a' (Nat_big_num.add (Nat_big_num.of_int n) a) in + + let rec chunk_data_memory dm = + match dm with + | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::(a4,b4)::(a5,b5)::(a6,b6)::(a7,b7)::dm' when + (aligned a0 8 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3 && + isplus a4 a0 4 && isplus a5 a0 5 && isplus a6 a0 6 && isplus a7 a0 7) -> + (a0,8,[b0;b1;b2;b3;b4;b5;b6;b7]) :: chunk_data_memory dm' + | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::dm' when + (aligned a0 4 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3) -> + (a0,4,[b0;b1;b2;b3]) :: chunk_data_memory dm' + | (a0,b0)::(a1,b1)::dm' when + (aligned a0 2 && isplus a1 a0 1) -> + (a0,2,[b0;b1]) :: chunk_data_memory dm' + | (a0,b0)::dm' -> + (a0,1,[b0]):: chunk_data_memory dm' + | [] -> [] in + + let initial_register_state = + fun rbn -> + try + List.assoc rbn initial_register_abi_data + with + Not_found -> + (register_state_zero register_data_all) rbn + in + + begin + (initial_reg_file register_data_all initial_register_state); + + (* construct initial system state *) + let initial_system_state = + (isa_defs, + isa_memory_access, + isa_externs, + isa_model, + model_reg_d, + startaddr, + (Interp_interface.address_of_integer startaddr)) + in + + (initial_system_state, symbol_table_pp) + end + end + +let eager_eval = ref true +let break_point = ref false +let break_instr = ref 0 +let max_cut_off = ref false +let max_instr = ref 0 + +let args = [ + ("--file", Arg.Set_string file, "filename binary code to load in memory"); + ("--quiet", Arg.Clear Run_interp_model.interact_print, "do not display per-instruction actions"); + ("--silent", Arg.Tuple [Arg.Clear Run_interp_model.error_print; + Arg.Clear Run_interp_model.interact_print; + Arg.Clear Run_interp_model.result_print], + "do not dispaly error messages, per-instruction actions, or results"); + ("--no_result", Arg.Clear Run_interp_model.result_print, "do not display final register values"); + ("--interactive", Arg.Clear eager_eval , "interactive execution"); + ("--breakpoint", Arg.Int (fun i -> break_point := true; break_instr:= i), "run to instruction number i, then run interactively"); + ("--max_instruction", Arg.Int (fun i -> max_cut_off := true; max_instr := i), "only run i instructions, then stop"); +] + +let time_it action arg = + let start_time = Sys.time () in + ignore (action arg); + let finish_time = Sys.time () in + finish_time -. start_time + +(*TODO MIPS specific, should print final register values under all models*) +let rec debug_print_gprs start stop = + resultf "DEBUG MIPS REG %.2d %s\n" start (Printing_functions.logfile_register_value_to_string (Reg.find (Format.sprintf "GPR%02d" start) !reg)); + if start < stop + then debug_print_gprs (start + 1) stop + else () + +let rec debug_print_capregs start stop = + resultf "DEBUG CAP REG %.2d %s\n" start (Printing_functions.logfile_register_value_to_string (Reg.find (Format.sprintf "C%02d" start) !reg)); + if start < stop + then debug_print_capregs (start + 1) stop + else () + +let stop_condition_met model instr = + match model with + | PPC -> + (match instr with + | ("Sc", [("Lev", _, arg)], []) -> + Nat_big_num.equal (integer_of_bit_list arg) (Nat_big_num.of_int 32) + | _ -> false) + | AArch64 -> (match instr with + | ("ImplementationDefinedStopFetching", _, _) -> true + | _ -> false) + | MIPS -> (match instr with + | ("HCF", _, _) -> + resultf "DEBUG MIPS PC %s\n" (Printing_functions.logfile_register_value_to_string (Reg.find "PC" !reg)); + debug_print_gprs 0 31; + resultf "DEBUG CAP PCC %s\n" (Printing_functions.logfile_register_value_to_string (Reg.find "PCC" !reg)); + debug_print_capregs 0 31; + true + | _ -> false) + +let is_branch model instruction = + let (name,_,_) = instruction in + match (model , name) with + | (PPC, "B") -> true + | (PPC, "Bc") -> true + | (PPC, "Bclr") -> true + | (PPC, "Bcctr") -> true + | (PPC, _) -> false + | (AArch64, "BranchImmediate") -> true + | (AArch64, "BranchConditional") -> true + | (AArch64, "CompareAndBranch") -> true + | (AArch64, "TestBitAndBranch") -> true + | (AArch64, "BranchRegister") -> true + | (AArch64, _) -> false + | (MIPS, _) -> false (*todo,fill this in*) + +let option_int_of_option_integer i = match i with + | Some i -> Some (Nat_big_num.to_int i) + | None -> None + +let set_next_instruction_address model = + match model with + | PPC -> + let cia = Reg.find "CIA" !reg in + let cia_addr = address_of_register_value cia in + (match cia_addr with + | Some cia_addr -> + let nia_addr = add_address_nat cia_addr 4 in + let nia = register_value_of_address nia_addr Interp_interface.D_increasing in + reg := Reg.add "NIA" nia !reg + | _ -> failwith "CIA address contains unknown or undefined") + | AArch64 -> + let pc = Reg.find "_PC" !reg in + let pc_addr = address_of_register_value pc in + (match pc_addr with + | Some pc_addr -> + let n_addr = add_address_nat pc_addr 4 in + let n_pc = register_value_of_address n_addr D_decreasing in + reg := Reg.add "_PC" n_pc !reg + | _ -> failwith "_PC address contains unknown or undefined") + | MIPS -> + let pc_addr = address_of_register_value (Reg.find "PC" !reg) in + let branchPending = integer_of_register_value (Reg.find "branchPending" !reg) in + let delayedPC = address_of_register_value (Reg.find "delayedPC" !reg) in + (match (pc_addr, option_int_of_option_integer branchPending, delayedPC) with + | (Some pc_val, Some 0, _) -> + (* normal -- increment PC *) + let n_addr = add_address_nat pc_val 4 in + let n_pc = register_value_of_address n_addr D_decreasing in + begin + reg := Reg.add "nextPC" n_pc !reg; + reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Interp_interface.D_decreasing Nat_big_num.zero) !reg; + end + | (Some pc_val, Some 1, Some delayedPC) -> + (* delay slot -- branch to delayed PC and clear branchPending *) + begin + reg := Reg.add "nextPC" (register_value_of_address delayedPC D_decreasing) !reg; + reg := Reg.add "branchPending" (register_value_of_integer 1 0 Interp_interface.D_decreasing Nat_big_num.zero) !reg; + reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Interp_interface.D_decreasing (Nat_big_num.of_int 1)) !reg; + end + | (_, _, _) -> errorf "PC address contains unknown or undefined"; exit 1) + +let add1 = Nat_big_num.add (Nat_big_num.of_int 1) + +let fetch_instruction_opcode_and_update_ia model addr_trans = + match model with + | PPC -> + let cia = Reg.find "CIA" !reg in + let cia_addr = address_of_register_value cia in + (match cia_addr with + | Some cia_addr -> + let cia_a = integer_of_address cia_addr in + let opcode = List.map (fun b -> match b with + | Some b -> b + | None -> failwith "A byte in opcode contained unknown or undef") + (List.map byte_of_memory_byte + [Mem.find cia_a !prog_mem; + Mem.find (add1 cia_a) !prog_mem; + Mem.find (add1 (add1 cia_a)) !prog_mem; + Mem.find (add1 (add1 (add1 cia_a))) !prog_mem]) in + begin + reg := Reg.add "CIA" (Reg.find "NIA" !reg) !reg; + Opcode opcode + end + | None -> failwith "CIA address contains unknown or undefined") + | AArch64 -> + let pc = Reg.find "_PC" !reg in + let pc_addr = address_of_register_value pc in + (match pc_addr with + | Some pc_addr -> + let pc_a = integer_of_address pc_addr in + let opcode = List.map (fun b -> match b with + | Some b -> b + | None -> failwith "A byte in opcode contained unknown or undef") + (List.map byte_of_memory_byte + ([Mem.find pc_a !prog_mem; + Mem.find (add1 pc_a) !prog_mem; + Mem.find (add1 (add1 pc_a)) !prog_mem; + Mem.find (add1 (add1 (add1 pc_a))) !prog_mem])) in + Opcode opcode + | None -> failwith "_PC address contains unknown or undefined") + | MIPS -> + let nextPC = Reg.find "nextPC" !reg in + let pc_addr = address_of_register_value nextPC in + (match pc_addr with + | Some pc_addr -> + let pc_a = match addr_trans pc_addr with + | Some a, _ -> integer_of_address a + | None, Some i -> failwith ("Address translation failed with error code " ^ (Nat_big_num.to_string i)) + | _ -> failwith "Neither an address or a code on translate address" in + let opcode = List.map (fun b -> match b with + | Some b -> b + | None -> failwith "A byte in opcode contained unknown or undef") + (List.map byte_of_memory_byte + (([Mem.find pc_a !prog_mem; + Mem.find (add1 pc_a) !prog_mem; + Mem.find (add1 (add1 pc_a)) !prog_mem; + Mem.find (add1 (add1 (add1 pc_a))) !prog_mem]))) in + begin + reg := Reg.add "PC" nextPC !reg; + Opcode opcode + end + | None -> errorf "nextPC contains unknown or undefined"; exit 1) + | _ -> assert false + +let get_pc_address = function + | MIPS -> Reg.find "PC" !reg + | PPC -> Reg.find "CIA" !reg + | AArch64 -> Reg.find "_PC" !reg + + +let rec fde_loop count context model mode track_dependencies opcode addr_trans = + if !max_cut_off && count = !max_instr + then resultf "\nEnding evaluation due to reaching cut off point of %d instructions\n" count + else begin + interactf "\n**** instruction %d from address %s ****\n" + count (Printing_functions.register_value_to_string (get_pc_address model)); + if !break_point && count = !break_instr then begin break_point := false; eager_eval := false end; + let (instruction,istate) = match Interp_inter_imp.decode_to_istate context opcode with + | Instr(instruction,istate) -> + interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); + (instruction,istate) + | Decode_error d -> + (match d with + | Interp_interface.Unsupported_instruction_error instr -> + errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Not_an_instruction_error op -> + (match op with + | Opcode bytes -> + errorf "\n**** Encountered non-decodeable opcode: %s ****\n" (Printing_functions.byte_list_to_string bytes)) + | Internal_error s -> errorf "\n**** Internal error on decode: %s ****\n" s); + exit 1 + in + if stop_condition_met model instruction + then resultf "\nSUCCESS program terminated after %d instructions\n" count + else + begin + set_next_instruction_address model; + match Run_interp_model.run istate !reg !prog_mem !tag_mem !eager_eval track_dependencies mode "execute" with + | false, _,_, _ -> errorf "FAILURE\n"; exit 1 + | true, mode, track_dependencies, (my_reg, my_mem, my_tags) -> + reg := my_reg; + prog_mem := my_mem; + tag_mem := my_tags; + let opcode = fetch_instruction_opcode_and_update_ia model addr_trans in + fde_loop (count + 1) context model (Some mode) (ref track_dependencies) opcode addr_trans + end + end + +let run () = + Arg.parse args (fun _ -> raise (Arg.Bad "anonymous parameter")) "" ; + if !file = "" then begin + Arg.usage args ""; + exit 1; + end; + if !break_point then eager_eval := true; + + let ((isa_defs, + (isa_m0, isa_m1, isa_m2, isa_m3,isa_m4), + isa_externs, + isa_model, + model_reg_d, + startaddr, + startaddr_internal), pp_symbol_map) = initial_system_state_of_elf_file !file in + + let context = build_context isa_defs isa_m0 isa_m1 isa_m2 isa_m3 isa_m4 isa_externs in + (*NOTE: this is likely MIPS specific, so should probably pull from initial_system_state info on to translate or not, + endian mode, and translate function name + *) + let addr_trans = translate_address context E_big_endian "TranslateAddress" in + let startaddr = match addr_trans startaddr_internal with + | Some a, _ -> integer_of_address a + | None, Some i -> failwith ("Address translation failed with error code " ^ (Nat_big_num.to_string i)) + | _ -> failwith "Neither an address or a code on translate address" + in + let initial_opcode = Opcode (List.map (fun b -> match b with + | Some b -> b + | None -> errorf "A byte in opcode contained unknown or undef"; exit 1) + (List.map byte_of_memory_byte + [Mem.find startaddr !prog_mem; + Mem.find (add1 startaddr) !prog_mem; + Mem.find (add1 (add1 startaddr)) !prog_mem; + Mem.find (add1 (add1 (add1 startaddr))) !prog_mem])) in + reg := Reg.add "PC" (register_value_of_address startaddr_internal model_reg_d ) !reg; + + (* entry point: unit -> unit fde *) + let name = Filename.basename !file in + let t = time_it (fun () -> fde_loop 0 context isa_model (Some Run) (ref false) initial_opcode addr_trans) () in + resultf "Execution time for file %s: %f seconds\n" name t;; + +run () ;; |
