diff options
author | Cyril SIX <cyril.six@kalray.eu> | 2021-06-01 14:58:05 +0200 |
---|---|---|
committer | Cyril SIX <cyril.six@kalray.eu> | 2021-06-01 14:58:05 +0200 |
commit | 75a2885f610e1d6e91df8e2386a4a4559b615bb9 (patch) | |
tree | 4456fa4a9876bc73d3d08b6dad1ad8f2f836578c | |
parent | 22504b61be43e5d4a97db621ce3c1785618bbaf0 (diff) | |
parent | c44fc24eb6111c177d1d6fc973a366ebf646202b (diff) | |
download | compcert-kvx-75a2885f610e1d6e91df8e2386a4a4559b615bb9.tar.gz compcert-kvx-75a2885f610e1d6e91df8e2386a4a4559b615bb9.zip |
Merge remote-tracking branch 'origin/kvx-work' into merge_master_8.13.1
-rw-r--r-- | Makefile | 1 | ||||
-rw-r--r-- | Makefile.extr | 2 | ||||
-rw-r--r-- | aarch64/Machregs.v | 2 | ||||
-rw-r--r-- | aarch64/Machregsaux.mli | 17 | ||||
-rw-r--r-- | aarch64/PeepholeOracle.ml | 11 | ||||
-rw-r--r-- | aarch64/TargetPrinter.ml | 4 | ||||
-rw-r--r-- | backend/Duplicateaux.ml | 355 | ||||
-rw-r--r-- | backend/LICMaux.ml | 32 | ||||
-rw-r--r-- | backend/Linearizeaux.ml | 442 | ||||
-rw-r--r-- | backend/Stackingproof.v | 2 | ||||
-rw-r--r-- | common/DebugPrint.ml | 28 | ||||
-rw-r--r-- | compcert_build_env.dockerfile | 6 | ||||
-rw-r--r-- | compcert_kvx.dockerfile | 19 | ||||
-rw-r--r-- | compcert_kvx_pruned.dockerfile | 5 | ||||
-rwxr-xr-x | configure | 5 | ||||
-rw-r--r-- | cparser/Machine.ml | 12 | ||||
-rw-r--r-- | cparser/Machine.mli | 3 | ||||
-rw-r--r-- | doc/index-kvx.html | 2 | ||||
-rw-r--r-- | driver/Clflags.ml | 3 | ||||
-rw-r--r-- | driver/Configuration.ml | 1 | ||||
-rw-r--r-- | driver/Configuration.mli | 3 | ||||
-rw-r--r-- | driver/Driver.ml | 1 | ||||
-rw-r--r-- | driver/Frontend.ml | 5 | ||||
-rwxr-xr-x | make_docker.sh | 3 | ||||
-rw-r--r-- | riscV/Asm.v | 2 | ||||
-rw-r--r-- | riscV/Asmgen.v | 459 | ||||
-rw-r--r-- | riscV/Asmgenproof.v | 164 | ||||
-rw-r--r-- | riscV/Asmgenproof1.v | 837 | ||||
-rw-r--r-- | riscV/ExpansionOracle.ml | 1149 | ||||
-rw-r--r-- | riscV/NeedOp.v | 21 | ||||
-rw-r--r-- | riscV/Op.v | 537 | ||||
-rw-r--r-- | riscV/OpWeights.ml | 335 | ||||
-rw-r--r-- | riscV/PrintOp.ml | 125 | ||||
-rw-r--r-- | riscV/RTLpathSE_simplify.v | 1109 | ||||
-rw-r--r-- | riscV/ValueAOp.v | 197 | ||||
-rw-r--r-- | scheduling/RTLpath.v | 2 | ||||
-rw-r--r-- | scheduling/RTLpathLivegenaux.ml | 30 | ||||
-rw-r--r-- | scheduling/RTLpathSE_impl.v | 2 | ||||
-rw-r--r-- | scheduling/RTLpathSE_simu_specs.v | 8 | ||||
-rw-r--r-- | scheduling/RTLpathScheduler.v | 2 | ||||
-rw-r--r-- | scheduling/RTLpathScheduleraux.ml | 9 | ||||
-rw-r--r-- | scheduling/abstractbb/AbstractBasicBlocksDef.v | 2 | ||||
-rw-r--r-- | test/aarch64/README.md | 15 | ||||
-rwxr-xr-x | test/aarch64/gen_tests/asmb_aarch64_gen_test.sh | 106 | ||||
-rwxr-xr-x | test/aarch64/postpass_tests/postpass_exec_c_test.sh | 36 | ||||
-rw-r--r-- | test/gourdinl/c/add_return.c (renamed from test/aarch64/c/add_return.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/addresses.c (renamed from test/aarch64/c/addresses.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/arith.c (renamed from test/aarch64/c/arith.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/arith_print.c (renamed from test/aarch64/c/arith_print.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/armstrong.c (renamed from test/aarch64/c/armstrong.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/array1.c (renamed from test/aarch64/c/array1.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/array2.c (renamed from test/aarch64/c/array2.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/biggest_of_3_int.c (renamed from test/aarch64/c/biggest_of_3_int.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/bitwise1.c (renamed from test/aarch64/c/bitwise1.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/cpintarray.c (renamed from test/aarch64/c/cpintarray.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/enum1.c (renamed from test/aarch64/c/enum1.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/enum2.c (renamed from test/aarch64/c/enum2.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/floop.c (renamed from test/aarch64/c/floop.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/floor.c (renamed from test/aarch64/c/floor.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/funcs.c (renamed from test/aarch64/c/funcs.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/hello.c (renamed from test/aarch64/c/hello.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/if.c (renamed from test/aarch64/c/if.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/msb_pos.c (renamed from test/aarch64/c/msb_pos.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/power2.c (renamed from test/aarch64/c/power2.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/prime.c (renamed from test/aarch64/c/prime.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/random.c (renamed from test/aarch64/c/random.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/simple_op.c (renamed from test/aarch64/c/simple_op.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/c/wloop.c (renamed from test/aarch64/c/wloop.c) | 0 | ||||
-rw-r--r-- | test/gourdinl/clause.h | 12 | ||||
-rw-r--r-- | test/gourdinl/clause2.c | 23 | ||||
-rw-r--r-- | test/gourdinl/cond_exp_mini_cse.c | 6 | ||||
-rwxr-xr-x | test/gourdinl/cscript.sh | 20 | ||||
-rw-r--r-- | test/gourdinl/fp_init.c | 7 | ||||
-rwxr-xr-x | test/gourdinl/gen_asm_files.sh | 6 | ||||
-rw-r--r-- | test/monniaux/profiling/compcert_profiling.dat | bin | 0 -> 96 bytes | |||
-rwxr-xr-x | test/monniaux/profiling/test_profiling | bin | 0 -> 14128 bytes | |||
-rw-r--r-- | test/monniaux/profiling/test_profiling.c | 15 |
77 files changed, 4260 insertions, 1940 deletions
@@ -315,6 +315,7 @@ compcert.ini: Makefile.config echo "linker_options=$(CLINKER_OPTIONS)";\ echo "arch=$(ARCH)"; \ echo "model=$(MODEL)"; \ + echo "os=$(OS)"; \ echo "abi=$(ABI)"; \ echo "endianness=$(ENDIANNESS)"; \ echo "system=$(SYSTEM)"; \ diff --git a/Makefile.extr b/Makefile.extr index 74b7fef8..d7c40cd4 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -52,7 +52,7 @@ INCLUDES=$(patsubst %,-I %, $(DIRS)) # Control of warnings: # WARNINGS=-w +a-4-9-27-42 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03 -WARNINGS=-w +a-4-9-27-42 +WARNINGS=-w +a-4-9-27-42-70-69 # 70,69 for OCaml 4.13 extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 diff --git a/aarch64/Machregs.v b/aarch64/Machregs.v index 3d27f48f..bfe23e83 100644 --- a/aarch64/Machregs.v +++ b/aarch64/Machregs.v @@ -158,7 +158,7 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_memcpy sz al => R15 :: R17 :: R29 :: nil | EF_inline_asm txt sg clob => destroyed_by_clobber clob - | EF_profiling _ _ => R15 :: R17 :: nil + | EF_profiling _ _ => R15 :: R17 :: R29 :: nil | _ => nil end. diff --git a/aarch64/Machregsaux.mli b/aarch64/Machregsaux.mli new file mode 100644 index 00000000..01b0f9fd --- /dev/null +++ b/aarch64/Machregsaux.mli @@ -0,0 +1,17 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +val is_scratch_register: string -> bool + +val class_of_type: AST.typ -> int diff --git a/aarch64/PeepholeOracle.ml b/aarch64/PeepholeOracle.ml index 18f41fed..2b214df4 100644 --- a/aarch64/PeepholeOracle.ml +++ b/aarch64/PeepholeOracle.ml @@ -401,9 +401,8 @@ let pair_rep_inv insta = * for one type of inst. Lists contains integers which * are the indices of insts in the main array "insta". *) init_symb_mem (); - for i = Array.length insta - 1 downto 1 do + for i = Array.length insta - 1 downto 0 do let h0 = insta.(i) in - let h1 = insta.(i - 1) in (* Here we need to update every symbolic memory according to the matched inst *) update_pot_rep_basic h0 insta (Ldr P32) true; update_pot_rep_basic h0 insta (Ldr P64) true; @@ -413,9 +412,9 @@ let pair_rep_inv insta = update_pot_rep_basic h0 insta (Str P64) true; update_pot_rep_basic h0 insta (Str P32f) true; update_pot_rep_basic h0 insta (Str P64f) true; - match (h0, h1) with + match h0 with (* Non-consecutive ldr *) - | PLoad (PLd_rd_a (ldi, rd1, ADimm (b1, n1))), _ -> + | PLoad (PLd_rd_a (ldi, rd1, ADimm (b1, n1))) -> if is_compat_load ldi then ( (* Search a previous compatible load *) let ld_t = get_load_pht ldi in @@ -445,7 +444,7 @@ let pair_rep_inv insta = (trans_ldi ldi, rd1, r, chunk_load ldi, c, ADimm (b, n1))))); Hashtbl.replace symb_mem ld_t pot_rep) (* Non-consecutive str *) - | PStore (PSt_rs_a (sti, rd1, ADimm (b1, n1))), _ -> + | PStore (PSt_rs_a (sti, rd1, ADimm (b1, n1))) -> if is_compat_store sti then ( (* Search a previous compatible store *) let st_t = get_store_pht sti in @@ -469,7 +468,7 @@ let pair_rep_inv insta = (trans_sti sti, rd1, r, chunk_store sti, c, ADimm (b, n1)))); Hashtbl.replace symb_mem st_t pot_rep (* Any other inst *)) - | i, _ -> ( + | i -> ( (* Clear list of candidates if there is a non supported store *) match i with PStore _ -> reset_str_symb_mem () | _ -> ()) done diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 229aa1b4..1ca3be16 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -349,8 +349,8 @@ module Target(System: SYSTEM): TARGET = fprintf oc "%s:\n" lbl; fprintf oc " ldaxr x17, [x15]\n"; fprintf oc " add x17, x17, 1\n"; - fprintf oc " stlxr w17, x17, [x15]\n"; - fprintf oc " cbnz w17, %s\n" lbl; + fprintf oc " stlxr w29, x17, [x15]\n"; + fprintf oc " cbnz w29, %s\n" lbl; fprintf oc "%s end profiling %a %d\n" comment Profilingaux.pp_id id kind;; diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index b3635527..d55da64a 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -24,6 +24,76 @@ open Maps open Camlcoq open DebugPrint +let stats_oc = ref None + +let set_stats_oc () = + try + let name = Sys.getenv "COMPCERT_PREDICT_STATS" in + let oc = open_out_gen [Open_append; Open_creat; Open_text] 0o666 name in + stats_oc := Some oc + with Not_found -> () + +(* number of total CBs *) +let stats_nb_total = ref 0 +(* we predicted the same thing as the profiling *) +let stats_nb_correct_predicts = ref 0 +(* we predicted something (say Some true), but the profiling predicted the opposite (say Some false) *) +let stats_nb_mispredicts = ref 0 +(* we did not predict anything (None) even though the profiling did predict something *) +let stats_nb_missed_opportunities = ref 0 +(* we predicted something (say Some true) but the profiling preferred not to predict anything (None) *) +let stats_nb_overpredict = ref 0 + +(* heuristic specific counters *) +let wrong_opcode = ref 0 +let wrong_return = ref 0 +let wrong_loop2 = ref 0 +let wrong_loop = ref 0 +let wrong_call = ref 0 + +let right_opcode = ref 0 +let right_return = ref 0 +let right_loop2 = ref 0 +let right_loop = ref 0 +let right_call = ref 0 + +let reset_stats () = begin + stats_nb_total := 0; + stats_nb_correct_predicts := 0; + stats_nb_mispredicts := 0; + stats_nb_missed_opportunities := 0; + stats_nb_overpredict := 0; + wrong_opcode := 0; + wrong_return := 0; + wrong_loop2 := 0; + wrong_loop := 0; + wrong_call := 0; + right_opcode := 0; + right_return := 0; + right_loop2 := 0; + right_loop := 0; + right_call := 0; +end + +let incr theref = theref := !theref + 1 + +let has_some o = match o with Some _ -> true | None -> false + +let stats_oc_recording () = has_some !stats_oc + +let write_stats_oc () = + match !stats_oc with + | None -> () + | Some oc -> begin + Printf.fprintf oc "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d\n" !stats_nb_total + !stats_nb_correct_predicts !stats_nb_mispredicts !stats_nb_missed_opportunities + !stats_nb_overpredict + !wrong_opcode !wrong_return !wrong_loop2 !wrong_loop !wrong_call + !right_opcode !right_return !right_loop2 !right_loop !right_call + ; + close_out oc + end + let get_loop_headers = LICMaux.get_loop_headers let get_some = LICMaux.get_some let rtl_successors = LICMaux.rtl_successors @@ -270,120 +340,66 @@ let get_inner_loops f code is_loop_header = ) (PTree.elements loopmap) end +let get_loop_bodies code entrypoint = + let predecessors = get_predecessors_rtl code in + (* Algorithm from Muchnik, Compiler Design & Implementation, Figure 7.21 page 192 *) + let natural_loop n m = + debug "Natural Loop from %d to %d\n" (P.to_int n) (P.to_int m); + let in_body = ref (PTree.map (fun n b -> false) code) in + let body = ref [] in + let add_to_body n = begin + in_body := PTree.set n true !in_body; + body := n :: !body + end + in let rec process_node p = + debug " Processing node %d\n" (P.to_int p); + List.iter (fun pred -> + debug " Looking at predecessor of %d: %d\n" (P.to_int p) (P.to_int pred); + let is_in_body = get_some @@ PTree.get pred !in_body in + if (not @@ is_in_body) then begin + debug " --> adding to body\n"; + add_to_body pred; + process_node pred + end + ) (get_some @@ PTree.get p predecessors) + in begin + add_to_body m; + add_to_body n; + (if (m != n) then process_node m); + !body + end + in let option_natural_loop n = function + | None -> None + | Some m -> Some (natural_loop n m) + in PTree.map option_natural_loop (LICMaux.get_loop_backedges code entrypoint) -(* Returns a PTree of either None or Some b where b determines the node following the loop, for a cb instruction *) -(* It uses the fact that loops in CompCert are done by a branch (backedge) instruction followed by a cb *) +(* Returns a PTree of either None or Some b where b determines the node in the loop body, for a cb instruction *) let get_loop_info f is_loop_header bfs_order code = - debug "GET LOOP INFO\n"; - debug "==================================\n"; let loop_info = ref (PTree.map (fun n i -> None) code) in - let mark_path n lbody = - let cb_info = ref PTree.empty in - let visited = ref (PTree.map (fun n i -> false) code) in - (* Returns true if there is a path from src to dest (not involving jumptables) *) - (* Mark nodes as visited along the way *) - let explore src dest = - debug "Trying to dive a path from %d to %d\n" (P.to_int src) (P.to_int dest); - (* Memoizing the results to avoid exponential blow-up *) - let memory = ref PTree.empty in - let rec explore_rec src = - debug "explore_rec %d vs %d... " (P.to_int src) (P.to_int dest); - if (P.to_int src) == (P.to_int dest) then (debug "FOUND\n"; true) - else if (get_some @@ PTree.get src !visited) then (debug "VISITED... :( \n"; false) - (* if we went out of the innermost loop *) - else if (not @@ List.mem src lbody) then (debug "Out of innermost...\n"; false) - else begin - let inst = get_some @@ PTree.get src code in - visited := PTree.set src true !visited; - match rtl_successors inst with - | [] -> false - | [s] -> explore_wrap s - | [s1; s2] -> let snapshot_visited = ref !visited in begin - debug "\t\tSplit at %d: either %d or %d\n" (P.to_int src) (P.to_int s1) (P.to_int s2); - (* Remembering that we tried the ifso node *) - cb_info := PTree.set src true !cb_info; - match explore_wrap s1 with - | true -> ( - visited := !snapshot_visited; - match explore_wrap s2 with - | true -> begin - (* Both paths lead to a loop: we cannot predict the CB - * (but the explore still succeeds) *) - cb_info := PTree.remove src !cb_info; - true - end - | false -> true (* nothing to do, the explore succeeded *) - ) - | false -> begin - cb_info := PTree.set src false !cb_info; - match explore_wrap s2 with - | true -> true - | false -> (cb_info := PTree.remove src !cb_info; false) - end - end - | _ -> false + let mark_body body = + List.iter (fun n -> + match get_some @@ PTree.get n code with + | Icond (_, _, ifso, ifnot, _) -> begin + match PTree.get n !loop_info with + | None -> () + | Some _ -> + let b1 = List.mem ifso body in + let b2 = List.mem ifnot body in + if (b1 && b2) then () + else if (b1 || b2) then begin + if b1 then loop_info := PTree.set n (Some true) !loop_info + else if b2 then loop_info := PTree.set n (Some false) !loop_info + end end - and explore_wrap src = begin - match PTree.get src !memory with - | Some b -> b - | None -> - let result = explore_rec src in - (memory := PTree.set src result !memory; result) - end in explore_wrap src - (* Goes forward until a CB is encountered - * Returns None if no CB was found, or Some the_cb_node - * Marks nodes as visited along the way *) - in let rec advance_to_cb src = - if (get_some @@ PTree.get src !visited) then None - else begin - visited := PTree.set src true !visited; - match get_some @@ PTree.get src code with - | Inop s | Iop (_, _, _, s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s) - | Ibuiltin (_,_,_,s) -> advance_to_cb s - | Icond _ -> Some src - | Ijumptable _ | Itailcall _ | Ireturn _ -> None - end - in begin - debug "Attempting to find natural loop from HEAD %d..\n" (P.to_int n); - match advance_to_cb n with - | None -> (debug "\tNo CB found\n") - | Some s -> ( debug "\tFound a CB! %d\n" (P.to_int s); - match get_some @@ PTree.get s !loop_info with - | None | Some _ -> begin - match get_some @@ PTree.get s code with - | Icond (_, _, n1, n2, _) -> ( - let b1 = explore n1 n in - let b2 = explore n2 n in - if (b1 && b2) then - debug "\tBoth paths lead back to the head: NONE\n" - else if (b1 || b2) then begin - if b1 then begin - debug "\tTrue path leads to the head: TRUE\n"; - loop_info := PTree.set s (Some true) !loop_info; - end else if b2 then begin - debug "\tFalse path leads to the head: FALSE\n"; - loop_info := PTree.set s (Some false) !loop_info - end; - debug "\tSetting other CBs encountered..\n"; - List.iter (fun (cb, dir) -> - debug "\t\t%d is %B\n" (P.to_int cb) dir; - loop_info := PTree.set cb (Some dir) !loop_info - ) (PTree.elements !cb_info) - end else - debug "\tNo path leads back to the head: NONE\n" - ) - | _ -> failwith "\tNot an Icond\n" - end - (* | Some _ -> ( debug "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *) - ) - end - in let iloops = get_inner_loops f code is_loop_header in - begin - List.iter (fun il -> mark_path il.head il.body) iloops; - (* List.iter mark_path @@ List.filter (fun n -> get_some @@ PTree.get n is_loop_header) bfs_order; *) - debug "==================================\n"; - !loop_info - end + | _ -> () + ) body + in let bodymap = get_loop_bodies code f.fn_entrypoint in + List.iter (fun (_,obody) -> + match obody with + | None -> () + | Some body -> mark_body body + ) (PTree.elements bodymap); + !loop_info (* Remark - compared to the original Branch Prediction for Free paper, we don't use the store heuristic *) let get_directions f code entrypoint = begin @@ -397,28 +413,59 @@ let get_directions f code entrypoint = begin (* debug "\n"; *) List.iter (fun n -> match (get_some @@ PTree.get n code) with - | Icond (cond, lr, ifso, ifnot, pred) -> - (match pred with Some _ -> debug "RTL node %d already has prediction information\n" (P.to_int n) - | None -> - (* debug "Analyzing %d.." (P.to_int n); *) - let heuristics = [ do_opcode_heuristic; - do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; do_call_heuristic; - (* do_store_heuristic *) ] in - let preferred = ref None in - begin - debug "Deciding condition for RTL node %d\n" (P.to_int n); - List.iter (fun do_heur -> - match !preferred with - | None -> preferred := do_heur code cond ifso ifnot is_loop_header - | Some _ -> () - ) heuristics; - directions := PTree.set n !preferred !directions; - (match !preferred with | Some false -> debug "\tFALLTHROUGH\n" - | Some true -> debug "\tBRANCH\n" - | None -> debug "\tUNSURE\n"); - debug "---------------------------------------\n" - end - ) + | Icond (cond, lr, ifso, ifnot, pred) -> begin + if stats_oc_recording () || not @@ has_some pred then + (* debug "Analyzing %d.." (P.to_int n); *) + let heuristics = [ do_opcode_heuristic; + do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; do_call_heuristic; + (* do_store_heuristic *) ] in + let preferred = ref None in + let current_heuristic = ref 0 in + begin + debug "Deciding condition for RTL node %d\n" (P.to_int n); + List.iter (fun do_heur -> + match !preferred with + | None -> begin + preferred := do_heur code cond ifso ifnot is_loop_header; + if stats_oc_recording () then begin + (* Getting stats about mispredictions from each heuristic *) + (match !preferred, pred with + | Some false, Some true + | Some true, Some false + (* | Some _, None *) (* Uncomment for overpredicts *) + -> begin + match !current_heuristic with + | 0 -> incr wrong_opcode + | 1 -> incr wrong_return + | 2 -> incr wrong_loop2 + | 3 -> incr wrong_loop + | 4 -> incr wrong_call + | _ -> failwith "Shouldn't happen" + end + | Some false, Some false + | Some true, Some true -> begin + match !current_heuristic with + | 0 -> incr right_opcode + | 1 -> incr right_return + | 2 -> incr right_loop2 + | 3 -> incr right_loop + | 4 -> incr right_call + | _ -> failwith "Shouldn't happen" + end + | _ -> () + ); + incr current_heuristic + end + end + | Some _ -> () + ) heuristics; + directions := PTree.set n !preferred !directions; + (match !preferred with | Some false -> debug "\tFALLTHROUGH\n" + | Some true -> debug "\tBRANCH\n" + | None -> debug "\tUNSURE\n"); + debug "---------------------------------------\n" + end + end | _ -> () ) bfs_order; !directions @@ -426,11 +473,28 @@ let get_directions f code entrypoint = begin end let update_direction direction = function -| Icond (cond, lr, n, n', pred) -> +| Icond (cond, lr, n, n', pred) -> begin + (* Counting stats from profiling *) + if stats_oc_recording () then begin + incr stats_nb_total; + match pred, direction with + | None, None -> incr stats_nb_correct_predicts + | None, Some _ -> incr stats_nb_overpredict + | Some _, None -> incr stats_nb_missed_opportunities + | Some false, Some false -> incr stats_nb_correct_predicts + | Some false, Some true -> incr stats_nb_mispredicts + | Some true, Some false -> incr stats_nb_mispredicts + | Some true, Some true -> incr stats_nb_correct_predicts + end; + (* only update if there is no prior existing branch prediction *) (match pred with | None -> Icond (cond, lr, n, n', direction) - | Some _ -> Icond (cond, lr, n, n', pred) ) + | Some _ -> begin + Icond (cond, lr, n, n', pred) + end + ) + end | i -> i (* Uses branch prediction to write prediction annotations in Icond *) @@ -1026,15 +1090,20 @@ let static_predict f = let entrypoint = f.fn_entrypoint in let code = f.fn_code in let revmap = make_identity_ptree code in - let code = - if !Clflags.option_fpredict then - update_directions f code entrypoint - else code in - let code = - if !Clflags.option_fpredict then - invert_iconds code - else code in - ((code, entrypoint), revmap) + begin + reset_stats (); + set_stats_oc (); + let code = + if !Clflags.option_fpredict then + update_directions f code entrypoint + else code in + write_stats_oc (); + let code = + if !Clflags.option_fpredict then + invert_iconds code + else code in + ((code, entrypoint), revmap) + end let unroll_single f = let entrypoint = f.fn_entrypoint in diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 1f6b8817..b88dbc2d 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -41,24 +41,25 @@ let rtl_successors = function * * If we come accross an edge to a Processed node, it's a loop! *) -let get_loop_headers code entrypoint = begin - debug "get_loop_headers\n"; +let get_loop_backedges code entrypoint = begin + debug "get_loop_backedges\n"; let visited = ref (PTree.map (fun n i -> Unvisited) code) - and is_loop_header = ref (PTree.map (fun n i -> false) code) - in let rec dfs_visit code = function + and loop_backedge = ref (PTree.map (fun n i -> None) code) + in let rec dfs_visit code origin = function | [] -> () | node :: ln -> debug "ENTERING node %d, REM are %a\n" (P.to_int node) print_intlist ln; match (get_some @@ PTree.get node !visited) with | Visited -> begin debug "\tNode %d is already Visited, skipping\n" (P.to_int node); - dfs_visit code ln + dfs_visit code origin ln end | Processed -> begin debug "Node %d is a loop header\n" (P.to_int node); - is_loop_header := PTree.set node true !is_loop_header; + debug "The backedge is from %d\n" (P.to_int @@ get_some origin); + loop_backedge := PTree.set node origin !loop_backedge; visited := PTree.set node Visited !visited; - dfs_visit code ln + dfs_visit code origin ln end | Unvisited -> begin visited := PTree.set node Processed !visited; @@ -67,19 +68,26 @@ let get_loop_headers code entrypoint = begin | None -> failwith "No such node" | Some i -> let next_visits = rtl_successors i in begin debug "About to visit: %a\n" print_intlist next_visits; - dfs_visit code next_visits + dfs_visit code (Some node) next_visits end); debug "Node %d is Visited!\n" (P.to_int node); visited := PTree.set node Visited !visited; - dfs_visit code ln + dfs_visit code origin ln end in begin - dfs_visit code [entrypoint]; - debug "LOOP HEADERS: %a\n" print_ptree_bool !is_loop_header; - !is_loop_header + dfs_visit code None [entrypoint]; + debug "LOOP BACKEDGES: %a\n" print_ptree_opint !loop_backedge; + !loop_backedge end end +let get_loop_headers code entrypoint = + let backedges = get_loop_backedges code entrypoint in + PTree.map (fun _ ob -> + match ob with + | None -> false + | Some _ -> true + ) backedges module Dominator = struct diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 3f1a8b6e..5914f6a3 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -126,400 +126,64 @@ let enumerate_aux_flat f reach = * This is a slight alteration to the above heuristic, ensuring that any * superblock will be contiguous in memory, while still following the original * heuristic + * + * Slight change: instead of taking the minimum pc of the superblock, we just take + * the pc of the first block. + * (experimentally this leads to slightly better performance..) *) -let get_some = function -| None -> failwith "Did not get some" -| Some thing -> thing - -exception EmptyList - -let rec last_element = function - | [] -> raise EmptyList - | e :: [] -> e - | e' :: e :: l -> last_element (e::l) - -let print_plist l = - let rec f = function - | [] -> () - | n :: l -> Printf.printf "%d, " (P.to_int n); f l - in begin - if !debug_flag then begin - Printf.printf "["; - f l; - Printf.printf "]" - end - end - -(* adapted from the above join_points function, but with PTree *) -let get_join_points code entry = - let reached = ref (PTree.map (fun n i -> false) code) in - let reached_twice = ref (PTree.map (fun n i -> false) code) in - let rec traverse pc = - if get_some @@ PTree.get pc !reached then begin - if not (get_some @@ PTree.get pc !reached_twice) then - reached_twice := PTree.set pc true !reached_twice - end else begin - reached := PTree.set pc true !reached; - traverse_succs (successors_block @@ get_some @@ PTree.get pc code) - end - and traverse_succs = function - | [] -> () - | [pc] -> traverse pc - | pc :: l -> traverse pc; traverse_succs l - in traverse entry; !reached_twice - -let forward_sequences code entry = - let visited = ref (PTree.map (fun n i -> false) code) in - let join_points = get_join_points code entry in - (* returns the list of traversed nodes, and a list of nodes to start traversing next *) - let rec traverse_fallthrough code node = - (* debug "Traversing %d..\n" (P.to_int node); *) - if not (get_some @@ PTree.get node !visited) then begin - visited := PTree.set node true !visited; - match PTree.get node code with - | None -> failwith "No such node" - | Some bb -> - let ln, rem = match (last_element bb) with - | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ - | Lbuiltin _ -> assert false - | Ltailcall _ | Lreturn -> begin (* debug "STOP tailcall/return\n"; *) ([], []) end - | Lbranch n -> - if get_some @@ PTree.get n join_points then ([], [n]) - else let ln, rem = traverse_fallthrough code n in (ln, rem) - | Lcond (_, _, ifso, ifnot, info) -> (match info with - | None -> begin (* debug "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end - | Some false -> - if get_some @@ PTree.get ifnot join_points then ([], [ifso; ifnot]) - else let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) - | Some true -> - if get_some @@ PTree.get ifso join_points then ([], [ifso; ifnot]) - else let ln, rem = traverse_fallthrough code ifso in (ln, [ifnot] @ rem) - ) - | Ljumptable(_, ln) -> begin (* debug "STOP Ljumptable\n"; *) ([], ln) end - in ([node] @ ln, rem) - end - else ([], []) - in let rec f code = function - | [] -> [] - | node :: ln -> - let fs, rem_from_node = traverse_fallthrough code node - in [fs] @ ((f code rem_from_node) @ (f code ln)) - in (f code [entry]) - -(** Unused code -module PInt = struct - type t = P.t - let compare x y = compare (P.to_int x) (P.to_int y) -end - -module PSet = Set.Make(PInt) - -module LPInt = struct - type t = P.t list - let rec compare x y = - match x with - | [] -> ( match y with - | [] -> 0 - | _ -> 1 ) - | e :: l -> match y with - | [] -> -1 - | e' :: l' -> - let e_cmp = PInt.compare e e' in - if e_cmp == 0 then compare l l' else e_cmp -end - -module LPSet = Set.Make(LPInt) - -let iter_lpset f s = Seq.iter f (LPSet.to_seq s) - -let first_of = function - | [] -> None - | e :: l -> Some e - -let rec last_of = function - | [] -> None - | e :: l -> (match l with [] -> Some e | e :: l -> last_of l) - -let can_be_merged code s s' = - let last_s = get_some @@ last_of s in - let first_s' = get_some @@ first_of s' in - match get_some @@ PTree.get last_s code with - | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ - | Lbuiltin _ | Ltailcall _ | Lreturn -> false - | Lbranch n -> n == first_s' - | Lcond (_, _, ifso, ifnot, info) -> (match info with - | None -> false - | Some false -> ifnot == first_s' - | Some true -> failwith "Inconsistency detected - ifnot is not the preferred branch") - | Ljumptable (_, ln) -> - match ln with - | [] -> false - | n :: ln -> n == first_s' - -let merge s s' = Some s - -let try_merge code (fs: (BinNums.positive list) list) = - let seqs = ref (LPSet.of_list fs) in - let oldLength = ref (LPSet.cardinal !seqs) in - let continue = ref true in - let found = ref false in - while !continue do - begin - found := false; - iter_lpset (fun s -> - if !found then () - else iter_lpset (fun s' -> - if (!found || s == s') then () - else if (can_be_merged code s s') then - begin - seqs := LPSet.remove s !seqs; - seqs := LPSet.remove s' !seqs; - seqs := LPSet.add (get_some (merge s s')) !seqs; - found := true; - end - else () - ) !seqs - ) !seqs; - if !oldLength == LPSet.cardinal !seqs then - continue := false - else - oldLength := LPSet.cardinal !seqs - end - done; - !seqs -*) - -(** Code adapted from Duplicateaux.get_loop_headers - * - * Getting loop branches with a DFS visit : - * Each node is either Unvisited, Visited, or Processed - * pre-order: node becomes Processed - * post-order: node becomes Visited - * - * If we come accross an edge to a Processed node, it's a loop! - *) -type pos = BinNums.positive - -module PP = struct - type t = pos * pos - let compare a b = - let ax, ay = a in - let bx, by = b in - let dx = compare ax bx in - if (dx == 0) then compare ay by - else dx -end - -module PPMap = Map.Make(PP) - -type vstate = Unvisited | Processed | Visited - -let get_loop_edges code entry = - let visited = ref (PTree.map (fun n i -> Unvisited) code) in - let is_loop_edge = ref PPMap.empty - in let rec dfs_visit code from = function - | [] -> () - | node :: ln -> - match (get_some @@ PTree.get node !visited) with - | Visited -> () - | Processed -> begin - let from_node = get_some from in - is_loop_edge := PPMap.add (from_node, node) true !is_loop_edge; - visited := PTree.set node Visited !visited - end - | Unvisited -> begin - visited := PTree.set node Processed !visited; - let bb = get_some @@ PTree.get node code in - let next_visits = (match (last_element bb) with - | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ - | Lbuiltin _ -> assert false - | Ltailcall _ | Lreturn -> [] - | Lbranch n -> [n] - | Lcond (_, _, ifso, ifnot, _) -> [ifso; ifnot] - | Ljumptable(_, ln) -> ln - ) in dfs_visit code (Some node) next_visits; - visited := PTree.set node Visited !visited; - dfs_visit code from ln - end - in begin - dfs_visit code None [entry]; - !is_loop_edge - end - -let ppmap_is_true pp ppmap = PPMap.mem pp ppmap && PPMap.find pp ppmap - -module Int = struct - type t = int - let compare x y = compare x y -end - -module ISet = Set.Make(Int) - -let print_iset s = begin - if !debug_flag then begin - Printf.printf "{"; - ISet.iter (fun e -> Printf.printf "%d, " e) s; - Printf.printf "}" - end -end - -let print_depmap dm = begin - if !debug_flag then begin - Printf.printf "[|"; - Array.iter (fun s -> print_iset s; Printf.printf ", ") dm; - Printf.printf "|]\n" - end -end - -let construct_depmap code entry fs = - let is_loop_edge = get_loop_edges code entry in - let visited = ref (PTree.map (fun n i -> false) code) in - let depmap = Array.map (fun e -> ISet.empty) fs in - let find_index_of_node n = - let index = ref 0 in - begin - Array.iteri (fun i s -> - match List.find_opt (fun e -> e == n) s with - | Some _ -> index := i - | None -> () - ) fs; - !index - end - in let check_and_update_depmap from target = - (* debug "From %d to %d\n" (P.to_int from) (P.to_int target); *) - if not (ppmap_is_true (from, target) is_loop_edge) then - let in_index_fs = find_index_of_node from in - let out_index_fs = find_index_of_node target in - if out_index_fs != in_index_fs then - depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs) - else () - else () - in let rec dfs_visit code = function - | [] -> () - | node :: ln -> - begin - match (get_some @@ PTree.get node !visited) with - | true -> () - | false -> begin - visited := PTree.set node true !visited; - let bb = get_some @@ PTree.get node code in - let next_visits = - match (last_element bb) with - | Ltailcall _ | Lreturn -> [] - | Lbranch n -> (check_and_update_depmap node n; [n]) - | Lcond (_, _, ifso, ifnot, _) -> begin - check_and_update_depmap node ifso; - check_and_update_depmap node ifnot; - [ifso; ifnot] - end - | Ljumptable(_, ln) -> begin - List.iter (fun n -> check_and_update_depmap node n) ln; - ln - end - (* end of bblocks should not be another value than one of the above *) - | _ -> failwith "last_element gave an invalid output" - in dfs_visit code next_visits - end; - dfs_visit code ln - end - in begin - dfs_visit code [entry]; - depmap - end - -let print_sequence s = - if !debug_flag then begin - Printf.printf "["; - List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s; - Printf.printf "]\n" - end - -let print_ssequence ofs = - if !debug_flag then begin - Printf.printf "["; - List.iter (fun s -> print_sequence s) ofs; - Printf.printf "]\n" - end - -let order_sequences code entry fs = - let fs_a = Array.of_list fs in - let depmap = construct_depmap code entry fs_a in - let fs_evaluated = Array.map (fun e -> false) fs_a in - let ordered_fs = ref [] in - let evaluate s_id = - begin - assert (not fs_evaluated.(s_id)); - ordered_fs := fs_a.(s_id) :: !ordered_fs; - fs_evaluated.(s_id) <- true; - (* debug "++++++\n"; - debug "Scheduling %d\n" s_id; - debug "Initial depmap: "; print_depmap depmap; *) - Array.iteri (fun i deps -> - depmap.(i) <- ISet.remove s_id deps - ) depmap; - (* debug "Final depmap: "; print_depmap depmap; *) +let super_blocks f joins = + let blocks = ref [] in + let visited = ref IntSet.empty in + (* start_block: + pc is the function entry point + or a join point + or the successor of a conditional test *) + let rec start_block pc = + let npc = P.to_int pc in + if not (IntSet.mem npc !visited) then begin + visited := IntSet.add npc !visited; + in_block [] npc pc end - in let choose_best_of candidates = - let current_best_id = ref None in - let current_best_score = ref None in - begin - List.iter (fun id -> - match !current_best_id with - | None -> begin - current_best_id := Some id; - match fs_a.(id) with - | [] -> current_best_score := None - | n::l -> current_best_score := Some (P.to_int n) - end - | Some b -> begin - match fs_a.(id) with - | [] -> () - | n::l -> let nscore = P.to_int n in - match !current_best_score with - | None -> (current_best_id := Some id; current_best_score := Some nscore) - | Some bs -> if nscore > bs then (current_best_id := Some id; current_best_score := Some nscore) + (* in_block: add pc to block and check successors *) + and in_block blk minpc pc = + let blk = pc :: blk in + match PTree.get pc f.fn_code with + | None -> assert false + | Some b -> + let rec do_instr_list = function + | [] -> assert false + | Lbranch s :: _ -> next_in_block blk minpc s + | Ltailcall (sig0, ros) :: _ -> end_block blk minpc + | Lcond (cond, args, ifso, ifnot, pred) :: _ -> begin + match pred with + | None -> (end_block blk minpc; start_block ifso; start_block ifnot) + | Some true -> (next_in_block blk minpc ifso; start_block ifnot) + | Some false -> (next_in_block blk minpc ifnot; start_block ifso) end - ) candidates; - !current_best_id - end - in let select_next () = - let candidates = ref [] in - begin - Array.iteri (fun i deps -> - begin - (* debug "Deps of %d: " i; print_iset deps; debug "\n"; *) - (* FIXME - if we keep it that way (no dependency check), remove all the unneeded stuff *) - if ((* deps == ISet.empty && *) not fs_evaluated.(i)) then - candidates := i :: !candidates - end - ) depmap; - if not (List.length !candidates > 0) then begin - Array.iteri (fun i deps -> - if (not fs_evaluated.(i)) then candidates := i :: !candidates - ) depmap; - end; - get_some (choose_best_of !candidates) - end - in begin - debug "-------------------------------\n"; - debug "depmap: "; print_depmap depmap; - debug "forward sequences identified: "; print_ssequence fs; - while List.length !ordered_fs != List.length fs do - let next_id = select_next () in - evaluate next_id - done; - debug "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs)); - List.rev (!ordered_fs) - end + | Ljumptable(arg, tbl) :: _ -> + end_block blk minpc; List.iter start_block tbl + | Lreturn :: _ -> end_block blk minpc + | instr :: b' -> do_instr_list b' in + do_instr_list b + (* next_in_block: check if join point and either extend block + or start block *) + and next_in_block blk minpc pc = + let npc = P.to_int pc in + if IntSet.mem npc joins + then (end_block blk minpc; start_block pc) + else in_block blk minpc pc + (* end_block: record block that we just discovered *) + and end_block blk minpc = + blocks := (minpc, List.rev blk) :: !blocks + in + start_block f.fn_entrypoint; !blocks + +(* Build the enumeration *) -let enumerate_aux_trace f reach = - let code = f.fn_code in - let entry = f.fn_entrypoint in - let fs = forward_sequences code entry in - let ofs = order_sequences code entry fs in - List.flatten ofs +let enumerate_aux_sb f reach = + flatten_blocks (super_blocks f (join_points f)) let enumerate_aux f reach = - if !Clflags.option_ftracelinearize then enumerate_aux_trace f reach + if !Clflags.option_ftracelinearize then enumerate_aux_sb f reach else enumerate_aux_flat f reach diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index aa74a1a1..6d793961 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -868,7 +868,7 @@ Qed. Remark transl_destroyed_by_op: forall op e, destroyed_by_op (transl_op e op) = destroyed_by_op op. Proof. - intros; destruct op; reflexivity. + intros; destruct op; try reflexivity; simpl. Qed. Remark transl_destroyed_by_load: diff --git a/common/DebugPrint.ml b/common/DebugPrint.ml index 5078f727..6f8449ee 100644 --- a/common/DebugPrint.ml +++ b/common/DebugPrint.ml @@ -20,6 +20,20 @@ let print_ptree_bool oc pt = end else () +let print_ptree_opint oc pt = + if !debug_flag then + let elements = PTree.elements pt in + begin + Printf.fprintf oc "["; + List.iter (fun (n, op) -> + match op with + | None -> () + | Some p -> Printf.fprintf oc "%d -> %d, " (P.to_int n) (P.to_int p) + ) elements; + Printf.fprintf oc "]\n" + end + else () + let print_intlist oc l = let rec f oc = function | [] -> () @@ -30,6 +44,20 @@ let print_intlist oc l = end end +let print_ptree_oplist oc pt = + if !debug_flag then + let elements = PTree.elements pt in + begin + Printf.fprintf oc "["; + List.iter (fun (n, ol) -> + match ol with + | None -> () + | Some l -> Printf.fprintf oc "%d -> %a,\n" (P.to_int n) print_intlist l + ) elements; + Printf.fprintf oc "]\n" + end + else () + (* Adapted from backend/PrintRTL.ml: print_function *) let print_code code = let open PrintRTL in let open Printf in if (!debug_flag) then begin diff --git a/compcert_build_env.dockerfile b/compcert_build_env.dockerfile new file mode 100644 index 00000000..de339e55 --- /dev/null +++ b/compcert_build_env.dockerfile @@ -0,0 +1,6 @@ +FROM debian:stable-20210408 +LABEL maintainer="David.Monniaux@univ-grenoble-alpes.fr" +RUN apt-get update && apt-get upgrade -y && apt-get -y install gcc-powerpc-linux-gnu gcc-powerpc64-linux-gnu gcc-riscv64-linux-gnu gcc-arm-linux-gnueabi gcc-arm-linux-gnueabihf gcc-aarch64-linux-gnu qemu-user opam +RUN adduser --gecos "Application user" appuser +USER appuser +RUN opam init --disable-sandboxing && opam switch create 4.11.2+flambda && eval $(opam config env) && opam pin -y add -n coq 8.12.2 && opam install -y menhir ocamlbuild coq diff --git a/compcert_kvx.dockerfile b/compcert_kvx.dockerfile new file mode 100644 index 00000000..21b15308 --- /dev/null +++ b/compcert_kvx.dockerfile @@ -0,0 +1,19 @@ +FROM compcert_build_env +USER root +RUN mkdir /opt/CompCert && chown appuser:appuser /opt/CompCert +COPY --chown=appuser:appuser . CompCert +USER appuser + +RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_aarch64.sh && make && make install + +RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_arm.sh && make && make install + +RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_armhf.sh && make && make install + +# RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_ia32.sh && make && make install + +RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_x86_64.sh && make && make install + +# RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_rv32.sh && make && make install + +RUN eval $(opam config env) && cd CompCert && git clean -dfx && git reset --hard && ./config_rv64.sh && make && make install diff --git a/compcert_kvx_pruned.dockerfile b/compcert_kvx_pruned.dockerfile new file mode 100644 index 00000000..c122cb83 --- /dev/null +++ b/compcert_kvx_pruned.dockerfile @@ -0,0 +1,5 @@ +FROM compcert_kvx +USER root +RUN apt-get -y install gcc && apt-get -y remove opam && apt-get -y autoremove +RUN rm -rf /home/appuser/.opam /home/appuser/CompCert +USER appuser @@ -561,9 +561,9 @@ esac echo "Testing OCaml... " | tr -d '\n' ocaml_ver=`ocamlc -version 2>/dev/null` case "$ocaml_ver" in - 4.00.*|4.01.*| 4.02.*|4.03.*|4.04.*) + 4.00.*|4.01.*| 4.02.*|4.03.*|4.04.*|4.05.*) echo "version $ocaml_ver -- UNSUPPORTED" - echo "Error: CompCert requires OCaml version 4.05 or later." + echo "Error: CompCert requires OCaml version 4.06 or later." missingtools=true;; 4.*) echo "version $ocaml_ver -- good!";; @@ -688,6 +688,7 @@ HAS_STANDARD_HEADERS=$has_standard_headers INSTALL_COQDEV=$install_coqdev LIBMATH=$libmath MODEL=$model +OS=${os:-unspecified} SYSTEM=$system RESPONSEFILE=$responsefile LIBRARY_FLOCQ=$library_Flocq diff --git a/cparser/Machine.ml b/cparser/Machine.ml index a0db245b..6c10715f 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -243,7 +243,7 @@ let rv64 = struct_passing_style = SP_ref_callee; (* Wrong *) struct_return_style = SR_ref } (* to check *) -let kvx = +let kvxbase = { name = "kvx"; char_signed = true; wchar_signed = true; @@ -276,7 +276,15 @@ let kvx = supports_unaligned_accesses = true; struct_passing_style = SP_value32_ref_callee; struct_return_style = SR_int1to4; - has_non_trapping_loads = true; + has_non_trapping_loads = false; +} + +let kvxcos = + { kvxbase with has_non_trapping_loads = false; +} + +let kvxmbr = + { kvxbase with has_non_trapping_loads = true; } let aarch64 = diff --git a/cparser/Machine.mli b/cparser/Machine.mli index 11c73985..bdbec976 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -89,7 +89,8 @@ val arm_littleendian : t val arm_bigendian : t val rv32 : t val rv64 : t -val kvx : t +val kvxmbr : t +val kvxcos : t val aarch64 : t val aarch64_apple : t diff --git a/doc/index-kvx.html b/doc/index-kvx.html index 6d56cbdb..62afb423 100644 --- a/doc/index-kvx.html +++ b/doc/index-kvx.html @@ -278,7 +278,7 @@ This IR is generic over the processor, even if currently, only used for KVX. </TD> <TD>RTL to RTL</TD> <TD><A HREF="html/compcert.backend.Duplicate.html">Duplicate</A> (generic checker)</TD> - <TD><A HREF="html/compcert.scheduling.Duplicateproof.html">Duplicateproof</A> (generic proof)<BR> + <TD><A HREF="html/compcert.backend.Duplicateproof.html">Duplicateproof</A> (generic proof)<BR> <a href="html/compcert.backend.Duplicatepasses.html">Duplicatepasses</a> (several passes from several oracles)</TD> </TR> <TR valign="top" style="color:#000000"> diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 4cff3f28..fa17c2d9 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -105,7 +105,8 @@ let option_fmadd = ref true let option_div_i32 = ref "stsud" let option_div_i64 = ref "stsud" let option_fcoalesce_mem = ref true -let option_fexpanse_rtlcond = ref true +let option_fexpanse_rtlcond = ref false +let option_fexpanse_others = ref false let option_fforward_moves = ref false let option_fmove_loop_invariants = ref false let option_fnontrap_loads = ref true diff --git a/driver/Configuration.ml b/driver/Configuration.ml index 3c9aff5e..deca85f2 100644 --- a/driver/Configuration.ml +++ b/driver/Configuration.ml @@ -126,6 +126,7 @@ let arch = | "powerpc"|"arm"|"x86"|"riscV"|"kvx"|"aarch64" as a -> a | v -> bad_config "arch" [v] let model = get_config_string "model" +let os = get_config_string "os" let abi = get_config_string "abi" let is_big_endian = match get_config_string "endianness" with diff --git a/driver/Configuration.mli b/driver/Configuration.mli index a71da72d..75e547ff 100644 --- a/driver/Configuration.mli +++ b/driver/Configuration.mli @@ -19,6 +19,9 @@ val model: string val abi: string (** ABI to use *) +val os: string + (** ABI to use *) + val is_big_endian: bool (** Endianness to use *) diff --git a/driver/Driver.ml b/driver/Driver.ml index 0c5d9cb4..7192ba4b 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -445,6 +445,7 @@ let cmdline_actions = @ f_opt "nontrap-loads" option_fnontrap_loads @ f_opt "coalesce-mem" option_fcoalesce_mem @ f_opt "expanse-rtlcond" option_fexpanse_rtlcond + @ f_opt "expanse-others" option_fexpanse_others @ f_opt "all-loads-nontrap" option_all_loads_nontrap @ f_opt "forward-moves" option_fforward_moves (* Code generation options *) diff --git a/driver/Frontend.ml b/driver/Frontend.ml index 9dec32fa..0d0ff26c 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -117,7 +117,10 @@ let init () = | "riscV" -> if Configuration.model = "64" then Machine.rv64 else Machine.rv32 - | "kvx" -> Machine.kvx + | "kvx" -> if Configuration.os = "cos" then Machine.kvxcos + else if Configuration.os = "mbr" then Machine.kvxmbr + else (Printf.eprintf "Configuration OS = %s\n" Configuration.os; + failwith "Wrong OS configuration for KVX") | "aarch64" -> if Configuration.abi = "apple" then Machine.aarch64_apple else Machine.aarch64 diff --git a/make_docker.sh b/make_docker.sh new file mode 100755 index 00000000..9665be4d --- /dev/null +++ b/make_docker.sh @@ -0,0 +1,3 @@ +docker build -t compcert_build_env -f compcert_build_env.dockerfile . +docker build -t compcert_kvx -f compcert_kvx.dockerfile . +docker build -t compcert_kvx_pruned -f compcert_kvx_pruned.dockerfile . diff --git a/riscV/Asm.v b/riscV/Asm.v index 7e8ba760..2bc6d956 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -982,6 +982,7 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Pbuiltin ef args res => Stuck (**r treated specially below *) + | Pnop => Next (nextinstr rs) m (**r Pnop is used by an oracle during expansion *) (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) @@ -1002,7 +1003,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsubd _ _ _ _ | Pfnmaddd _ _ _ _ | Pfnmsubd _ _ _ _ - | Pnop => Stuck end. diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 957166b6..3e84e950 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -105,6 +105,8 @@ Definition addimm32 := opimm32 Paddw Paddiw. Definition andimm32 := opimm32 Pandw Pandiw. Definition orimm32 := opimm32 Porw Poriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. +Definition sltimm32 := opimm32 Psltw Psltiw. +Definition sltuimm32 := opimm32 Psltuw Psltiuw. Definition load_hilo64 (r: ireg) (hi lo: int64) k := if Int64.eq lo Int64.zero then Pluil r hi :: k @@ -130,6 +132,8 @@ Definition addimm64 := opimm64 Paddl Paddil. Definition andimm64 := opimm64 Pandl Pandil. Definition orimm64 := opimm64 Porl Poril. Definition xorimm64 := opimm64 Pxorl Pxoril. +Definition sltimm64 := opimm64 Psltl Psltil. +Definition sltuimm64 := opimm64 Psltul Psltiul. Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := if Ptrofs.eq_dec n Ptrofs.zero then @@ -141,75 +145,332 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := (** Translation of conditional branches. *) -Definition apply_bin_r0_r0r0lbl (optR0: option bool) (sem: ireg0 -> ireg0 -> label -> instruction) (r1 r2: ireg0) (lbl: label) := - match optR0 with - | None => sem r1 r2 lbl - | Some true => sem X0 r1 lbl - | Some false => sem r1 X0 lbl - end. +Definition transl_cbranch_int32s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltw r1 r2 lbl + | Cle => Pbgew r2 r1 lbl + | Cgt => Pbltw r2 r1 lbl + | Cge => Pbgew r1 r2 lbl + end. + +Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeqw r1 r2 lbl + | Cne => Pbnew r1 r2 lbl + | Clt => Pbltuw r1 r2 lbl + | Cle => Pbgeuw r2 r1 lbl + | Cgt => Pbltuw r2 r1 lbl + | Cge => Pbgeuw r1 r2 lbl + end. -Definition apply_bin_r0_r0r0 (optR0: option bool) (sem: ireg0 -> ireg0 -> instruction) (r1 r2: ireg0) := - match optR0 with - | None => sem r1 r2 - | Some true => sem X0 r1 - | Some false => sem r1 X0 +Definition transl_cbranch_int64s (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltl r1 r2 lbl + | Cle => Pbgel r2 r1 lbl + | Cgt => Pbltl r2 r1 lbl + | Cge => Pbgel r1 r2 lbl end. +Definition transl_cbranch_int64u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := + match cmp with + | Ceq => Pbeql r1 r2 lbl + | Cne => Pbnel r1 r2 lbl + | Clt => Pbltul r1 r2 lbl + | Cle => Pbgeul r2 r1 lbl + | Cgt => Pbltul r2 r1 lbl + | Cge => Pbgeul r1 r2 lbl + end. + +Definition transl_cond_float (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqd rd fs1 fs2, true) + | Cne => (Pfeqd rd fs1 fs2, false) + | Clt => (Pfltd rd fs1 fs2, true) + | Cle => (Pfled rd fs1 fs2, true) + | Cgt => (Pfltd rd fs2 fs1, true) + | Cge => (Pfled rd fs2 fs1, true) + end. + +Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := + match cmp with + | Ceq => (Pfeqs rd fs1 fs2, true) + | Cne => (Pfeqs rd fs1 fs2, false) + | Clt => (Pflts rd fs1 fs2, true) + | Cle => (Pfles rd fs1 fs2, true) + | Cgt => (Pflts rd fs2 fs1, true) + | Cge => (Pfles rd fs2 fs1, true) + end. + +(** Functions to select a special register according to the op "oreg" argument from RTL *) + +Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ireg0) := + match optR with + | None => (r1, r2) + | Some X0_L => (X0, r1) + | Some X0_R => (r1, X0) + end. + +Definition get_oreg (optR: option oreg) (r: ireg0) := + match optR with + | Some X0_L | Some X0_R => X0 + | _ => r + end. + Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with - | CEbeqw optR0, a1 :: a2 :: nil => + | Ccomp c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) - | CEbnew optR0, a1 :: a2 :: nil => + OK (transl_cbranch_int32s c r1 r2 lbl :: k) + | Ccompu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnew r1 r2 lbl :: k) - | CEbequw optR0, a1 :: a2 :: nil => + OK (transl_cbranch_int32u c r1 r2 lbl :: k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32s c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32s c r1 X31 lbl :: k)) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + transl_cbranch_int32u c r1 X0 lbl :: k + else + loadimm32 X31 n (transl_cbranch_int32u c r1 X31 lbl :: k)) + | Ccompl c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) - | CEbneuw optR0, a1 :: a2 :: nil => + OK (transl_cbranch_int64s c r1 r2 lbl :: k) + | Ccomplu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnew r1 r2 lbl :: k) - | CEbltw optR0, a1 :: a2 :: nil => + OK (transl_cbranch_int64u c r1 r2 lbl :: k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64s c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64s c r1 X31 lbl :: k)) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + transl_cbranch_int64u c r1 X0 lbl :: k + else + loadimm64 X31 n (transl_cbranch_int64u c r1 X31 lbl :: k)) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c X31 r1 r2 in + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + + | CEbeqw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltw r1 r2 lbl :: k) - | CEbltuw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeqw r1' r2' lbl :: k) + | CEbnew optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltuw r1 r2 lbl :: k) - | CEbgew optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnew r1' r2' lbl :: k) + | CEbequw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgew r1 r2 lbl :: k) - | CEbgeuw optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeqw r1' r2' lbl :: k) + | CEbneuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgeuw r1 r2 lbl :: k) - | CEbeql optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnew r1' r2' lbl :: k) + | CEbltw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeql r1 r2 lbl :: k) - | CEbnel optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltw r1' r2' lbl :: k) + | CEbltuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnel r1 r2 lbl :: k) - | CEbequl optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltuw r1' r2' lbl :: k) + | CEbgew optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbeql r1 r2 lbl :: k) - | CEbneul optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgew r1' r2' lbl :: k) + | CEbgeuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbnel r1 r2 lbl :: k) - | CEbltl optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgeuw r1' r2' lbl :: k) + | CEbeql optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltl r1 r2 lbl :: k) - | CEbltul optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeql r1' r2' lbl :: k) + | CEbnel optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbltul r1 r2 lbl :: k) - | CEbgel optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnel r1' r2' lbl :: k) + | CEbequl optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgel r1 r2 lbl :: k) - | CEbgeul optR0, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeql r1' r2' lbl :: k) + | CEbneul optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (apply_bin_r0_r0r0lbl optR0 Pbgeul r1 r2 lbl :: k) + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnel r1' r2' lbl :: k) + | CEbltl optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltl r1' r2' lbl :: k) + | CEbltul optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltul r1' r2' lbl :: k) + | CEbgel optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgel r1' r2' lbl :: k) + | CEbgeul optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgeul r1' r2' lbl :: k) | _, _ => Error(msg "Asmgen.transl_cond_branch") end. +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltw rd r1 r2 :: k + | Cle => Psltw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltw rd r2 r1 :: k + | Cge => Psltw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int32u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseqw rd r1 r2 :: k + | Cne => Psnew rd r1 r2 :: k + | Clt => Psltuw rd r1 r2 :: k + | Cle => Psltuw rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltuw rd r2 r1 :: k + | Cge => Psltuw rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64s (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltl rd r1 r2 :: k + | Cle => Psltl rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltl rd r2 r1 :: k + | Cge => Psltl rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_cond_int64u (cmp: comparison) (rd: ireg) (r1 r2: ireg0) (k: code) := + match cmp with + | Ceq => Pseql rd r1 r2 :: k + | Cne => Psnel rd r1 r2 :: k + | Clt => Psltul rd r1 r2 :: k + | Cle => Psltul rd r2 r1 :: Pxoriw rd rd Int.one :: k + | Cgt => Psltul rd r2 r1 :: k + | Cge => Psltul rd r1 r2 :: Pxoriw rd rd Int.one :: k + end. + +Definition transl_condimm_int32s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm32 rd r1 n (transl_cond_int32s cmp rd rd X0 k) + | Clt => sltimm32 rd r1 n k + | Cle => if Int.eq n (Int.repr Int.max_signed) + then loadimm32 rd Int.one k + else sltimm32 rd r1 (Int.add n Int.one) k + | _ => loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int32u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int) (k: code) := + if Int.eq n Int.zero then transl_cond_int32u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm32 rd r1 n k + | _ => loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64s (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64s cmp rd r1 X0 k else + match cmp with + | Ceq | Cne => xorimm64 rd r1 n (transl_cond_int64s cmp rd rd X0 k) + | Clt => sltimm64 rd r1 n k + | Cle => if Int64.eq n (Int64.repr Int64.max_signed) + then loadimm32 rd Int.one k + else sltimm64 rd r1 (Int64.add n Int64.one) k + | _ => loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k) + end. + +Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int64) (k: code) := + if Int64.eq n Int64.zero then transl_cond_int64u cmp rd r1 X0 k else + match cmp with + | Clt => sltuimm64 rd r1 n k + | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) + end. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) + | Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | _, _ => + Error(msg "Asmgen.transl_cond_op") + end. + (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -523,36 +784,47 @@ Definition transl_op | Osingleoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) - | OEseqw optR0, a1 :: a2 :: nil => + | Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k + + (* Instructions expanded in RTL *) + | OEseqw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseqw rd) rs1 rs2 :: k) - | OEsnew optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseqw rd rs1' rs2' :: k) + | OEsnew optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnew rd) rs1 rs2 :: k) - | OEsequw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnew rd rs1' rs2' :: k) + | OEsequw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseqw rd) rs1 rs2 :: k) - | OEsneuw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseqw rd rs1' rs2' :: k) + | OEsneuw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnew rd) rs1 rs2 :: k) - | OEsltw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnew rd rs1' rs2' :: k) + | OEsltw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltw rd) rs1 rs2 :: k) - | OEsltuw optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltw rd rs1' rs2' :: k) + | OEsltuw optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltuw rd) rs1 rs2 :: k) + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltuw rd rs1' rs2' :: k) | OEsltiw n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -565,42 +837,62 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pxoriw rd rs n :: k) - | OEluiw n _, a1 :: nil => + | OEluiw n, nil => do rd <- ireg_of res; OK (Pluiw rd n :: k) - | OEaddiwr0 n _, a1 :: nil => + | OEaddiw optR n, nil => + do rd <- ireg_of res; + let rs := get_oreg optR X0 in + OK (Paddiw rd rs n :: k) + | OEaddiw optR n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + let rs' := get_oreg optR rs in + OK (Paddiw rd rs' n :: k) + | OEandiw n, a1 :: nil => do rd <- ireg_of res; - OK (Paddiw rd X0 n :: k) - | OEseql optR0, a1 :: a2 :: nil => + do rs <- ireg_of a1; + OK (Pandiw rd rs n :: k) + | OEoriw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Poriw rd rs n :: k) + | OEseql optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseql rd) rs1 rs2 :: k) - | OEsnel optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseql rd rs1' rs2' :: k) + | OEsnel optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnel rd) rs1 rs2 :: k) - | OEsequl optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnel rd rs1' rs2' :: k) + | OEsequl optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Pseql rd) rs1 rs2 :: k) - | OEsneul optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseql rd rs1' rs2' :: k) + | OEsneul optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psnel rd) rs1 rs2 :: k) - | OEsltl optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnel rd rs1' rs2' :: k) + | OEsltl optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltl rd) rs1 rs2 :: k) - | OEsltul optR0, a1 :: a2 :: nil => + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltl rd rs1' rs2' :: k) + | OEsltul optR, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (apply_bin_r0_r0r0 optR0 (Psltul rd) rs1 rs2 :: k) + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltul rd rs1' rs2' :: k) | OEsltil n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -613,12 +905,26 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pxoril rd rs n :: k) - | OEluil n, a1 :: nil => + | OEluil n, nil => do rd <- ireg_of res; OK (Pluil rd n :: k) - | OEaddilr0 n, a1 :: nil => + | OEaddil optR n, nil => do rd <- ireg_of res; - OK (Paddil rd X0 n :: k) + let rs := get_oreg optR X0 in + OK (Paddil rd rs n :: k) + | OEaddil optR n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + let rs' := get_oreg optR rs in + OK (Paddil rd rs' n :: k) + | OEandil n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pandil rd rs n :: k) + | OEoril n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Poril rd rs n :: k) | OEloadli n, nil => do rd <- ireg_of res; OK (Ploadli rd n :: k) @@ -652,6 +958,13 @@ Definition transl_op do r1 <- freg_of f1; do r2 <- freg_of f2; OK (Pfles rd r1 r2 :: k) + | OEmayundef _, a1 :: a2 :: nil => + do rd <- ireg_of res; + do r2 <- ireg_of a2; + if ireg_eq rd r2 then + OK (Pnop :: k) + else + OK (Pmv rd r2 :: k) | Obits_of_single, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index d9715984..a7259390 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -161,37 +161,165 @@ Proof. Qed. Hint Resolve addptrofs_label: labels. +Remark transl_cond_float_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_float c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_float; intros. destruct c; inv H; exact I. +Qed. + +Remark transl_cond_single_nolabel: + forall c r1 r2 r3 insn normal, + transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. +Proof. + unfold transl_cond_single; intros. destruct c; inv H; exact I. + Qed. + Remark transl_cbranch_label: forall cond args lbl k c, transl_cbranch cond args lbl k = OK c -> tail_nolabel k c. Proof. intros. unfold transl_cbranch in H; destruct cond; TailNoLabel. - all: destruct optR0 as [[]|]; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int.eq n Int.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int32u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64s c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. + apply tail_nolabel_trans with (transl_cbranch_int64u c0 x X31 lbl :: k). + auto with labels. destruct c0; simpl; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. +Remark transl_cond_op_label: + forall cond args r k c, + transl_cond_op cond r args k = OK c -> tail_nolabel k c. +Proof. + intros. unfold transl_cond_op in H; destruct cond; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int32s. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm32_label; intros; exact I | TailNoLabel]. +* apply opimm32_label; intros; exact I. +* destruct (Int.eq n (Int.repr Int.max_signed)). apply loadimm32_label. apply opimm32_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm32_label. TailNoLabel. +- unfold transl_condimm_int32u. + destruct (Int.eq n Int.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). + apply opimm32_label; intros; exact I. +- destruct c0; simpl; TailNoLabel. + - destruct c0; simpl; TailNoLabel. +- unfold transl_condimm_int64s. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* eapply tail_nolabel_trans; [apply opimm64_label; intros; exact I | TailNoLabel]. +* apply opimm64_label; intros; exact I. +* destruct (Int64.eq n (Int64.repr Int64.max_signed)). apply loadimm32_label. apply opimm64_label; intros; exact I. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +* eapply tail_nolabel_trans. apply loadimm64_label. TailNoLabel. +- unfold transl_condimm_int64u. + destruct (Int64.eq n Int64.zero). ++ destruct c0; simpl; TailNoLabel. ++ destruct c0; simpl; + try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). + apply opimm64_label; intros; exact I. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. +- destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. + apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. + destruct normal; TailNoLabel. + Qed. + Remark transl_op_label: forall op args r k c, transl_op op args r k = OK c -> tail_nolabel k c. Proof. Opaque Int.eq. unfold transl_op; intros; destruct op; TailNoLabel. - { destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. } - { destruct (Float.eq_dec n Float.zero); TailNoLabel. } - { destruct (Float32.eq_dec n Float32.zero); TailNoLabel. } - { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). - + eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. - + TailNoLabel. } - { apply opimm32_label; intros; exact I. } - { apply opimm32_label; intros; exact I. } - { apply opimm32_label; intros; exact I. } - { apply opimm32_label; intros; exact I. } - { destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. } - { apply opimm64_label; intros; exact I. } - { apply opimm64_label; intros; exact I. } - { apply opimm64_label; intros; exact I. } - { apply opimm64_label; intros; exact I. } - { destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. } - all: destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel. +- destruct (Float.eq_dec n Float.zero); TailNoLabel. +- destruct (Float32.eq_dec n Float32.zero); TailNoLabel. +- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ eapply tail_nolabel_trans; [|apply addptrofs_label]. TailNoLabel. ++ TailNoLabel. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- apply opimm32_label; intros; exact I. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- apply opimm64_label; intros; exact I. +- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. +- eapply transl_cond_op_label; eauto. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. +- destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 379b5789..6abde89f 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -290,6 +290,102 @@ Proof. rewrite H0 in B. inv B. auto. Qed. +(** Translation of conditional branches *) + +Lemma transl_cbranch_int32s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- destruct rs##r1; simpl in H; try discriminate. destruct rs##r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmp_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int32u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (transl_cbranch_int32u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cbranch_int64s_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64s cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- destruct rs###r1; simpl in H; try discriminate. destruct rs###r2; inv H. + simpl; auto. +- auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmpl_bool. simpl. rewrite H; auto. +- auto. +Qed. + +Lemma transl_cbranch_int64u_correct: + forall cmp r1 r2 lbl (rs: regset) m b, + Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (transl_cbranch_int64u cmp r1 r2 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct cmp; simpl; rewrite ? H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +- rewrite <- Val.swap_cmplu_bool. simpl. rewrite H; auto. +Qed. + +Lemma transl_cond_float_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_float cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpf cmp rs#r1 rs#r2 else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- rewrite Val.negate_cmpf_eq. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpf, Val.cmpf_bool. + rewrite <- Float.cmp_swap. auto. +Qed. + +Lemma transl_cond_single_correct: + forall (rs: regset) m cmp rd r1 r2 insn normal v, + transl_cond_single cmp rd r1 r2 = (insn, normal) -> + v = (if normal then Val.cmpfs cmp rs#r1 rs#r2 else Val.notbool (Val.cmpfs cmp rs#r1 rs#r2)) -> + exec_instr ge fn insn rs m = Next (nextinstr (rs#rd <- v)) m. +Proof. + intros. destruct cmp; simpl in H; inv H; auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite Float32.cmp_ne_eq. destruct (Float32.cmp Ceq f0 f); auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. +- simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. + rewrite <- Float32.cmp_swap. auto. + Qed. + +(* TODO gourdinl UNUSUED ? Remark branch_on_X31: + forall normal lbl (rs: regset) m b, + rs#X31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) rs m = + eval_branch fn lbl rs m (Some b). +Proof. + intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. + Qed.*) + Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -321,84 +417,219 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. - (* Pbeqw / Cmp *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; auto; - simpl in *. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int.eq Int.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int.eq i Int.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: (Int.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbnew / Cmp *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; auto; - simpl in *. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int.eq Int.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: negb (Int.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbeqw, Pbnew, Pbltw, Pbtluw, Pbgew, Pbgeuw / Cmpu *) - 1-6: - destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero32, Op.zero32 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. - (* Pbeql / Cmpl *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int64.eq Int64.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: (Int64.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbnel / Cmpl *) - { destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. - rewrite HB; destruct b; simpl; auto. - + destruct (rs x); simpl in *; try congruence. - destruct (rs x0); try congruence. - assert (HB: negb (Int64.eq i i0) = b) by congruence. - rewrite HB; destruct b; simpl; auto. } - (* Pbeql, Pbnel, Pbltl, Pbtlul, Pbgel, Pbgeul / Cmplu *) - 1-6: - destruct optR0 as [[]|]; - unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; - unfold zero64, Op.zero64 in *; - eexists; eexists; eauto; split; constructor; - simpl in *; try rewrite EVAL'; auto. + - exists rs, (transl_cbranch_int32s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. +- exists rs, (transl_cbranch_int32u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int.eq Int.eq_spec n Int.zero. ++ subst n. exists rs, (transl_cbranch_int32u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. ++ exploit (loadimm32_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int32u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int32u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- exists rs, (transl_cbranch_int64s c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. +- exists rs, (transl_cbranch_int64u c0 x x0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64s c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64s_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64s c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64s_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- predSpec Int64.eq Int64.eq_spec n Int64.zero. ++ subst n. exists rs, (transl_cbranch_int64u c0 x X0 lbl). + intuition auto. constructor. apply transl_cbranch_int64u_correct; auto. ++ exploit (loadimm64_correct X31 n); eauto. intros (rs' & A & B & C). + exists rs', (transl_cbranch_int64u c0 x X31 lbl). + split. constructor; eexact A. split; auto. + apply transl_cbranch_int64u_correct; auto. + simpl; rewrite B, C; eauto with asmgen. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpf. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_float c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpf_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpf c0 rs#x rs#x0 else Val.notbool (Val.cmpf c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpf. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (eqb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL'. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. +- destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:TC; inv EQ2. + assert (EVAL'': Val.cmpfs_bool c0 (rs x) (rs x0) = Some (negb b)). + { destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; inv EVAL'; auto. } + set (v := if normal then Val.cmpfs c0 rs#x rs#x0 else Val.notbool (Val.cmpfs c0 rs#x rs#x0)). + assert (V: v = Val.of_bool (xorb normal b)). + { unfold v, Val.cmpfs. rewrite EVAL''. destruct normal, b; reflexivity. } + econstructor; econstructor. + split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split. rewrite V; destruct normal, b; reflexivity. + intros; Simpl. + +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + inv EQ2; eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + rewrite EQRS; + assert (HB: (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + rewrite EQRS; + assert (HB: (Int.eq i Int.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; + destruct (rs x0); try congruence. + assert (HB: (Int.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + inv EQ2; eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + rewrite EQRS; + assert (HB: negb (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + rewrite EQRS; + assert (HB: negb (Int.eq i Int.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; + destruct (rs x0); try congruence. + assert (HB: negb (Int.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + rewrite EQRS; + assert (HB: (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + rewrite EQRS; + assert (HB: (Int64.eq i Int64.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; + destruct (rs x0); try congruence. + assert (HB: (Int64.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; inv EQ2; + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + rewrite EQRS; + assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + rewrite EQRS; + assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + + rewrite EQRS; + destruct (rs x0); try congruence. + assert (HB: negb (Int64.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32, zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. Qed. Lemma transl_cbranch_correct_true: @@ -432,6 +663,405 @@ Proof. intros; Simpl. Qed. +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs##r1 rs##r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs##r1); auto. destruct (rs##r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. + simpl. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r2 rs##r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmp. rewrite <- Val.swap_cmp_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmp. rewrite (Val.negate_cmp_bool Clt). + destruct (Val.cmp_bool Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int32u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.cmpu (Mem.valid_pointer m) cmp rs##r1 rs##r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. + simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Cle rs##r1 rs##r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpu. rewrite <- Val.swap_cmpu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpu. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmpu_bool (Mem.valid_pointer m) Clt rs##r1 rs##r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64s cmp rd r1 r2 k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs###r1 rs###r2)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. destruct (rs###r1); auto. destruct (rs###r2); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. + simpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r2 rs###r1) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmpl. rewrite <- Val.swap_cmpl_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmpl. rewrite (Val.negate_cmpl_bool Clt). + destruct (Val.cmpl_bool Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge fn (transl_cond_int64u cmp rd r1 r2 k) rs m k rs' m + /\ rs'#rd = Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs###r1 rs###r2) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. + simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cle). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Cle rs###r1 rs###r2) as [[]|]; auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. unfold Val.cmplu. rewrite <- Val.swap_cmplu_bool. auto. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold Val.cmplu. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Clt). + destruct (Val.cmplu_bool (Mem.valid_pointer m) Clt rs###r1 rs###r2) as [[]|]; auto. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32s. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm32. + exploit (opimm32_correct Pxorw Pxoriw Val.xor); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmp in B2; simpl in B2; rewrite Int.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int.eq Int.eq_spec n (Int.repr Int.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmp; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int.lt. rewrite zlt_false. auto. + change (Int.signed (Int.repr Int.max_signed)) with Int.max_signed. + generalize (Int.signed_range i); omega. +* exploit (opimm32_correct Psltw Psltiw (Val.cmp Clt)); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmp; simpl; destruct (rs#r1); simpl; auto. + unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). + destruct (zlt (Int.signed n) (Int.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int.add_signed. symmetry; apply Int.signed_repr. + assert (Int.signed n <> Int.max_signed). + { red; intros E. elim H1. rewrite <- (Int.repr_signed n). rewrite E. auto. } + generalize (Int.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int32u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int32u. + predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. exploit transl_cond_int32u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm32 X31 n (transl_cond_int32u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int32u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm32_correct Psltuw Psltiuw (Val.cmpu (Mem.valid_pointer m) Clt) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64s cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64s. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64s_correct. intros (rs' & A & B & C). + exists rs'; eauto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64s cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ unfold xorimm64. + exploit (opimm64_correct Pxorl Pxoril Val.xorl); eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64s_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2; rewrite B1 in B2; simpl in B2. destruct (rs#r1); auto. + unfold Val.cmpl in B2; simpl in B2; rewrite Int64.xor_is_zero in B2. exact B2. + intros; transitivity (rs1 r); auto. ++ exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ predSpec Int64.eq Int64.eq_spec n (Int64.repr Int64.max_signed). +* subst n. exploit loadimm32_correct; eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + unfold Val.cmpl; destruct (rs#r1); simpl; auto. rewrite B1. + unfold Int64.lt. rewrite zlt_false. auto. + change (Int64.signed (Int64.repr Int64.max_signed)) with Int64.max_signed. + generalize (Int64.signed_range i); omega. +* exploit (opimm64_correct Psltl Psltil (fun v1 v2 => Val.maketotal (Val.cmpl Clt v1 v2))); eauto. intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. + rewrite B1. unfold Val.cmpl; simpl; destruct (rs#r1); simpl; auto. + unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). + destruct (zlt (Int64.signed n) (Int64.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. + assert (Int64.signed n <> Int64.max_signed). + { red; intros E. elim H1. rewrite <- (Int64.repr_signed n). rewrite E. auto. } + generalize (Int64.signed_range n); omega. ++ apply DFL. ++ apply DFL. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> X31 -> + exists rs', + exec_straight ge fn (transl_condimm_int64u cmp rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + intros. unfold transl_condimm_int64u. + predSpec Int64.eq Int64.eq_spec n Int64.zero. +- subst n. exploit transl_cond_int64u_correct. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. rewrite B; auto. +- assert (DFL: + exists rs', + exec_straight ge fn (loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k)) rs m k rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r). + { exploit loadimm64_correct; eauto. intros (rs1 & A1 & B1 & C1). + exploit transl_cond_int64u_correct; eauto. intros (rs2 & A2 & B2 & C2). + exists rs2; split. + eapply exec_straight_trans. eexact A1. eexact A2. + split. simpl in B2. rewrite B1, C1 in B2 by auto with asmgen. rewrite B2; auto. + intros; transitivity (rs1 r); auto. } + destruct cmp. ++ apply DFL. ++ apply DFL. ++ exploit (opimm64_correct Psltul Psltiul (fun v1 v2 => Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 v2)) m); eauto. + intros (rs1 & A1 & B1 & C1). + exists rs1; split. eexact A1. split; auto. rewrite B1; auto. ++ apply DFL. ++ apply DFL. ++ apply DFL. + Qed. + +Lemma transl_cond_op_correct: + forall cond rd args k c rs m, + transl_cond_op cond rd args k = OK c -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. +Proof. + assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). + { destruct ob as [[]|]; reflexivity. } + intros until m; intros TR. + destruct cond; simpl in TR; ArgsInv. ++ (* cmp *) + exploit transl_cond_int32s_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B; auto. ++ (* cmpimm *) + apply transl_condimm_int32s_correct; eauto with asmgen. ++ (* cmpuimm *) + apply transl_condimm_int32u_correct; eauto with asmgen. ++ (* cmpl *) + exploit transl_cond_int64s_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. ++ (* cmplimm *) + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpluimm *) + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpf *) + destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. + fold (Val.cmpf c0 (rs x) (rs x0)). + set (v := Val.cmpf c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. + split; intros; Simpl. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_float_correct with (v := Val.notbool v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. ++ (* notcmpf *) + destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. + rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)). + set (v := Val.cmpf c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_float_correct with (v := v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto. + split; intros; Simpl. ++ (* cmpfs *) + destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. + fold (Val.cmpfs c0 (rs x) (rs x0)). + set (v := Val.cmpfs c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. + split; intros; Simpl. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_single_correct with (v := Val.notbool v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. ++ (* notcmpfs *) + destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. + rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)). + set (v := Val.cmpfs c0 (rs x) (rs x0)). + destruct normal; inv EQ2. +* econstructor; split. + eapply exec_straight_two. + eapply transl_cond_single_correct with (v := v); eauto. + simpl; reflexivity. + auto. auto. + split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. +* econstructor; split. + apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. + split; intros; Simpl. + Qed. + (** Some arithmetic properties. *) Remark cast32unsigned_from_cast32signed: @@ -640,18 +1270,53 @@ Opaque Int.eq. eapply exec_straight_step. simpl; reflexivity. auto. apply exec_straight_one. simpl; reflexivity. auto. split; intros; Simpl. } + (* cond *) + { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. } (* Expanded instructions from RTL *) - 7,8,15,16: + 9,10,19,20: econstructor; split; try apply exec_straight_one; simpl; eauto; - split; intros; Simpl; unfold may_undef_int; try destruct is_long; simpl; - try rewrite Int.add_commut; try rewrite Int64.add_commut; - destruct (rs (preg_of m0)); try discriminate; eauto. - 1-12: - destruct optR0 as [[]|]; unfold apply_bin_r0_r0r0, apply_bin_r0; + split; intros; Simpl; try destruct (rs x0); + try rewrite Int64.add_commut; + try rewrite Int.add_commut; auto; + try rewrite Int64.and_commut; + try rewrite Int.and_commut; auto; + try rewrite Int64.or_commut; + try rewrite Int.or_commut; auto. + 1-16: + destruct optR as [[]|]; try discriminate; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; try inv EQ3; try inv EQ2; + try destruct (Int.eq _ _) eqn:A; try inv H0; + try destruct (Int64.eq _ _) eqn:A; try inv H1; econstructor; split; try apply exec_straight_one; simpl; eauto; split; intros; Simpl; - destruct (rs x0); auto; - destruct (rs x1); auto. + try apply Int.same_if_eq in A; subst; + try apply Int64.same_if_eq in A; subst; + unfold get_sp; + try destruct (rs x0); auto; + try destruct (rs x1); auto; + try destruct (rs X2); auto; + try destruct Archi.ptr64 eqn:B; + try fold (Val.add (Vint Int.zero) (get_sp (rs X2))); + try fold (Val.addl (Vlong Int64.zero) (get_sp (rs X2))); + try rewrite Val.add_commut; auto; + try rewrite Val.addl_commut; auto; + try rewrite Int.add_commut; auto; + try rewrite Int64.add_commut; auto; + replace (Ptrofs.of_int Int.zero) with (Ptrofs.zero) by auto; + replace (Ptrofs.of_int64 Int64.zero) with (Ptrofs.zero) by auto; + try rewrite Ptrofs.add_zero; auto. + (* mayundef *) + { destruct (ireg_eq x x0); inv EQ2; + econstructor; split; + try apply exec_straight_one; simpl; eauto; + split; unfold eval_may_undef; + destruct mu eqn:EQMU; simpl; intros; Simpl; auto. + all: + destruct (rs (preg_of m0)) eqn:EQM0; simpl; auto; + destruct (rs x0); simpl; auto; Simpl; + try destruct (Int.ltu _ _); simpl; + Simpl; auto. } (* select *) { econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index 95a300c5..68d4e4d2 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -17,17 +17,27 @@ open Maps open RTL open Op open Asmgen -open DebugPrint open RTLpath open! Integers +open Camlcoq +open Option +open AST +open DebugPrint + +(** Mini CSE (a dynamic numbering is applied during expansion. + The CSE algorithm is inspired by the "static" one used in backend/CSE.v *) + +(** Managing virtual registers and node index *) let reg = ref 1 let node = ref 1 -let r2p () = Camlcoq.P.of_int !reg +let p2i r = P.to_int r -let n2p () = Camlcoq.P.of_int !node +let r2p () = P.of_int !reg + +let n2p () = P.of_int !node let r2pi () = reg := !reg + 1; @@ -37,300 +47,563 @@ let n2pi () = node := !node + 1; n2p () -type immt = Xoriw | Xoril | Sltiw | Sltiuw | Sltil | Sltiul +(** Below are the types for rhs and equations *) + +type rhs = Sop of operation * int list | Smove + +type seq = Seq of int * rhs + +(** This is a mini abstraction to have a simpler representation during expansion + - Snop will be converted to Inop + - (Sr r) is inserted if the value was found in register r + - (Sexp dest rhs args succ) represent an instruction + (succesor may not be defined at this point, hence the use of type option) + - (Sfinalcond cond args succ1 succ2 info) represents a condition (which must + always be the last instruction in expansion list *) + +type expl = + | Snop of P.t + | Sr of P.t + | Sexp of P.t * rhs * P.t list * node option + | Sfinalcond of condition * P.t list * node * node * bool option + +(** Record used during the "dynamic" value numbering *) + +type numb = { + mutable nnext : int; (** Next unusued value number *) + mutable seqs : seq list; (** equations *) + mutable nreg : (P.t, int) Hashtbl.t; (** mapping registers to values *) + mutable nval : (int, P.t list) Hashtbl.t; + (** reverse mapping values to registers containing it *) +} + +let print_list_pos l = + debug "["; + List.iter (fun i -> debug "%d;" (p2i i)) l; + debug "]\n" + +let empty_numbering () = + { nnext = 1; seqs = []; nreg = Hashtbl.create 100; nval = Hashtbl.create 100 } + +let rec get_nvalues vn = function + | [] -> [] + | r :: rs -> + let v = + match Hashtbl.find_opt !vn.nreg r with + | Some v -> + debug "getnval r=%d |-> v=%d\n" (p2i r) v; + v + | None -> + let n = !vn.nnext in + debug "getnval r=%d |-> v=%d\n" (p2i r) n; + !vn.nnext <- !vn.nnext + 1; + Hashtbl.replace !vn.nreg r n; + Hashtbl.replace !vn.nval n [ r ]; + n + in + let vs = get_nvalues vn rs in + v :: vs + +let get_nval_ornil vn v = + match Hashtbl.find_opt !vn.nval v with None -> [] | Some l -> l + +let forget_reg vn rd = + match Hashtbl.find_opt !vn.nreg rd with + | Some v -> + debug "forget_reg: r=%d |-> v=%d\n" (p2i rd) v; + let old_regs = get_nval_ornil vn v in + debug "forget_reg: old_regs are:\n"; + print_list_pos old_regs; + Hashtbl.replace !vn.nval v + (List.filter (fun n -> not (P.eq n rd)) old_regs) + | None -> debug "forget_reg: no mapping for r=%d\n" (p2i rd) + +let update_reg vn rd v = + debug "update_reg: update v=%d with r=%d\n" v (p2i rd); + forget_reg vn rd; + let old_regs = get_nval_ornil vn v in + Hashtbl.replace !vn.nval v (rd :: old_regs) + +let rec find_valnum_rhs rh = function + | [] -> None + | Seq (v, rh') :: tl -> if rh = rh' then Some v else find_valnum_rhs rh tl + +let set_unknown vn rd = + debug "set_unknown: rd=%d\n" (p2i rd); + forget_reg vn rd; + Hashtbl.remove !vn.nreg rd + +let set_res_unknown vn res = match res with BR r -> set_unknown vn r | _ -> () + +let addrhs vn rd rh = + match find_valnum_rhs rh !vn.seqs with + | Some vres -> + debug "addrhs: Some v=%d\n" vres; + Hashtbl.replace !vn.nreg rd vres; + update_reg vn rd vres + | None -> + let n = !vn.nnext in + debug "addrhs: None v=%d\n" n; + !vn.nnext <- !vn.nnext + 1; + !vn.seqs <- Seq (n, rh) :: !vn.seqs; + update_reg vn rd n; + Hashtbl.replace !vn.nreg rd n + +let addsop vn v op rd = + debug "addsop\n"; + if op = Omove then ( + update_reg vn rd (List.hd v); + Hashtbl.replace !vn.nreg rd (List.hd v)) + else addrhs vn rd (Sop (op, v)) + +let rec kill_mem_operations = function + | (Seq (v, Sop (op, vl)) as eq) :: tl -> + if op_depends_on_memory op then kill_mem_operations tl + else eq :: kill_mem_operations tl + | [] -> [] + | eq :: tl -> eq :: kill_mem_operations tl + +let reg_valnum vn v = + debug "reg_valnum: trying to find a mapping for v=%d\n" v; + match Hashtbl.find !vn.nval v with + | [] -> None + | r :: rs -> + debug "reg_valnum: found a mapping r=%d\n" (p2i r); + Some r + +let rec reg_valnums vn = function + | [] -> Some [] + | v :: vs -> ( + match (reg_valnum vn v, reg_valnums vn vs) with + | Some r, Some rs -> Some (r :: rs) + | _, _ -> None) + +let find_rhs vn rh = + match find_valnum_rhs rh !vn.seqs with + | None -> None + | Some vres -> reg_valnum vn vres + +(** Functions to perform the dynamic reduction during CSE *) + +let extract_arg l = + if List.length l > 0 then + match List.hd l with + | Sr r -> (r, List.tl l) + | Sexp (rd, _, _, _) -> (rd, l) + | _ -> failwith "extract_arg: final instruction arg can not be extracted" + else failwith "extract_arg: trying to extract on an empty list" + +let extract_final vn fl fdest succ = + if List.length fl > 0 then + match List.hd fl with + | Sr r -> + if not (P.eq r fdest) then ( + let v = get_nvalues vn [ r ] in + addsop vn v Omove fdest; + Sexp (fdest, Smove, [ r ], Some succ) :: List.tl fl) + else Snop succ :: List.tl fl + | Sexp (rd, rh, args, None) -> + assert (rd = fdest); + Sexp (fdest, rh, args, Some succ) :: List.tl fl + | _ -> fl + else failwith "extract_final: trying to extract on an empty list" + +let addinst vn op args rd = + let v = get_nvalues vn args in + let rh = Sop (op, v) in + match find_rhs vn rh with + | Some r -> + debug "addinst: rhs found with r=%d\n" (p2i r); + Sr r + | None -> + addsop vn v op rd; + Sexp (rd, rh, args, None) + +(** Expansion functions *) -let load_hilo32 a1 dest hi lo succ is_long k = - if Int.eq lo Int.zero then Iop (OEluiw (hi, is_long), [ a1 ], dest, succ) :: k +type immt = + | Addiw + | Addil + | Andiw + | Andil + | Oriw + | Oril + | Xoriw + | Xoril + | Sltiw + | Sltiuw + | Sltil + | Sltiul + +let load_hilo32 vn dest hi lo = + let op1 = OEluiw hi in + if Int.eq lo Int.zero then [ addinst vn op1 [] dest ] else let r = r2pi () in - Iop (OEluiw (hi, is_long), [ a1 ], r, n2pi ()) - :: Iop (Oaddimm lo, [ r ], dest, succ) :: k + let op2 = OEaddiw (None, lo) in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + let i2 = addinst vn op2 [ r' ] dest in + i2 :: l -let load_hilo64 a1 dest hi lo succ k = - if Int64.eq lo Int64.zero then Iop (OEluil hi, [ a1 ], dest, succ) :: k +let load_hilo64 vn dest hi lo = + let op1 = OEluil hi in + if Int64.eq lo Int64.zero then [ addinst vn op1 [] dest ] else let r = r2pi () in - Iop (OEluil hi, [ a1 ], r, n2pi ()) - :: Iop (Oaddlimm lo, [ r ], dest, succ) :: k + let op2 = OEaddil (None, lo) in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + let i2 = addinst vn op2 [ r' ] dest in + i2 :: l -let loadimm32 a1 dest n succ is_long k = +let loadimm32 vn dest n = match make_immed32 n with - | Imm32_single imm -> Iop (OEaddiwr0 (imm, is_long), [ a1 ], dest, succ) :: k - | Imm32_pair (hi, lo) -> load_hilo32 a1 dest hi lo succ is_long k + | Imm32_single imm -> + let op1 = OEaddiw (Some X0_R, imm) in + [ addinst vn op1 [] dest ] + | Imm32_pair (hi, lo) -> load_hilo32 vn dest hi lo -let loadimm64 a1 dest n succ k = +let loadimm64 vn dest n = match make_immed64 n with - | Imm64_single imm -> Iop (OEaddilr0 imm, [ a1 ], dest, succ) :: k - | Imm64_pair (hi, lo) -> load_hilo64 a1 dest hi lo succ k - | Imm64_large imm -> Iop (OEloadli imm, [], dest, succ) :: k + | Imm64_single imm -> + let op1 = OEaddil (Some X0_R, imm) in + [ addinst vn op1 [] dest ] + | Imm64_pair (hi, lo) -> load_hilo64 vn dest hi lo + | Imm64_large imm -> + let op1 = OEloadli imm in + [ addinst vn op1 [] dest ] -let get_opimm imm = function +let get_opimm optR imm = function + | Addiw -> OEaddiw (optR, imm) + | Andiw -> OEandiw imm + | Oriw -> OEoriw imm | Xoriw -> OExoriw imm | Sltiw -> OEsltiw imm | Sltiuw -> OEsltiuw imm + | Addil -> OEaddil (optR, imm) + | Andil -> OEandil imm + | Oril -> OEoril imm | Xoril -> OExoril imm | Sltil -> OEsltil imm | Sltiul -> OEsltiul imm -let opimm32 a1 dest n succ is_long k op opimm = +let opimm32 vn a1 dest n optR op opimm = match make_immed32 n with - | Imm32_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k + | Imm32_single imm -> [ addinst vn (get_opimm optR imm opimm) [ a1 ] dest ] | Imm32_pair (hi, lo) -> let r = r2pi () in - load_hilo32 a1 r hi lo (n2pi ()) is_long - (Iop (op, [ a1; r ], dest, succ) :: k) + let l = load_hilo32 vn r hi lo in + let r', l' = extract_arg l in + let i = addinst vn op [ a1; r' ] dest in + i :: l' -let opimm64 a1 dest n succ k op opimm = +let opimm64 vn a1 dest n optR op opimm = match make_immed64 n with - | Imm64_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k + | Imm64_single imm -> [ addinst vn (get_opimm optR imm opimm) [ a1 ] dest ] | Imm64_pair (hi, lo) -> let r = r2pi () in - load_hilo64 a1 r hi lo (n2pi ()) (Iop (op, [ a1; r ], dest, succ) :: k) + let l = load_hilo64 vn r hi lo in + let r', l' = extract_arg l in + let i = addinst vn op [ a1; r' ] dest in + i :: l' | Imm64_large imm -> let r = r2pi () in - Iop (OEloadli imm, [], r, n2pi ()) :: Iop (op, [ a1; r ], dest, succ) :: k + let op1 = OEloadli imm in + let i1 = addinst vn op1 [] r in + let r', l' = extract_arg [ i1 ] in + let i2 = addinst vn op [ a1; r' ] dest in + i2 :: l' + +let addimm32 vn a1 dest n optR = opimm32 vn a1 dest n optR Oadd Addiw + +let andimm32 vn a1 dest n = opimm32 vn a1 dest n None Oand Andiw + +let orimm32 vn a1 dest n = opimm32 vn a1 dest n None Oor Oriw + +let xorimm32 vn a1 dest n = opimm32 vn a1 dest n None Oxor Xoriw + +let sltimm32 vn a1 dest n = opimm32 vn a1 dest n None (OEsltw None) Sltiw + +let sltuimm32 vn a1 dest n = opimm32 vn a1 dest n None (OEsltuw None) Sltiuw -let xorimm32 a1 dest n succ is_long k = - opimm32 a1 dest n succ is_long k Oxor Xoriw +let addimm64 vn a1 dest n optR = opimm64 vn a1 dest n optR Oaddl Addil -let sltimm32 a1 dest n succ is_long k = - opimm32 a1 dest n succ is_long k (OEsltw None) Sltiw +let andimm64 vn a1 dest n = opimm64 vn a1 dest n None Oandl Andil -let sltuimm32 a1 dest n succ is_long k = - opimm32 a1 dest n succ is_long k (OEsltuw None) Sltiuw +let orimm64 vn a1 dest n = opimm64 vn a1 dest n None Oorl Oril -let xorimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oxorl Xoril +let xorimm64 vn a1 dest n = opimm64 vn a1 dest n None Oxorl Xoril -let sltimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltl None) Sltil +let sltimm64 vn a1 dest n = opimm64 vn a1 dest n None (OEsltl None) Sltil -let sltuimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltul None) Sltiul +let sltuimm64 vn a1 dest n = opimm64 vn a1 dest n None (OEsltul None) Sltiul let is_inv_cmp = function Cle | Cgt -> true | _ -> false -let make_optR0 is_x0 is_inv = if is_x0 then Some is_inv else None +let make_optR is_x0 is_inv = + if is_x0 then if is_inv then Some X0_L else Some X0_R else None let cbranch_int32s is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbeqw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbnew optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgew optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltw optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgew optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Sfinalcond (CEbeqw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbnew optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgew optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgew optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int32u is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbequw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbneuw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltuw optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgeuw optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltuw optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgeuw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Sfinalcond (CEbequw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbneuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgeuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgeuw optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int64s is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbeql optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbnel optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltl optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgel optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltl optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgel optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Ceq -> Sfinalcond (CEbeql optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbnel optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgel optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltl optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgel optR, [ a1; a2 ], succ1, succ2, info) :: k let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Icond (CEbequl optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cne -> Icond (CEbneul optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Clt -> Icond (CEbltul optR0, [ a1; a2 ], succ1, succ2, info) :: k - | Cle -> Icond (CEbgeul optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cgt -> Icond (CEbltul optR0, [ a2; a1 ], succ1, succ2, info) :: k - | Cge -> Icond (CEbgeul optR0, [ a1; a2 ], succ1, succ2, info) :: k - -let cond_int32s is_x0 cmp a1 a2 dest succ k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + | Ceq -> Sfinalcond (CEbequl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbneul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgeul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgeul optR, [ a1; a2 ], succ1, succ2, info) :: k + +let cond_int32s vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEseqw optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsnew optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltw optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ addinst vn (OEseqw optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsnew optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltw optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in - Iop (OEsltw optR0, [ a2; a1 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltw optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltw optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltw optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in - Iop (OEsltw optR0, [ a1; a2 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltw optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let cond_int32u is_x0 cmp a1 a2 dest succ k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in +let cond_int32u vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEsequw optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsneuw optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltuw optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ addinst vn (OEsequw optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsneuw optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltuw optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in - Iop (OEsltuw optR0, [ a2; a1 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltuw optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltuw optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltuw optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in - Iop (OEsltuw optR0, [ a1; a2 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltuw optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let cond_int64s is_x0 cmp a1 a2 dest succ k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in +let cond_int64s vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEseql optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsnel optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltl optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ addinst vn (OEseql optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsnel optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltl optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in - Iop (OEsltl optR0, [ a2; a1 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltl optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltl optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltl optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in - Iop (OEsltl optR0, [ a1; a2 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltl optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let cond_int64u is_x0 cmp a1 a2 dest succ k = - let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in +let cond_int64u vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in match cmp with - | Ceq -> Iop (OEsequl optR0, [ a1; a2 ], dest, succ) :: k - | Cne -> Iop (OEsneul optR0, [ a1; a2 ], dest, succ) :: k - | Clt -> Iop (OEsltul optR0, [ a1; a2 ], dest, succ) :: k + | Ceq -> [ addinst vn (OEsequl optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsneul optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltul optR) [ a1; a2 ] dest ] | Cle -> let r = r2pi () in - Iop (OEsltul optR0, [ a2; a1 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k - | Cgt -> Iop (OEsltul optR0, [ a2; a1 ], dest, succ) :: k + let op = OEsltul optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltul optR) [ a2; a1 ] dest ] | Cge -> let r = r2pi () in - Iop (OEsltul optR0, [ a1; a2 ], r, n2pi ()) - :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + let op = OEsltul optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l let is_normal_cmp = function Cne -> false | _ -> true -let cond_float cmp f1 f2 dest succ = +let cond_float vn cmp f1 f2 dest = match cmp with - | Ceq -> Iop (OEfeqd, [ f1; f2 ], dest, succ) - | Cne -> Iop (OEfeqd, [ f1; f2 ], dest, succ) - | Clt -> Iop (OEfltd, [ f1; f2 ], dest, succ) - | Cle -> Iop (OEfled, [ f1; f2 ], dest, succ) - | Cgt -> Iop (OEfltd, [ f2; f1 ], dest, succ) - | Cge -> Iop (OEfled, [ f2; f1 ], dest, succ) - -let cond_single cmp f1 f2 dest succ = + | Ceq -> [ addinst vn OEfeqd [ f1; f2 ] dest ] + | Cne -> [ addinst vn OEfeqd [ f1; f2 ] dest ] + | Clt -> [ addinst vn OEfltd [ f1; f2 ] dest ] + | Cle -> [ addinst vn OEfled [ f1; f2 ] dest ] + | Cgt -> [ addinst vn OEfltd [ f2; f1 ] dest ] + | Cge -> [ addinst vn OEfled [ f2; f1 ] dest ] + +let cond_single vn cmp f1 f2 dest = match cmp with - | Ceq -> Iop (OEfeqs, [ f1; f2 ], dest, succ) - | Cne -> Iop (OEfeqs, [ f1; f2 ], dest, succ) - | Clt -> Iop (OEflts, [ f1; f2 ], dest, succ) - | Cle -> Iop (OEfles, [ f1; f2 ], dest, succ) - | Cgt -> Iop (OEflts, [ f2; f1 ], dest, succ) - | Cge -> Iop (OEfles, [ f2; f1 ], dest, succ) - -let expanse_cbranchimm_int32s cmp a1 n info succ1 succ2 k = - if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 k + | Ceq -> [ addinst vn OEfeqs [ f1; f2 ] dest ] + | Cne -> [ addinst vn OEfeqs [ f1; f2 ] dest ] + | Clt -> [ addinst vn OEflts [ f1; f2 ] dest ] + | Cle -> [ addinst vn OEfles [ f1; f2 ] dest ] + | Cgt -> [ addinst vn OEflts [ f2; f1 ] dest ] + | Cge -> [ addinst vn OEfles [ f2; f1 ] dest ] + +let expanse_cbranchimm_int32s vn cmp a1 n info succ1 succ2 = + if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cbranch_int32s false cmp a1 r info succ1 succ2 k) + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cbranch_int32s false cmp a1 r' info succ1 succ2 l' -let expanse_cbranchimm_int32u cmp a1 n info succ1 succ2 k = - if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 k +let expanse_cbranchimm_int32u vn cmp a1 n info succ1 succ2 = + if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cbranch_int32u false cmp a1 r info succ1 succ2 k) + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cbranch_int32u false cmp a1 r' info succ1 succ2 l' -let expanse_cbranchimm_int64s cmp a1 n info succ1 succ2 k = - if Int64.eq n Int64.zero then cbranch_int64s true cmp a1 a1 info succ1 succ2 k +let expanse_cbranchimm_int64s vn cmp a1 n info succ1 succ2 = + if Int64.eq n Int64.zero then + cbranch_int64s true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - loadimm64 a1 r n (n2pi ()) - (cbranch_int64s false cmp a1 r info succ1 succ2 k) + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cbranch_int64s false cmp a1 r' info succ1 succ2 l' -let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k = - if Int64.eq n Int64.zero then cbranch_int64u true cmp a1 a1 info succ1 succ2 k +let expanse_cbranchimm_int64u vn cmp a1 n info succ1 succ2 = + if Int64.eq n Int64.zero then + cbranch_int64u true cmp a1 a1 info succ1 succ2 [] else let r = r2pi () in - loadimm64 a1 r n (n2pi ()) - (cbranch_int64u false cmp a1 r info succ1 succ2 k) + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cbranch_int64u false cmp a1 r' info succ1 succ2 l' -let expanse_condimm_int32s cmp a1 n dest succ k = - if Int.eq n Int.zero then cond_int32s true cmp a1 a1 dest succ k +let expanse_condimm_int32s vn cmp a1 n dest = + if Int.eq n Int.zero then cond_int32s vn true cmp a1 a1 dest else match cmp with | Ceq | Cne -> let r = r2pi () in - xorimm32 a1 r n (n2pi ()) false (cond_int32s true cmp r r dest succ k) - | Clt -> sltimm32 a1 dest n succ false k + let l = xorimm32 vn a1 r n in + let r', l' = extract_arg l in + cond_int32s vn true cmp r' r' dest @ l' + | Clt -> sltimm32 vn a1 dest n | Cle -> if Int.eq n (Int.repr Int.max_signed) then - loadimm32 a1 dest Int.one succ false k - else sltimm32 a1 dest (Int.add n Int.one) succ false k + let l = loadimm32 vn dest Int.one in + let r, l' = extract_arg l in + addinst vn (OEmayundef MUint) [ a1; r ] dest :: l' + else sltimm32 vn a1 dest (Int.add n Int.one) | _ -> let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cond_int32s false cmp a1 r dest succ k) + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cond_int32s vn false cmp a1 r' dest @ l' -let expanse_condimm_int32u cmp a1 n dest succ k = - if Int.eq n Int.zero then cond_int32u true cmp a1 a1 dest succ k +let expanse_condimm_int32u vn cmp a1 n dest = + if Int.eq n Int.zero then cond_int32u vn true cmp a1 a1 dest else match cmp with - | Clt -> sltuimm32 a1 dest n succ false k + | Clt -> sltuimm32 vn a1 dest n | _ -> let r = r2pi () in - loadimm32 a1 r n (n2pi ()) false - (cond_int32u false cmp a1 r dest succ k) + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cond_int32u vn false cmp a1 r' dest @ l' -let expanse_condimm_int64s cmp a1 n dest succ k = - if Int64.eq n Int64.zero then cond_int64s true cmp a1 a1 dest succ k +let expanse_condimm_int64s vn cmp a1 n dest = + if Int64.eq n Int64.zero then cond_int64s vn true cmp a1 a1 dest else match cmp with | Ceq | Cne -> let r = r2pi () in - xorimm64 a1 r n (n2pi ()) (cond_int64s true cmp r r dest succ k) - | Clt -> sltimm64 a1 dest n succ k + let l = xorimm64 vn a1 r n in + let r', l' = extract_arg l in + cond_int64s vn true cmp r' r' dest @ l' + | Clt -> sltimm64 vn a1 dest n | Cle -> if Int64.eq n (Int64.repr Int64.max_signed) then - loadimm32 a1 dest Int.one succ true k - else sltimm64 a1 dest (Int64.add n Int64.one) succ k + let l = loadimm32 vn dest Int.one in + let r, l' = extract_arg l in + addinst vn (OEmayundef MUlong) [ a1; r ] dest :: l' + else sltimm64 vn a1 dest (Int64.add n Int64.one) | _ -> let r = r2pi () in - loadimm64 a1 r n (n2pi ()) (cond_int64s false cmp a1 r dest succ k) + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cond_int64s vn false cmp a1 r' dest @ l' -let expanse_condimm_int64u cmp a1 n dest succ k = - if Int64.eq n Int64.zero then cond_int64u true cmp a1 a1 dest succ k +let expanse_condimm_int64u vn cmp a1 n dest = + if Int64.eq n Int64.zero then cond_int64u vn true cmp a1 a1 dest else match cmp with - | Clt -> sltuimm64 a1 dest n succ k + | Clt -> sltuimm64 vn a1 dest n | _ -> let r = r2pi () in - loadimm64 a1 r n (n2pi ()) (cond_int64u false cmp a1 r dest succ k) + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cond_int64u vn false cmp a1 r' dest @ l' -let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ k = +let expanse_cond_fp vn cnot fn_cond cmp f1 f2 dest = let normal = is_normal_cmp cmp in let normal' = if cnot then not normal else normal in - let succ' = if normal' then succ else n2pi () in - let insn = fn_cond cmp f1 f2 dest succ' in - insn - :: (if normal' then k else Iop (OExoriw Int.one, [ dest ], dest, succ) :: k) + let insn = fn_cond vn cmp f1 f2 dest in + if normal' then insn + else + let r', l = extract_arg insn in + addinst vn (OExoriw Int.one) [ r' ] dest :: l -let expanse_cbranch_fp cnot fn_cond cmp f1 f2 info succ1 succ2 k = +let expanse_cbranch_fp vn cnot fn_cond cmp f1 f2 info succ1 succ2 = let r = r2pi () in let normal = is_normal_cmp cmp in let normal' = if cnot then not normal else normal in - let insn = fn_cond cmp f1 f2 r (n2pi ()) in - insn - :: - (if normal' then Icond (CEbnew (Some false), [ r; r ], succ1, succ2, info) - else Icond (CEbeqw (Some false), [ r; r ], succ1, succ2, info)) - :: k + let insn = fn_cond vn cmp f1 f2 r in + let r', l = extract_arg insn in + if normal' then + Sfinalcond (CEbnew (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l + else Sfinalcond (CEbeqw (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l + +(** Form a list containing both sources and destination regs of an instruction *) let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] @@ -348,11 +621,10 @@ let get_regs_inst = function | Ireturn (Some r) -> [ r ] | _ -> [] -let write_initial_node initial code' new_order = - code' := PTree.set initial (Inop (n2p ())) !code'; - new_order := initial :: !new_order +(** Modify pathmap according to the size of the expansion list *) let write_pathmap initial esize pm' = + debug "write_pathmap: initial=%d, esize=%d\n" (p2i initial) esize; let path = get_some @@ PTree.get initial !pm' in let npsize = Camlcoq.Nat.of_int (esize + Camlcoq.Nat.to_int path.psize) in let path' = @@ -365,21 +637,51 @@ let write_pathmap initial esize pm' = in pm' := PTree.set initial path' !pm' -let rec write_tree exp current code' new_order = +(** Write a single instruction in the tree and update order *) + +let write_inst target_node inst code' new_order = + code' := PTree.set (P.of_int target_node) inst !code'; + new_order := P.of_int target_node :: !new_order + +(** Return olds args if the CSE numbering is empty *) + +let get_arguments vn vals args = + match reg_valnums vn vals with Some args' -> args' | None -> args + +(** Update the code tree with the expansion list *) + +let rec write_tree vn exp initial current code' new_order fturn = + debug "wt: node is %d\n" !node; + let target_node, next_node = + if fturn then (P.to_int initial, current) else (current, current - 1) + in match exp with - | (Iop (_, _, _, succ) as inst) :: k -> - code' := PTree.set (Camlcoq.P.of_int current) inst !code'; - new_order := Camlcoq.P.of_int current :: !new_order; - write_tree k (current - 1) code' new_order - | (Icond (_, _, succ1, succ2, _) as inst) :: k -> - code' := PTree.set (Camlcoq.P.of_int current) inst !code'; - new_order := Camlcoq.P.of_int current :: !new_order; - write_tree k (current - 1) code' new_order + | Sr r :: _ -> + failwith "write_tree: there are still some symbolic values in the list" + | Sexp (rd, Sop (op, vals), args, None) :: k -> + let args = get_arguments vn vals args in + let inst = Iop (op, args, rd, P.of_int next_node) in + write_inst target_node inst code' new_order; + write_tree vn k initial next_node code' new_order false + | [ Snop succ ] -> + let inst = Inop succ in + write_inst target_node inst code' new_order + | [ Sexp (rd, Sop (op, vals), args, Some succ) ] -> + let args = get_arguments vn vals args in + let inst = Iop (op, args, rd, succ) in + write_inst target_node inst code' new_order + | [ Sexp (rd, Smove, args, Some succ) ] -> + let inst = Iop (Omove, args, rd, succ) in + write_inst target_node inst code' new_order + | [ Sfinalcond (cond, args, succ1, succ2, info) ] -> + let inst = Icond (cond, args, succ1, succ2, info) in + write_inst target_node inst code' new_order | [] -> () - | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." + | _ -> failwith "write_tree: invalid list" +(** Main expansion function - TODO gourdinl to split? *) let expanse (sb : superblock) code pm = - (*debug_flag := true;*) + debug "#### New superblock for expansion oracle\n"; let new_order = ref [] in let liveins = ref sb.liveins in let exp = ref [] in @@ -387,150 +689,377 @@ let expanse (sb : superblock) code pm = let was_exp = ref false in let code' = ref code in let pm' = ref pm in + let vn = ref (empty_numbering ()) in Array.iter (fun n -> was_branch := false; was_exp := false; let inst = get_some @@ PTree.get n code in - (match inst with - | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomp\n"; - exp := cond_int32s false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompu\n"; - exp := cond_int32u false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompimm\n"; - exp := expanse_condimm_int32s c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompuimm\n"; - exp := expanse_condimm_int32u c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccompl\n"; - exp := cond_int64s false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> - debug "Iop/Ccomplu\n"; - exp := cond_int64u false c a1 a2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccomplimm\n"; - exp := expanse_condimm_int64s c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> - debug "Iop/Ccompluimm\n"; - exp := expanse_condimm_int64u c a1 imm dest succ []; - was_exp := true - | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompf\n"; - exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompf\n"; - exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Ccompfs\n"; - exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; - was_exp := true - | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> - debug "Iop/Cnotcompfs\n"; - exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; - was_exp := true - | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomp\n"; - exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompu\n"; - exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompimm\n"; - exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompuimm\n"; - exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompl\n"; - exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplu\n"; - exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccomplimm\n"; - exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompluimm\n"; - exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompf\n"; - exp := expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompf\n"; - exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Ccompfs\n"; - exp := - expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> - debug "Icond/Cnotcompfs\n"; - exp := expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; - was_branch := true; - was_exp := true - | _ -> new_order := n :: !new_order); + (if !Clflags.option_fexpanse_rtlcond then + match inst with + (* Expansion of conditions - Ocmp *) + | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomp\n"; + exp := cond_int32s vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompu\n"; + exp := cond_int32u vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompimm\n"; + exp := expanse_condimm_int32s vn c a1 imm dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompuimm\n"; + exp := expanse_condimm_int32u vn c a1 imm dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompl\n"; + exp := cond_int64s vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomplu\n"; + exp := cond_int64u vn false c a1 a2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccomplimm\n"; + exp := expanse_condimm_int64s vn c a1 imm dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompluimm\n"; + exp := expanse_condimm_int64u vn c a1 imm dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompf\n"; + exp := expanse_cond_fp vn false cond_float c f1 f2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompf\n"; + exp := expanse_cond_fp vn true cond_float c f1 f2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompfs\n"; + exp := expanse_cond_fp vn false cond_single c f1 f2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompfs\n"; + exp := expanse_cond_fp vn true cond_single c f1 f2 dest; + exp := extract_final vn !exp dest succ; + was_exp := true + (* Expansion of branches - Ccomp *) + | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomp\n"; + exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompu\n"; + exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompimm\n"; + exp := expanse_cbranchimm_int32s vn c a1 imm info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompuimm\n"; + exp := expanse_cbranchimm_int32u vn c a1 imm info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompl\n"; + exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplu\n"; + exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplimm\n"; + exp := expanse_cbranchimm_int64s vn c a1 imm info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompluimm\n"; + exp := expanse_cbranchimm_int64u vn c a1 imm info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompf\n"; + exp := + expanse_cbranch_fp vn false cond_float c f1 f2 info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompf\n"; + exp := expanse_cbranch_fp vn true cond_float c f1 f2 info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompfs\n"; + exp := + expanse_cbranch_fp vn false cond_single c f1 f2 info succ1 succ2; + was_branch := true; + was_exp := true + | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompfs\n"; + exp := + expanse_cbranch_fp vn true cond_single c f1 f2 info succ1 succ2; + was_branch := true; + was_exp := true + | _ -> ()); + (if !Clflags.option_fexpanse_others && not !was_exp then + match inst with + | Iop (Ofloatconst f, nil, dest, succ) -> ( + match make_immed64 (Floats.Float.to_bits f) with + | Imm64_single _ | Imm64_large _ -> () + | Imm64_pair (hi, lo) -> + debug "Iop/Ofloatconst\n"; + let r = r2pi () in + let l = load_hilo64 vn r hi lo in + let r', l' = extract_arg l in + exp := addinst vn Ofloat_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; + was_exp := true) + | Iop (Osingleconst f, nil, dest, succ) -> ( + match make_immed32 (Floats.Float32.to_bits f) with + | Imm32_single imm -> () + | Imm32_pair (hi, lo) -> + debug "Iop/Osingleconst\n"; + let r = r2pi () in + let l = load_hilo32 vn r hi lo in + let r', l' = extract_arg l in + exp := addinst vn Osingle_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; + was_exp := true) + | Iop (Ointconst n, nil, dest, succ) -> + debug "Iop/Ointconst\n"; + exp := loadimm32 vn dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Olongconst n, nil, dest, succ) -> + debug "Iop/Olongconst\n"; + exp := loadimm64 vn dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oaddimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oaddimm\n"; + exp := addimm32 vn a1 dest n None; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oaddlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oaddlimm\n"; + exp := addimm64 vn a1 dest n None; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oandimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oandimm\n"; + exp := andimm32 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oandlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oandlimm\n"; + exp := andimm64 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oorimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oorimm\n"; + exp := orimm32 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oorlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oorlimm\n"; + exp := orimm64 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oxorimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oxorimm\n"; + exp := xorimm32 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oxorlimm n, a1 :: nil, dest, succ) -> + debug "Iop/Oxorlimm\n"; + exp := xorimm64 vn a1 dest n; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocast8signed, a1 :: nil, dest, succ) -> + debug "Iop/cast8signed\n"; + let op = Oshlimm (Int.repr (Z.of_sint 24)) in + let r = r2pi () in + let i1 = addinst vn op [ a1 ] r in + let r', l = extract_arg [ i1 ] in + exp := + addinst vn (Oshrimm (Int.repr (Z.of_sint 24))) [ r' ] dest :: l; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocast16signed, a1 :: nil, dest, succ) -> + debug "Iop/cast16signed\n"; + let op = Oshlimm (Int.repr (Z.of_sint 16)) in + let r = r2pi () in + let i1 = addinst vn op [ a1 ] r in + let r', l = extract_arg [ i1 ] in + exp := + addinst vn (Oshrimm (Int.repr (Z.of_sint 16))) [ r' ] dest :: l; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> + debug "Iop/Ocast32unsigned\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Ocast32signed in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oshllimm (Int.repr (Z.of_sint 32)) in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oshrluimm (Int.repr (Z.of_sint 32)) in + exp := addinst vn op3 [ r2' ] dest :: l2; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oshrximm n, a1 :: nil, dest, succ) -> + if Int.eq n Int.zero then ( + debug "Iop/Oshrximm1\n"; + exp := [ addinst vn (OEmayundef (MUshrx n)) [ a1; a1 ] dest ]) + else if Int.eq n Int.one then ( + debug "Iop/Oshrximm2\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oadd in + let i2 = addinst vn op2 [ a1; r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oshrimm Int.one in + let i3 = addinst vn op3 [ r2' ] dest in + let r3, l3 = extract_arg (i3 :: l2) in + exp := addinst vn (OEmayundef (MUshrx n)) [ r3; r3 ] dest :: l3) + else ( + debug "Iop/Oshrximm3\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrimm (Int.repr (Z.of_sint 31)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oshruimm (Int.sub Int.iwordsize n) in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oadd in + let i3 = addinst vn op3 [ a1; r2' ] r3 in + let r3', l3 = extract_arg (i3 :: l2) in + + let op4 = Oshrimm n in + let i4 = addinst vn op4 [ r3' ] dest in + let r4, l4 = extract_arg (i4 :: l3) in + exp := addinst vn (OEmayundef (MUshrx n)) [ r4; r4 ] dest :: l4); + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> + if Int.eq n Int.zero then ( + debug "Iop/Oshrxlimm1\n"; + exp := [ addinst vn (OEmayundef (MUshrxl n)) [ a1; a1 ] dest ]) + else if Int.eq n Int.one then ( + debug "Iop/Oshrxlimm2\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oaddl in + let i2 = addinst vn op2 [ a1; r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oshrlimm Int.one in + let i3 = addinst vn op3 [ r2' ] dest in + let r3, l3 = extract_arg (i3 :: l2) in + exp := addinst vn (OEmayundef (MUshrxl n)) [ r3; r3 ] dest :: l3) + else ( + debug "Iop/Oshrxlimm3\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrlimm (Int.repr (Z.of_sint 63)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oshrluimm (Int.sub Int64.iwordsize' n) in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oaddl in + let i3 = addinst vn op3 [ a1; r2' ] r3 in + let r3', l3 = extract_arg (i3 :: l2) in + + let op4 = Oshrlimm n in + let i4 = addinst vn op4 [ r3' ] dest in + let r4, l4 = extract_arg (i4 :: l3) in + exp := addinst vn (OEmayundef (MUshrxl n)) [ r4; r4 ] dest :: l4); + exp := extract_final vn !exp dest succ; + was_exp := true + | _ -> ()); + (* Update the CSE numbering *) + (if not !was_exp then + match inst with + | Iop (op, args, dest, succ) -> + let v = get_nvalues vn args in + addsop vn v op dest + | Iload (_, _, _, _, dst, _) -> set_unknown vn dst + | Istore (chk, addr, args, src, s) -> + !vn.seqs <- kill_mem_operations !vn.seqs + | Icall (_, _, _, _, _) | Itailcall (_, _, _) | Ibuiltin (_, _, _, _) -> + vn := empty_numbering () + | _ -> ()); + (* Update code, liveins, pathmap, and order of the superblock for one expansion *) if !was_exp then ( - node := !node + 1; - (if !was_branch then + (if !was_branch && List.length !exp > 1 then let lives = PTree.get n !liveins in match lives with | Some lives -> - let new_branch_pc = - Camlcoq.P.of_int (!node - (List.length !exp - 1)) - in + let new_branch_pc = P.of_int (!node + 1) in liveins := PTree.set new_branch_pc lives !liveins; liveins := PTree.remove n !liveins | _ -> ()); - write_pathmap sb.instructions.(0) (List.length !exp) pm'; - write_initial_node n code' new_order; - write_tree !exp !node code' new_order)) + node := !node + List.length !exp - 1; + write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; + write_tree vn (List.rev !exp) n !node code' new_order true) + else new_order := n :: !new_order) sb.instructions; sb.instructions <- Array.of_list (List.rev !new_order); sb.liveins <- !liveins; - (*debug_flag := false;*) (!code', !pm') +(** Compute the last used node and reg indexs *) + let rec find_last_node_reg = function | [] -> () | (pc, i) :: k -> let rec traverse_list var = function | [] -> () | e :: t -> - let e' = Camlcoq.P.to_int e in + let e' = p2i e in if e' > !var then var := e'; traverse_list var t in diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index fe000976..6041a34d 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -96,8 +96,10 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiw _ => op1 (default nv) | OEsltiuw _ => op1 (default nv) | OExoriw _ => op1 (bitwise nv) - | OEluiw _ _ => op1 (default nv) - | OEaddiwr0 _ _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEluiw _ => op1 (default nv) + | OEaddiw _ _ => op1 (default nv) + | OEandiw n => op1 (andimm nv n) + | OEoriw n => op1 (orimm nv n) | OEseql _ => op2 (default nv) | OEsnel _ => op2 (default nv) | OEsequl _ => op2 (default nv) @@ -108,8 +110,11 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | OEsltiul _ => op1 (default nv) | OExoril _ => op1 (default nv) | OEluil _ => op1 (default nv) - | OEaddilr0 _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEaddil _ _ => op1 (default nv) + | OEandil _ => op1 (default nv) + | OEoril _ => op1 (default nv) | OEloadli _ => op1 (default nv) + | OEmayundef _ => op2 (default nv) | OEfeqd => op2 (default nv) | OEfltd => op2 (default nv) | OEfled => op2 (default nv) @@ -188,6 +193,16 @@ Proof. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. +- fold (Val.and (Vint n) v0); + fold (Val.and (Vint n) v2); + rewrite (Val.and_commut (Vint n) v0); + rewrite (Val.and_commut (Vint n) v2); + apply andimm_sound; auto. +- fold (Val.or (Vint n) v0); + fold (Val.or (Vint n) v2); + rewrite (Val.or_commut (Vint n) v0); + rewrite (Val.or_commut (Vint n) v2); + apply orimm_sound; auto. - apply xor_sound; auto with na. - (* selectl *) unfold ExtValues.select01_long. @@ -38,6 +38,12 @@ Set Implicit Arguments. (** Conditions (boolean-valued operators). *) +(** Type to modelize the use of a special register in arith operations *) + +Inductive oreg: Type := + | X0_L: oreg + | X0_R: oreg. + Inductive condition : Type := | Ccomp (c: comparison) (**r signed integer comparison *) | Ccompu (c: comparison) (**r unsigned integer comparison *) @@ -52,22 +58,30 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *) (* Expansed branches *) - | CEbeqw (optR0: option bool) (**r branch-if-equal signed *) - | CEbnew (optR0: option bool) (**r branch-if-not-equal signed *) - | CEbequw (optR0: option bool) (**r branch-if-equal unsigned *) - | CEbneuw (optR0: option bool) (**r branch-if-not-equal unsigned *) - | CEbltw (optR0: option bool) (**r branch-if-less signed *) - | CEbltuw (optR0: option bool) (**r branch-if-less unsigned *) - | CEbgew (optR0: option bool) (**r branch-if-greater-or-equal signed *) - | CEbgeuw (optR0: option bool) (**r branch-if-greater-or-equal unsigned *) - | CEbeql (optR0: option bool) (**r branch-if-equal signed *) - | CEbnel (optR0: option bool) (**r branch-if-not-equal signed *) - | CEbequl (optR0: option bool) (**r branch-if-equal unsigned *) - | CEbneul (optR0: option bool) (**r branch-if-not-equal unsigned *) - | CEbltl (optR0: option bool) (**r branch-if-less signed *) - | CEbltul (optR0: option bool) (**r branch-if-less unsigned *) - | CEbgel (optR0: option bool) (**r branch-if-greater-or-equal signed *) - | CEbgeul (optR0: option bool). (**r branch-if-greater-or-equal unsigned *) + | CEbeqw (optR: option oreg) (**r branch-if-equal signed *) + | CEbnew (optR: option oreg) (**r branch-if-not-equal signed *) + | CEbequw (optR: option oreg) (**r branch-if-equal unsigned *) + | CEbneuw (optR: option oreg) (**r branch-if-not-equal unsigned *) + | CEbltw (optR: option oreg) (**r branch-if-less signed *) + | CEbltuw (optR: option oreg) (**r branch-if-less unsigned *) + | CEbgew (optR: option oreg) (**r branch-if-greater-or-equal signed *) + | CEbgeuw (optR: option oreg) (**r branch-if-greater-or-equal unsigned *) + | CEbeql (optR: option oreg) (**r branch-if-equal signed *) + | CEbnel (optR: option oreg) (**r branch-if-not-equal signed *) + | CEbequl (optR: option oreg) (**r branch-if-equal unsigned *) + | CEbneul (optR: option oreg) (**r branch-if-not-equal unsigned *) + | CEbltl (optR: option oreg) (**r branch-if-less signed *) + | CEbltul (optR: option oreg) (**r branch-if-less unsigned *) + | CEbgel (optR: option oreg) (**r branch-if-greater-or-equal signed *) + | CEbgeul (optR: option oreg). (**r branch-if-greater-or-equal unsigned *) + +(* This type will define the eval function of a OEmayundef operation. *) + +Inductive mayundef: Type := + | MUint: mayundef + | MUlong: mayundef + | MUshrx: int -> mayundef + | MUshrxl: int -> mayundef. (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -172,35 +186,40 @@ Inductive operation : Type := (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) (* Expansed conditions *) - | OEseqw (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) - | OEsnew (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) - | OEsequw (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) - | OEsneuw (optR0: option bool) (**r [rd <- rs1 != rs2] unsigned *) - | OEsltw (optR0: option bool) (**r set-less-than *) - | OEsltuw (optR0: option bool) (**r set-less-than unsigned *) - | OEsltiw (n: int) (**r set-less-than immediate *) - | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) - | OExoriw (n: int) (**r xor immediate *) - | OEluiw (n: int) (is_long: bool) (**r load upper-immediate *) - | OEaddiwr0 (n: int) (is_long: bool) (**r add immediate *) - | OEseql (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) - | OEsnel (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) - | OEsequl (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) - | OEsneul (optR0: option bool) (**r [rd <- rs1 != rs2] unsigned *) - | OEsltl (optR0: option bool) (**r set-less-than *) - | OEsltul (optR0: option bool) (**r set-less-than unsigned *) - | OEsltil (n: int64) (**r set-less-than immediate *) - | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) - | OExoril (n: int64) (**r xor immediate *) - | OEluil (n: int64) (**r load upper-immediate *) - | OEaddilr0 (n: int64) (**r add immediate *) - | OEloadli (n: int64) (**r load an immediate int64 *) - | OEfeqd (**r compare equal *) - | OEfltd (**r compare less-than *) - | OEfled (**r compare less-than/equal *) - | OEfeqs (**r compare equal *) - | OEflts (**r compare less-than *) - | OEfles (**r compare less-than/equal *) + | OEseqw (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) + | OEsnew (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) + | OEsequw (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneuw (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltw (optR: option oreg) (**r set-less-than *) + | OEsltuw (optR: option oreg) (**r set-less-than unsigned *) + | OEsltiw (n: int) (**r set-less-than immediate *) + | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) + | OEaddiw (optR: option oreg) (n: int) (**r add immediate *) + | OEandiw (n: int) (**r and immediate *) + | OEoriw (n: int) (**r or immediate *) + | OExoriw (n: int) (**r xor immediate *) + | OEluiw (n: int) (**r load upper-immediate *) + | OEseql (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) + | OEsnel (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) + | OEsequl (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneul (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltl (optR: option oreg) (**r set-less-than *) + | OEsltul (optR: option oreg) (**r set-less-than unsigned *) + | OEsltil (n: int64) (**r set-less-than immediate *) + | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) + | OEaddil (optR: option oreg) (n: int64) (**r add immediate *) + | OEandil (n: int64) (**r and immediate *) + | OEoril (n: int64) (**r or immediate *) + | OExoril (n: int64) (**r xor immediate *) + | OEluil (n: int64) (**r load upper-immediate *) + | OEloadli (n: int64) (**r load an immediate int64 *) + | OEmayundef (mu: mayundef) + | OEfeqd (**r compare equal *) + | OEfltd (**r compare less-than *) + | OEfled (**r compare less-than/equal *) + | OEfeqs (**r compare equal *) + | OEflts (**r compare less-than *) + | OEfles (**r compare less-than/equal *) | Obits_of_single | Obits_of_float | Osingle_of_bits @@ -217,12 +236,15 @@ Inductive addressing: Type := (** Comparison functions (used in modules [CSE] and [Allocation]). *) +Definition oreg_eq: forall (x y: oreg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + Definition eq_condition (x y: condition) : {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec bool_dec; intros. + generalize Int.eq_dec Int64.eq_dec bool_dec oreg_eq; intros. assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. decide equality. - all: destruct optR0, optR1; decide equality. + all: destruct optR, optR0; decide equality. Defined. Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. @@ -233,9 +255,9 @@ Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec Val.eq oreg_eq; intros. decide equality. - all: destruct optR0, optR1; decide equality. + all: try destruct optR, optR0; try decide equality. Defined. (* Alternate definition: @@ -252,41 +274,51 @@ Defined. Global Opaque eq_condition eq_addressing eq_operation. -(** * Evaluation functions *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation can trigger an - error, e.g. integer division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) +(** Generic function to evaluate an instruction according to the given specific register *) Definition zero32 := (Vint Int.zero). Definition zero64 := (Vlong Int64.zero). -Definition apply_bin_r0 {B} (optR0: option bool) (sem: val -> val -> B) (v1 v2 vz: val): B := - match optR0 with +Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz: val): B := + match optR with | None => sem v1 v2 - | Some true => sem vz v1 - | Some false => sem v1 vz + | Some X0_L => sem vz v1 + | Some X0_R => sem v1 vz end. -Definition may_undef_int (is_long: bool) (sem: val -> val -> val) (v1 vimm vz: val): val := - if negb is_long then - match v1 with - | Vint _ => sem vimm vz - | _ => Vundef - end - else - match v1 with - | Vlong _ => sem vimm vz - | _ => Vundef - end. - -Definition may_undef_luil (v1: val) (n: int64): val := - match v1 with - | Vlong _ => Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12))) - | _ => Vundef +(** Mayundef evaluation according to the above defined type *) + +Definition eval_may_undef (mu: mayundef) (v1 v2: val): val := + match mu with + | MUint => match v1, v2 with + | Vint _, Vint _ => v2 + | _, _ => Vundef + end + | MUlong => match v1, v2 with + | Vlong _, Vint _ => v2 + | _, _ => Vundef + end + | MUshrx i => + match v1, v2 with + | Vint _, Vint _ => + if Int.ltu i (Int.repr 31) then v2 else Vundef + | _, _ => Vundef + end + | MUshrxl i => + match v1, v2 with + | Vlong _, Vlong _ => + if Int.ltu i (Int.repr 63) then v2 else Vundef + | _, _ => Vundef + end end. +(** * Evaluation functions *) + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 @@ -302,25 +334,33 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) (* Expansed branches *) - | CEbeqw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Ceq) v1 v2 zero32 - | CEbnew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Cne) v1 v2 zero32 - | CEbequw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 - | CEbneuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 - | CEbltw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Clt) v1 v2 zero32 - | CEbltuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 - | CEbgew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Cge) v1 v2 zero32 - | CEbgeuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 - | CEbeql optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Ceq) v1 v2 zero64 - | CEbnel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Cne) v1 v2 zero64 - | CEbequl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 - | CEbneul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 - | CEbltl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Clt) v1 v2 zero64 - | CEbltul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 - | CEbgel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Cge) v1 v2 zero64 - | CEbgeul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 | _, _ => None end. +(** Assert sp is a pointer *) + +Definition get_sp sp := + match sp with + | Vptr _ _ => sp + | _ => Vundef + end. + Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := @@ -423,29 +463,36 @@ Definition eval_operation | Ofloat_of_bits, v1::nil => Some (ExtValues.float_of_bits v1) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) (* Expansed conditions *) - | OEseqw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Ceq) v1 v2 zero32) - | OEsnew optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Cne) v1 v2 zero32) - | OEsequw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) - | OEsneuw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) - | OEsltw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Clt) v1 v2 zero32) - | OEsltuw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) + | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) - | OEluiw n is_long, v1::nil => Some (may_undef_int is_long Val.shl v1 (Vint n) (Vint (Int.repr 12))) - | OEaddiwr0 n is_long, v1::nil => Some (may_undef_int is_long Val.add v1 (Vint n) zero32) - | OEseql optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Ceq) v1 v2 zero64)) - | OEsnel optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Cne) v1 v2 zero64)) - | OEsequl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) - | OEsneul optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) - | OEsltl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Clt) v1 v2 zero64)) - | OEsltul optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) + | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) + | OEaddiw optR n, nil => Some (apply_bin_oreg optR Val.add (Vint n) Vundef zero32) + | OEaddiw optR n, v1::nil => Some (apply_bin_oreg optR Val.add v1 (Vint n) Vundef) + | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) + | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) + | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64)) + | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64)) + | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) + | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) + | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64)) + | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) - | OEluil n, v1::nil => Some (may_undef_luil v1 n) - | OEaddilr0 n, v1::nil => Some (may_undef_int true Val.addl v1 (Vlong n) zero64) + | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) + | OEaddil optR n, nil => Some (apply_bin_oreg optR Val.addl (Vlong n) Vundef zero64) + | OEaddil optR n, v1::nil => Some (apply_bin_oreg optR Val.addl v1 (Vlong n) Vundef) + | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) + | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) | OEloadli n, nil => Some (Vlong n) + | OEmayundef mu, v1 :: v2 :: nil => Some (eval_may_undef mu v1 v2) | OEfeqd, v1::v2::nil => Some (Val.cmpf Ceq v1 v2) | OEfltd, v1::v2::nil => Some (Val.cmpf Clt v1 v2) | OEfled, v1::v2::nil => Some (Val.cmpf Cle v1 v2) @@ -530,6 +577,15 @@ Definition type_of_condition (c: condition) : list typ := | CEbgeul _ => Tlong :: Tlong :: nil end. +(** The type of mayundef and addsp is dynamic *) + +Definition type_of_mayundef mu := + match mu with + | MUint | MUshrx _ => (Tint :: Tint :: nil, Tint) + | MUlong => (Tlong :: Tint :: nil, Tint) + | MUshrxl _ => (Tlong :: Tlong :: nil, Tlong) + end. + Definition type_of_operation (op: operation) : list typ * typ := match op with | Omove => (nil, Tint) (* treated specially *) @@ -634,8 +690,11 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltiw _ => (Tint :: nil, Tint) | OEsltiuw _ => (Tint :: nil, Tint) | OExoriw _ => (Tint :: nil, Tint) - | OEluiw _ _ => (Tint :: nil, Tint) - | OEaddiwr0 _ _ => (Tint :: nil, Tint) + | OEluiw _ => (nil, Tint) + | OEaddiw None _ => (Tint :: nil, Tint) + | OEaddiw (Some _) _ => (nil, Tint) + | OEandiw _ => (Tint :: nil, Tint) + | OEoriw _ => (Tint :: nil, Tint) | OEseql _ => (Tlong :: Tlong :: nil, Tint) | OEsnel _ => (Tlong :: Tlong :: nil, Tint) | OEsequl _ => (Tlong :: Tlong :: nil, Tint) @@ -644,10 +703,14 @@ Definition type_of_operation (op: operation) : list typ * typ := | OEsltul _ => (Tlong :: Tlong :: nil, Tint) | OEsltil _ => (Tlong :: nil, Tint) | OEsltiul _ => (Tlong :: nil, Tint) + | OEandil _ => (Tlong :: nil, Tlong) + | OEoril _ => (Tlong :: nil, Tlong) | OExoril _ => (Tlong :: nil, Tlong) - | OEluil _ => (Tlong :: nil, Tlong) - | OEaddilr0 _ => (Tlong :: nil, Tlong) + | OEluil _ => (nil, Tlong) + | OEaddil None _ => (Tlong :: nil, Tlong) + | OEaddil (Some _) _ => (nil, Tlong) | OEloadli _ => (nil, Tlong) + | OEmayundef mu => type_of_mayundef mu | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) | OEfltd => (Tfloat :: Tfloat :: nil, Tint) | OEfled => (Tfloat :: Tfloat :: nil, Tint) @@ -689,6 +752,14 @@ Proof. intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. Qed. +Remark type_mayundef: + forall mu v1 v2, Val.has_type (eval_may_undef mu v1 v2) (snd (type_of_mayundef mu)). +Proof. + intros. unfold eval_may_undef. + destruct mu eqn:EQMU, v1, v2; simpl; auto. + all: destruct Int.ltu; simpl; auto. +Qed. + Lemma type_of_operation_sound: forall op vl sp v m, op <> Omove -> @@ -698,7 +769,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). intros. destruct op; simpl; simpl in H0; FuncInv; subst; simpl. (* move *) - - congruence. + - simpl in H; congruence. (* intconst, longconst, floatconst, singleconst *) - exact I. - exact I. @@ -866,67 +937,79 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* cmp *) - destruct (eval_condition cond vl m)... destruct b... (* OEseqw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsnew *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsequw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + - destruct optR as [[]|]; simpl; unfold Val.cmpu; destruct Val.cmpu_bool... all: destruct b... (* OEsneuw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + - destruct optR as [[]|]; simpl; unfold Val.cmpu; destruct Val.cmpu_bool... all: destruct b... (* OEsltw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + - destruct optR as [[]|]; simpl; unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsltuw *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + - destruct optR as [[]|]; simpl; unfold Val.cmpu; destruct Val.cmpu_bool... all: destruct b... (* OEsltiw *) - unfold Val.cmp; destruct Val.cmp_bool... all: destruct b... (* OEsltiuw *) - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... + (* OEaddiw *) + - destruct optR as [[]|]; simpl in *; trivial. + - destruct optR as [[]|]; simpl in *; trivial; + apply type_add. + (* OEandiw *) + - destruct v0... + (* OEoriw *) + - destruct v0... (* OExoriw *) - destruct v0... (* OEluiw *) - - unfold may_undef_int; - destruct v0, is_long; simpl; trivial; - destruct (Int.ltu _ _); cbn; trivial. - (* OEaddiwr0 *) - - destruct v0, is_long; simpl; trivial. + - destruct (Int.ltu _ _); cbn; trivial. (* OEseql *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + - destruct optR as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsnel *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + - destruct optR as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsequl *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + - destruct optR as [[]|]; simpl; unfold Val.cmplu; destruct Val.cmplu_bool... all: destruct b... (* OEsneul *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + - destruct optR as [[]|]; simpl; unfold Val.cmplu; destruct Val.cmplu_bool... all: destruct b... (* OEsltl *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + - destruct optR as [[]|]; simpl; unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsltul *) - - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + - destruct optR as [[]|]; simpl; unfold Val.cmplu; destruct Val.cmplu_bool... all: destruct b... (* OEsltil *) - unfold Val.cmpl; destruct Val.cmpl_bool... all: destruct b... (* OEsltiul *) - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... + (* OEaddil *) + - destruct optR as [[]|]; simpl in *; trivial. + - destruct optR as [[]|]; simpl in *; trivial; + apply type_addl. + (* OEandil *) + - destruct v0... + (* OEoril *) + - destruct v0... (* OExoril *) - destruct v0... (* OEluil *) - - destruct v0; simpl; trivial. - (* OEaddilr0 *) - - destruct v0; simpl; trivial. + - simpl; trivial. (* OEloadli *) - trivial. + (* OEmayundef *) + - apply type_mayundef. (* OEfeqd *) - destruct v0; destruct v1; cbn; auto. destruct Float.cmp; cbn; auto. @@ -978,11 +1061,14 @@ Lemma is_trapping_op_sound: eval_operation genv sp op vl m <> None. Proof. unfold args_of_operation. - destruct op; destruct eq_operation; intros; simpl in *; try congruence. + destruct op eqn:E; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). + all: try destruct optR as [[]|]; simpl in H0; try discriminate. + all: try destruct Archi.ptr64; simpl in *; try discriminate. + all: try destruct mu; simpl in *; try discriminate. Qed. End SOUNDNESS. @@ -1026,22 +1112,22 @@ Definition negate_condition (cond: condition): condition := | Cnotcompf c => Ccompf c | Ccompfs c => Cnotcompfs c | Cnotcompfs c => Ccompfs c - | CEbeqw optR0 => CEbnew optR0 - | CEbnew optR0 => CEbeqw optR0 - | CEbequw optR0 => CEbneuw optR0 - | CEbneuw optR0 => CEbequw optR0 - | CEbltw optR0 => CEbgew optR0 - | CEbltuw optR0 => CEbgeuw optR0 - | CEbgew optR0 => CEbltw optR0 - | CEbgeuw optR0 => CEbltuw optR0 - | CEbeql optR0 => CEbnel optR0 - | CEbnel optR0 => CEbeql optR0 - | CEbequl optR0 => CEbneul optR0 - | CEbneul optR0 => CEbequl optR0 - | CEbltl optR0 => CEbgel optR0 - | CEbltul optR0 => CEbgeul optR0 - | CEbgel optR0 => CEbltl optR0 - | CEbgeul optR0 => CEbltul optR0 + | CEbeqw optR => CEbnew optR + | CEbnew optR => CEbeqw optR + | CEbequw optR => CEbneuw optR + | CEbneuw optR => CEbequw optR + | CEbltw optR => CEbgew optR + | CEbltuw optR => CEbgeuw optR + | CEbgew optR => CEbltw optR + | CEbgeuw optR => CEbltuw optR + | CEbeql optR => CEbnel optR + | CEbnel optR => CEbeql optR + | CEbequl optR => CEbneul optR + | CEbneul optR => CEbequl optR + | CEbltl optR => CEbgel optR + | CEbltul optR => CEbgeul optR + | CEbgel optR => CEbltl optR + | CEbgeul optR => CEbltul optR end. Lemma eval_negate_condition: @@ -1062,37 +1148,37 @@ Proof. repeat (destruct vl; auto). repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmp_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmpu_bool. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. - repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmpl_bool. - repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; apply Val.negate_cmplu_bool. Qed. @@ -1119,7 +1205,8 @@ Qed. Lemma type_shift_stack_operation: forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. Proof. - intros. destruct op; auto. + intros. destruct op; auto; + try destruct optR as [[]|]; simpl; auto. Qed. Lemma eval_shift_stack_addressing: @@ -1136,7 +1223,7 @@ Lemma eval_shift_stack_operation: eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. Proof. - intros. destruct op; simpl; auto. destruct vl; auto. + intros. destruct op eqn:E; simpl; auto; destruct vl; auto. rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. Qed. @@ -1237,7 +1324,7 @@ Proof. f_equal. f_equal. apply cond_depends_on_memory_correct; trivial. all: intros; repeat (destruct args; auto); unfold Val.cmpu, Val.cmpu_bool, Val.cmplu, Val.cmplu_bool; - try destruct optR0 as [[]|]; simpl; + try destruct optR as [[]|]; simpl; destruct v; try destruct v0; simpl; auto; try apply negb_false_iff in H; try rewrite H; auto. Qed. @@ -1249,7 +1336,7 @@ Lemma cond_valid_pointer_eq: Proof. intros until m2. intro MEM. destruct cond eqn:COND; simpl; try congruence. all: repeat (destruct args; simpl; try congruence); - try destruct optR0 as [[]|]; simpl; + try destruct optR as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; try erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. @@ -1262,7 +1349,7 @@ Proof. intros until m2. destruct op; simpl; try congruence. intro MEM; erewrite cond_valid_pointer_eq; eauto. all: intros MEM; repeat (destruct args; simpl; try congruence); - try destruct optR0 as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; + try destruct optR as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; unfold Val.cmpu, Val.cmplu; erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. @@ -1394,21 +1481,22 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. -Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR0, +Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) - (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). + Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) + (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). Proof. - intros until optR0. intros HV1 HV2. - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmpu; + intros until optR. intros HV1 HV2. + destruct optR as [[]|]; simpl; unfold zero32, Val.cmpu; destruct (Val.cmpu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; assert (HVI: Val.inject f (Vint Int.zero) (Vint Int.zero)) by apply Val.inject_int. + exploit eval_cmpu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. - + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + + exploit eval_cmpu_bool_inj'. eapply HV1. instantiate (1:=v'0). + eauto. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. @@ -1435,21 +1523,22 @@ Proof. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. -Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR0, +Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR, Val.inject f v v' -> Val.inject f v0 v'0 -> - Val.inject f (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) - (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). + Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) + (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). Proof. - intros until optR0. intros HV1 HV2. - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmplu; + intros until optR. intros HV1 HV2. + destruct optR as [[]|]; simpl; unfold zero64, Val.cmplu; destruct (Val.cmplu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; assert (HVI: Val.inject f (Vlong Int64.zero) (Vlong Int64.zero)) by apply Val.inject_long. + exploit eval_cmplu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. - + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + + exploit eval_cmplu_bool_inj'. eapply HV1. instantiate (1:=v'0). + eauto. eapply Heqo. intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. Qed. @@ -1475,37 +1564,37 @@ Proof. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmpu_bool_inj'; eauto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. -- destruct optR0 as [[]|]; simpl; +- destruct optR as [[]|]; simpl; inv H3; inv H2; simpl in H0; inv H0; auto. -- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; +- destruct optR as [[]|]; unfold apply_bin_oreg in *; eapply eval_cmplu_bool_inj'; eauto. Qed. @@ -1652,7 +1741,7 @@ Proof. (* shru, shruimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shrx *) + (* shrx *) - inv H4; cbn; try apply Val.val_inject_undef. destruct (Int.ltu n (Int.repr 63)); cbn. apply Val.inject_long. @@ -1716,11 +1805,11 @@ Proof. destruct b; simpl; constructor. simpl; constructor. (* OEseqw *) - - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsnew *) - - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsequw *) @@ -1728,7 +1817,7 @@ Proof. (* OEsneuw *) - apply eval_cmpu_bool_inj_opt; auto. (* OEsltw *) - - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; inv H4; inv H2; simpl; try destruct (Int.lt _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsltuw *) @@ -1737,23 +1826,26 @@ Proof. - inv H4; simpl; cbn; auto; try destruct (Int.lt _ _); apply Val.inject_int. (* OEsltiuw *) - apply eval_cmpu_bool_inj; auto. + (* OEaddiw *) + - destruct optR as [[]|]; auto; simpl. + rewrite Int.add_zero_l; auto. + rewrite Int.add_commut, Int.add_zero_l; auto. + - destruct optR as [[]|]; auto; simpl; + eapply Val.add_inject; auto. + (* OEandiw *) + - inv H4; cbn; auto. + (* OEoriw *) + - inv H4; cbn; auto. (* OExoriw *) - inv H4; simpl; auto. (* OEluiw *) - - unfold may_undef_int; - destruct is_long; - inv H4; simpl; auto; - destruct (Int.ltu _ _); auto. - (* OEaddiwr0 *) - - unfold may_undef_int; - destruct is_long; - inv H4; simpl; auto. + - destruct (Int.ltu _ _); auto. (* OEseql *) - - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsnel *) - - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsequl *) @@ -1761,7 +1853,7 @@ Proof. (* OEsneul *) - apply eval_cmplu_bool_inj_opt; auto. (* OEsltl *) - - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; inv H4; inv H2; simpl; try destruct (Int64.lt _ _); simpl; cbn; auto; try apply Val.inject_int. (* OEsltul *) @@ -1770,13 +1862,22 @@ Proof. - inv H4; simpl; cbn; auto; try destruct (Int64.lt _ _); apply Val.inject_int. (* OEsltiul *) - apply eval_cmplu_bool_inj; auto. + (* OEaddil *) + - destruct optR as [[]|]; auto; simpl. + rewrite Int64.add_zero_l; auto. + rewrite Int64.add_commut, Int64.add_zero_l; auto. + - destruct optR as [[]|]; auto; simpl; + eapply Val.addl_inject; auto. + (* OEandil *) + - inv H4; cbn; auto. + (* OEoril *) + - inv H4; cbn; auto. (* OExoril *) - inv H4; simpl; auto. - (* OEluil *) - - inv H4; simpl; auto. - (* OEaddilr0 *) - - unfold may_undef_int; - inv H4; simpl; auto. + (* OEmayundef *) + - destruct mu; inv H4; inv H2; simpl; auto; + try destruct (Int.ltu _ _); simpl; auto. + all: eapply Val.inject_ptr; eauto. (* OEfeqd *) - inv H4; inv H2; cbn; simpl; auto. destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. diff --git a/riscV/OpWeights.ml b/riscV/OpWeights.ml index 35ae81e6..0a1d9ad4 100644 --- a/riscV/OpWeights.ml +++ b/riscV/OpWeights.ml @@ -1,177 +1,168 @@ -open Op;; -open PrepassSchedulingOracleDeps;; - -module Rocket = - struct - (* Attempt at modeling the Rocket core *) - - let resource_bounds = [| 1 |];; - let nr_non_pipelined_units = 1;; (* divider *) - - let latency_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> 4 - - | Onegf -> 1 (*r [rd = - r1] *) - | Oabsf (*r [rd = abs(r1)] *) - | Oaddf (*r [rd = r1 + r2] *) - | Osubf (*r [rd = r1 - r2] *) - | Omulf -> 6 (*r [rd = r1 * r2] *) - | Onegfs -> 1 (*r [rd = - r1] *) - | Oabsfs (*r [rd = abs(r1)] *) - | Oaddfs (*r [rd = r1 + r2] *) - | Osubfs (*r [rd = r1 - r2] *) - | Omulfs -> 4 (*r [rd = r1 * r2] *) - | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle -> 4 (*r [rd] is [r1] extended to double-precision float *) - (*c Conversions between int and float: *) - | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) - | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) - | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) - | Ofloatofintu -> 6 (*r [rd = float64_of_unsigned_int(r1)] *) - | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) - | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) - | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) - | Osingleofintu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) - | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) - | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) - | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) - | Ofloatoflongu -> 6 (*r [rd = float64_of_unsigned_long(r1)] *) - | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) - | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) - | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) - | Osingleoflongu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) - - | Odiv | Odivu | Odivl | Odivlu -> 16 - | Odivfs -> 35 - | Odivf -> 50 - - | Ocmp cond -> - (match cond with - | Ccomp _ - | Ccompu _ - | Ccompimm _ - | Ccompuimm _ - | Ccompl _ - | Ccomplu _ - | Ccomplimm _ - | Ccompluimm _ - | CEbeqw _ - | CEbnew _ - | CEbequw _ - | CEbneuw _ - | CEbltw _ - | CEbltuw _ - | CEbgew _ - | CEbgeuw _ - | CEbeql _ - | CEbnel _ - | CEbequl _ - | CEbneul _ - | CEbltl _ - | CEbltul _ - | CEbgel _ - | CEbgeul _ -> 1 - | Ccompf _ - | Cnotcompf _ -> 6 - | Ccompfs _ - | Cnotcompfs _ -> 4) - | _ -> 1;; - - let resources_of_op (op : operation) (nargs : int) = resource_bounds;; - - let non_pipelined_resources_of_op (op : operation) (nargs : int) = - match op with - | Odiv | Odivu -> [| 29 |] - | Odivfs -> [| 20 |] - | Odivl | Odivlu | Odivf -> [| 50 |] - | _ -> [| -1 |];; - - let resources_of_cond (cond : condition) (nargs : int) = resource_bounds;; - - let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; - let latency_of_call _ _ = 6;; - - let resources_of_load trap chunk addressing nargs = resource_bounds;; - - let resources_of_store chunk addressing nargs = resource_bounds;; - - let resources_of_call _ _ = resource_bounds;; - let resources_of_builtin _ = resource_bounds;; - end;; - -module SweRV_EH1 = - struct - (* Attempt at modeling SweRV EH1 - [| issues ; LSU ; multiplier |] *) - let resource_bounds = [| 2 ; 1; 1 |];; - let nr_non_pipelined_units = 1;; (* divider *) - - let latency_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> 3 - | Odiv | Odivu | Odivl | Odivlu -> 16 - | _ -> 1;; - - let resources_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> [| 1 ; 0 ; 1 |] - | Odiv | Odivu | Odivl | Odivlu -> [| 0 ; 0; 0 |] - | _ -> [| 1; 0; 0 |];; - - let non_pipelined_resources_of_op (op : operation) (nargs : int) = - match op with - | Odiv | Odivu -> [| 29 |] - | Odivfs -> [| 20 |] - | Odivl | Odivlu | Odivf -> [| 50 |] - | _ -> [| -1 |];; - - let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |];; - - let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; - let latency_of_call _ _ = 6;; - - let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |];; - - let resources_of_store chunk addressing nargs = [| 1; 1; 0 |];; - - let resources_of_call _ _ = resource_bounds;; - let resources_of_builtin _ = resource_bounds;; - end;; +open Op +open PrepassSchedulingOracleDeps + +module Rocket = struct + (* Attempt at modeling the Rocket core *) + + let resource_bounds = [| 1 |] + + let nr_non_pipelined_units = 1 + + (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> 4 + | Onegf -> 1 (*r [rd = - r1] *) + | Oabsf (*r [rd = abs(r1)] *) + | Oaddf (*r [rd = r1 + r2] *) + | Osubf (*r [rd = r1 - r2] *) + | Omulf -> + 6 (*r [rd = r1 * r2] *) + | Onegfs -> 1 (*r [rd = - r1] *) + | Oabsfs (*r [rd = abs(r1)] *) + | Oaddfs (*r [rd = r1 + r2] *) + | Osubfs (*r [rd = r1 - r2] *) + | Omulfs -> + 4 (*r [rd = r1 * r2] *) + | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (*r [rd] is [r1] extended to double-precision float *) + (*c Conversions between int and float: *) + | Ofloatconst _ | Osingleconst _ + | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (*r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (*r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (*r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu -> + 2 (*r [rd = float32_of_unsigned_int(r1)] *) + | OEfeqd | OEfltd | OEfeqs | OEflts | OEfles | OEfled | Obits_of_single + | Obits_of_float | Osingle_of_bits | Ofloat_of_bits -> + 2 + | OEloadli _ -> 2 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | Odivfs -> 35 + | Odivf -> 50 + | Ocmp cond -> ( + match cond with + | Ccomp _ | Ccompu _ | Ccompimm _ | Ccompuimm _ | Ccompl _ | Ccomplu _ + | Ccomplimm _ | Ccompluimm _ | CEbeqw _ | CEbnew _ | CEbequw _ + | CEbneuw _ | CEbltw _ | CEbltuw _ | CEbgew _ | CEbgeuw _ | CEbeql _ + | CEbnel _ | CEbequl _ | CEbneul _ | CEbltl _ | CEbltul _ | CEbgel _ + | CEbgeul _ -> + 1 + | Ccompf _ | Cnotcompf _ -> 2 + | Ccompfs _ | Cnotcompfs _ -> 2) + | OEmayundef _ -> 0 + | _ -> 1 + + let resources_of_op (op : operation) (nargs : int) = resource_bounds + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |] + + let resources_of_cond (cond : condition) (nargs : int) = resource_bounds + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3 + + let latency_of_call _ _ = 6 + + let resources_of_load trap chunk addressing nargs = resource_bounds + + let resources_of_store chunk addressing nargs = resource_bounds + + let resources_of_call _ _ = resource_bounds + + let resources_of_builtin _ = resource_bounds +end + +module SweRV_EH1 = struct + (* Attempt at modeling SweRV EH1 + [| issues ; LSU ; multiplier |] *) + let resource_bounds = [| 2; 1; 1 |] + + let nr_non_pipelined_units = 1 + + (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> 3 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | _ -> 1 + + let resources_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> [| 1; 0; 1 |] + | Odiv | Odivu | Odivl | Odivlu -> [| 0; 0; 0 |] + | _ -> [| 1; 0; 0 |] + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |] + + let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |] + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3 + + let latency_of_call _ _ = 6 + + let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |] + + let resources_of_store chunk addressing nargs = [| 1; 1; 0 |] + + let resources_of_call _ _ = resource_bounds + + let resources_of_builtin _ = resource_bounds +end let get_opweights () : opweights = match !Clflags.option_mtune with | "rocket" | "" -> - { - pipelined_resource_bounds = Rocket.resource_bounds; - nr_non_pipelined_units = Rocket.nr_non_pipelined_units; - latency_of_op = Rocket.latency_of_op; - resources_of_op = Rocket.resources_of_op; - non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; - latency_of_load = Rocket.latency_of_load; - resources_of_load = Rocket.resources_of_load; - resources_of_store = Rocket.resources_of_store; - resources_of_cond = Rocket.resources_of_cond; - latency_of_call = Rocket.latency_of_call; - resources_of_call = Rocket.resources_of_call; - resources_of_builtin = Rocket.resources_of_builtin - } + { + pipelined_resource_bounds = Rocket.resource_bounds; + nr_non_pipelined_units = Rocket.nr_non_pipelined_units; + latency_of_op = Rocket.latency_of_op; + resources_of_op = Rocket.resources_of_op; + non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; + latency_of_load = Rocket.latency_of_load; + resources_of_load = Rocket.resources_of_load; + resources_of_store = Rocket.resources_of_store; + resources_of_cond = Rocket.resources_of_cond; + latency_of_call = Rocket.latency_of_call; + resources_of_call = Rocket.resources_of_call; + resources_of_builtin = Rocket.resources_of_builtin; + } | "SweRV_EH1" | "EH1" -> - { - pipelined_resource_bounds = SweRV_EH1.resource_bounds; - nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; - latency_of_op = SweRV_EH1.latency_of_op; - resources_of_op = SweRV_EH1.resources_of_op; - non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; - latency_of_load = SweRV_EH1.latency_of_load; - resources_of_load = SweRV_EH1.resources_of_load; - resources_of_store = SweRV_EH1.resources_of_store; - resources_of_cond = SweRV_EH1.resources_of_cond; - latency_of_call = SweRV_EH1.latency_of_call; - resources_of_call = SweRV_EH1.resources_of_call; - resources_of_builtin = SweRV_EH1.resources_of_builtin - } - | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);; + { + pipelined_resource_bounds = SweRV_EH1.resource_bounds; + nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; + latency_of_op = SweRV_EH1.latency_of_op; + resources_of_op = SweRV_EH1.resources_of_op; + non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; + latency_of_load = SweRV_EH1.latency_of_load; + resources_of_load = SweRV_EH1.resources_of_load; + resources_of_store = SweRV_EH1.resources_of_store; + resources_of_cond = SweRV_EH1.resources_of_cond; + latency_of_call = SweRV_EH1.latency_of_call; + resources_of_call = SweRV_EH1.resources_of_call; + resources_of_builtin = SweRV_EH1.resources_of_builtin; + } + | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx) diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 84380251..0d47192a 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -30,10 +30,20 @@ let comparison_name = function | Cgt -> ">" | Cge -> ">=" -let get_optR0_s c reg pp r1 r2 = function +let mu_name pp = function + | MUint -> fprintf pp "MUint" + | MUlong -> fprintf pp "MUlong" + | MUshrx i -> fprintf pp "MUshrx(%ld)" (camlint_of_coqint i) + | MUshrxl i -> fprintf pp "MUshrxl(%ld)" (camlint_of_coqint i) + +let get_optR_s c reg pp r1 r2 = function | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 - | Some true -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 - | Some false -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) + | Some X0_L -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 + | Some X0_R -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) + +let get_optR_a pp = function + | None -> failwith "PrintOp: None in get_optR_a instruction (problem with RTL expansions?)" + | Some X0_L | Some X0_R -> fprintf pp "X0" let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> @@ -60,47 +70,47 @@ let print_condition reg pp = function fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 | (Cnotcompfs c, [r1;r2]) -> fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 - | (CEbeqw optR0, [r1;r2]) -> - fprintf pp "CEbeqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbnew optR0, [r1;r2]) -> - fprintf pp "CEbnew"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbequw optR0, [r1;r2]) -> - fprintf pp "CEbequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbneuw optR0, [r1;r2]) -> - fprintf pp "CEbneuw"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbltw optR0, [r1;r2]) -> - fprintf pp "CEbltw"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbltuw optR0, [r1;r2]) -> - fprintf pp "CEbltuw"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbgew optR0, [r1;r2]) -> - fprintf pp "CEbgew"; (get_optR0_s Cge reg pp r1 r2 optR0) - | (CEbgeuw optR0, [r1;r2]) -> - fprintf pp "CEbgeuw"; (get_optR0_s Cge reg pp r1 r2 optR0) - | (CEbeql optR0, [r1;r2]) -> - fprintf pp "CEbeql"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbnel optR0, [r1;r2]) -> - fprintf pp "CEbnel"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbequl optR0, [r1;r2]) -> - fprintf pp "CEbequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | (CEbneul optR0, [r1;r2]) -> - fprintf pp "CEbneul"; (get_optR0_s Cne reg pp r1 r2 optR0) - | (CEbltl optR0, [r1;r2]) -> - fprintf pp "CEbltl"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbltul optR0, [r1;r2]) -> - fprintf pp "CEbltul"; (get_optR0_s Clt reg pp r1 r2 optR0) - | (CEbgel optR0, [r1;r2]) -> - fprintf pp "CEbgel"; (get_optR0_s Cge reg pp r1 r2 optR0) - | (CEbgeul optR0, [r1;r2]) -> - fprintf pp "CEbgeul"; (get_optR0_s Cge reg pp r1 r2 optR0) + | (CEbeqw optR, [r1;r2]) -> + fprintf pp "CEbeqw"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbnew optR, [r1;r2]) -> + fprintf pp "CEbnew"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbequw optR, [r1;r2]) -> + fprintf pp "CEbequw"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbneuw optR, [r1;r2]) -> + fprintf pp "CEbneuw"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbltw optR, [r1;r2]) -> + fprintf pp "CEbltw"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbltuw optR, [r1;r2]) -> + fprintf pp "CEbltuw"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbgew optR, [r1;r2]) -> + fprintf pp "CEbgew"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbgeuw optR, [r1;r2]) -> + fprintf pp "CEbgeuw"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbeql optR, [r1;r2]) -> + fprintf pp "CEbeql"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbnel optR, [r1;r2]) -> + fprintf pp "CEbnel"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbequl optR, [r1;r2]) -> + fprintf pp "CEbequl"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbneul optR, [r1;r2]) -> + fprintf pp "CEbneul"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbltl optR, [r1;r2]) -> + fprintf pp "CEbltl"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbltul optR, [r1;r2]) -> + fprintf pp "CEbltul"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbgel optR, [r1;r2]) -> + fprintf pp "CEbgel"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbgeul optR, [r1;r2]) -> + fprintf pp "CEbgeul"; (get_optR_s Cge reg pp r1 r2 optR) | _ -> fprintf pp "<bad condition>" let print_operation reg pp = function | Omove, [r1] -> reg pp r1 - | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) - | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) - | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) - | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) + | Ointconst n, [] -> fprintf pp "Ointconst(%ld)" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "Olongconst(%LdL)" (camlint64_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "Ofloatconst(%F)" (camlfloat_of_coqfloat n) + | Osingleconst n, [] -> fprintf pp "Osingleconst(%Ff)" (camlfloat_of_coqfloat32 n) | Oaddrsymbol(id, ofs), [] -> fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) | Oaddrstack ofs, [] -> @@ -193,29 +203,36 @@ let print_operation reg pp = function | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) - | OEseqw optR0, [r1;r2] -> fprintf pp "OEseqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsnew optR0, [r1;r2] -> fprintf pp "OEsnew"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsequw optR0, [r1;r2] -> fprintf pp "OEsequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsneuw optR0, [r1;r2] -> fprintf pp "OEsneuw"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsltw optR0, [r1;r2] -> fprintf pp "OEsltw"; (get_optR0_s Clt reg pp r1 r2 optR0) - | OEsltuw optR0, [r1;r2] -> fprintf pp "OEsltuw"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEseqw optR, [r1;r2] -> fprintf pp "OEseqw"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsnew optR, [r1;r2] -> fprintf pp "OEsnew"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsequw optR, [r1;r2] -> fprintf pp "OEsequw"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsneuw optR, [r1;r2] -> fprintf pp "OEsneuw"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsltw optR, [r1;r2] -> fprintf pp "OEsltw"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltuw optR, [r1;r2] -> fprintf pp "OEsltuw"; (get_optR_s Clt reg pp r1 r2 optR) | OEsltiw n, [r1] -> fprintf pp "OEsltiw(%a,%ld)" reg r1 (camlint_of_coqint n) | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) - | OEluiw (n, _), _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) - | OEaddiwr0 (n, _), _ -> fprintf pp "OEaddiwr0(%ld,X0)" (camlint_of_coqint n) - | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsnel optR0, [r1;r2] -> fprintf pp "OEsnel"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsequl optR0, [r1;r2] -> fprintf pp "OEsequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) - | OEsneul optR0, [r1;r2] -> fprintf pp "OEsneul"; (get_optR0_s Cne reg pp r1 r2 optR0) - | OEsltl optR0, [r1;r2] -> fprintf pp "OEsltl"; (get_optR0_s Clt reg pp r1 r2 optR0) - | OEsltul optR0, [r1;r2] -> fprintf pp "OEsltul"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) + | OEaddiw (optR, n), [] -> fprintf pp "OEaddiw(%a,%ld)" get_optR_a optR (camlint_of_coqint n) + | OEaddiw (optR, n), [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEandiw n, [r1] -> fprintf pp "OEandiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEoriw n, [r1] -> fprintf pp "OEoriw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEseql optR, [r1;r2] -> fprintf pp "OEseql"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsnel optR, [r1;r2] -> fprintf pp "OEsnel"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsequl optR, [r1;r2] -> fprintf pp "OEsequl"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsneul optR, [r1;r2] -> fprintf pp "OEsneul"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsltl optR, [r1;r2] -> fprintf pp "OEsltl"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltul optR, [r1;r2] -> fprintf pp "OEsltul"; (get_optR_s Clt reg pp r1 r2 optR) | OEsltil n, [r1] -> fprintf pp "OEsltil(%a,%ld)" reg r1 (camlint_of_coqint n) | OEsltiul n, [r1] -> fprintf pp "OEsltiul(%a,%ld)" reg r1 (camlint_of_coqint n) | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) - | OEaddilr0 n, _ -> fprintf pp "OEaddilr0(%ld,X0)" (camlint_of_coqint n) + | OEaddil (optR, n), [] -> fprintf pp "OEaddil(%a,%ld)" get_optR_a optR (camlint_of_coqint n) + | OEaddil (optR, n), [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEandil n, [r1] -> fprintf pp "OEandil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEoril n, [r1] -> fprintf pp "OEoril(%a,%ld)" reg r1 (camlint_of_coqint n) | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) + | OEmayundef mu, [r1;r2] -> fprintf pp "OEmayundef (%a,%a,%a)" mu_name mu reg r1 reg r2 | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 | OEfltd, [r1;r2] -> fprintf pp "OEfltd(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 | OEfled, [r1;r2] -> fprintf pp "OEfled(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index 2669d4bc..2739bc5d 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -14,8 +14,11 @@ Definition is_inv_cmp_int (cmp: comparison) : bool := Definition is_inv_cmp_float (cmp: comparison) : bool := match cmp with | Cge | Cgt => true | _ => false end. -Definition make_optR0 (is_x0 is_inv: bool) : option bool := - if is_x0 then Some is_inv else None. +Definition make_optR (is_x0 is_inv: bool) : option oreg := + if is_x0 then + (if is_inv then Some (X0_L) + else Some (X0_R)) + else None. (** Functions to manage lists of "fake" values *) @@ -27,52 +30,48 @@ Definition make_lhsv_cmp (is_inv: bool) (hv1 hv2: hsval) : list_hsval := Definition make_lhsv_single (hvs: hsval) : list_hsval := fScons hvs fSnil. -(** Expansion functions *) +(** * Expansion functions *) -(* Immediate loads *) +(** ** Immediate loads *) -Definition load_hilo32 (hv1: hsval) (hi lo: int) (is_long: bool) := - let hl := make_lhsv_single hv1 in +Definition load_hilo32 (hi lo: int) := if Int.eq lo Int.zero then - fSop (OEluiw hi is_long) hl + fSop (OEluiw hi) fSnil else - let hvs := fSop (OEluiw hi is_long) hl in - let hl' := make_lhsv_single hvs in - fSop (Oaddimm lo) hl'. + let hvs := fSop (OEluiw hi) fSnil in + let hl := make_lhsv_single hvs in + fSop (OEaddiw None lo) hl. -Definition load_hilo64 (hv1: hsval) (hi lo: int64) := - let hl := make_lhsv_single hv1 in +Definition load_hilo64 (hi lo: int64) := if Int64.eq lo Int64.zero then - fSop (OEluil hi) hl + fSop (OEluil hi) fSnil else - let hvs := fSop (OEluil hi) hl in + let hvs := fSop (OEluil hi) fSnil in let hl := make_lhsv_single hvs in - fSop (Oaddlimm lo) hl. + fSop (OEaddil None lo) hl. -Definition loadimm32 (hv1: hsval) (n: int) (is_long: bool) := +Definition loadimm32 (n: int) := match make_immed32 n with | Imm32_single imm => - let hl := make_lhsv_single hv1 in - fSop (OEaddiwr0 imm is_long) hl - | Imm32_pair hi lo => load_hilo32 hv1 hi lo is_long + fSop (OEaddiw (Some X0_R) imm) fSnil + | Imm32_pair hi lo => load_hilo32 hi lo end. -Definition loadimm64 (hv1: hsval) (n: int64) := +Definition loadimm64 (n: int64) := match make_immed64 n with | Imm64_single imm => - let hl := make_lhsv_single hv1 in - fSop (OEaddilr0 imm) hl - | Imm64_pair hi lo => load_hilo64 hv1 hi lo + fSop (OEaddil (Some X0_R) imm) fSnil + | Imm64_pair hi lo => load_hilo64 hi lo | Imm64_large imm => fSop (OEloadli imm) fSnil end. -Definition opimm32 (hv1: hsval) (n: int) (op: operation) (opimm: int -> operation) (is_long: bool) := +Definition opimm32 (hv1: hsval) (n: int) (op: operation) (opimm: int -> operation) := match make_immed32 n with | Imm32_single imm => let hl := make_lhsv_single hv1 in fSop (opimm imm) hl | Imm32_pair hi lo => - let hvs := load_hilo32 hv1 hi lo is_long in + let hvs := load_hilo32 hi lo in let hl := make_lhsv_cmp false hv1 hvs in fSop op hl end. @@ -83,7 +82,7 @@ Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> oper let hl := make_lhsv_single hv1 in fSop (opimm imm) hl | Imm64_pair hi lo => - let hvs := load_hilo64 hv1 hi lo in + let hvs := load_hilo64 hi lo in let hl := make_lhsv_cmp false hv1 hvs in fSop op hl | Imm64_large imm => @@ -92,55 +91,61 @@ Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> oper fSop op hl end. -Definition xorimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n Oxor OExoriw is_long. -Definition sltimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n (OEsltw None) OEsltiw is_long. -Definition sltuimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n (OEsltuw None) OEsltiuw is_long. +Definition addimm32 (hv1: hsval) (n: int) (or: option oreg) := opimm32 hv1 n Oadd (OEaddiw or). +Definition andimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oand OEandiw. +Definition orimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oor OEoriw. +Definition xorimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oxor OExoriw. +Definition sltimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltw None) OEsltiw. +Definition sltuimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltuw None) OEsltiuw. +Definition addimm64 (hv1: hsval) (n: int64) (or: option oreg) := opimm64 hv1 n Oaddl (OEaddil or). +Definition andimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oandl OEandil. +Definition orimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oorl OEoril. Definition xorimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oxorl OExoril. Definition sltimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltl None) OEsltil. Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEsltiul. -(* Comparisons intructions *) +(** ** Comparisons intructions *) -Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEseqw optR0) lhsv - | Cne => fSop (OEsnew optR0) lhsv - | Clt | Cgt => fSop (OEsltw optR0) lhsv + | Ceq => fSop (OEseqw optR) lhsv + | Cne => fSop (OEsnew optR) lhsv + | Clt | Cgt => fSop (OEsltw optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltw optR0) lhsv) in + let hvs := (fSop (OEsltw optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. -Definition cond_int32u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int32u (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEsequw optR0) lhsv - | Cne => fSop (OEsneuw optR0) lhsv - | Clt | Cgt => fSop (OEsltuw optR0) lhsv + | Ceq => fSop (OEsequw optR) lhsv + | Cne => fSop (OEsneuw optR) lhsv + | Clt | Cgt => fSop (OEsltuw optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltuw optR0) lhsv) in + let hvs := (fSop (OEsltuw optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. -Definition cond_int64s (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int64s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEseql optR0) lhsv - | Cne => fSop (OEsnel optR0) lhsv - | Clt | Cgt => fSop (OEsltl optR0) lhsv + | Ceq => fSop (OEseql optR) lhsv + | Cne => fSop (OEsnel optR) lhsv + | Clt | Cgt => fSop (OEsltl optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltl optR0) lhsv) in + let hvs := (fSop (OEsltl optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. -Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := +Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := match cmp with - | Ceq => fSop (OEsequl optR0) lhsv - | Cne => fSop (OEsneul optR0) lhsv - | Clt | Cgt => fSop (OEsltul optR0) lhsv + | Ceq => fSop (OEsequl optR) lhsv + | Cne => fSop (OEsneul optR) lhsv + | Clt | Cgt => fSop (OEsltul optR) lhsv | Cle | Cge => - let hvs := (fSop (OEsltul optR0) lhsv) in + let hvs := (fSop (OEsltul optR) lhsv) in let hl := make_lhsv_single hvs in fSop (OExoriw Int.one) hl end. @@ -148,83 +153,87 @@ Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := let is_inv := is_inv_cmp_int cmp in if Int.eq n Int.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int32s cmp hl optR0 + cond_int32s cmp hl optR else match cmp with | Ceq | Cne => - let optR0 := make_optR0 true is_inv in - let hvs := xorimm32 hv1 n false in + let optR := make_optR true is_inv in + let hvs := xorimm32 hv1 n in let hl := make_lhsv_cmp false hvs hvs in - cond_int32s cmp hl optR0 - | Clt => sltimm32 hv1 n false + cond_int32s cmp hl optR + | Clt => sltimm32 hv1 n | Cle => if Int.eq n (Int.repr Int.max_signed) then - loadimm32 hv1 Int.one false - else sltimm32 hv1 (Int.add n Int.one) false + let hvs := loadimm32 Int.one in + let hl := make_lhsv_cmp false hv1 hvs in + fSop (OEmayundef MUint) hl + else sltimm32 hv1 (Int.add n Int.one) | _ => - let optR0 := make_optR0 false is_inv in - let hvs := loadimm32 hv1 n false in + let optR := make_optR false is_inv in + let hvs := loadimm32 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int32s cmp hl optR0 + cond_int32s cmp hl optR end. Definition expanse_condimm_int32u (cmp: comparison) (hv1: hsval) (n: int) := let is_inv := is_inv_cmp_int cmp in if Int.eq n Int.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int32u cmp hl optR0 + cond_int32u cmp hl optR else match cmp with - | Clt => sltuimm32 hv1 n false + | Clt => sltuimm32 hv1 n | _ => - let optR0 := make_optR0 false is_inv in - let hvs := loadimm32 hv1 n false in + let optR := make_optR false is_inv in + let hvs := loadimm32 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int32u cmp hl optR0 + cond_int32u cmp hl optR end. Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := let is_inv := is_inv_cmp_int cmp in if Int64.eq n Int64.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int64s cmp hl optR0 + cond_int64s cmp hl optR else match cmp with | Ceq | Cne => - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hvs := xorimm64 hv1 n in let hl := make_lhsv_cmp false hvs hvs in - cond_int64s cmp hl optR0 + cond_int64s cmp hl optR | Clt => sltimm64 hv1 n | Cle => if Int64.eq n (Int64.repr Int64.max_signed) then - loadimm32 hv1 Int.one true + let hvs := loadimm32 Int.one in + let hl := make_lhsv_cmp false hv1 hvs in + fSop (OEmayundef MUlong) hl else sltimm64 hv1 (Int64.add n Int64.one) | _ => - let optR0 := make_optR0 false is_inv in - let hvs := loadimm64 hv1 n in + let optR := make_optR false is_inv in + let hvs := loadimm64 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int64s cmp hl optR0 + cond_int64s cmp hl optR end. Definition expanse_condimm_int64u (cmp: comparison) (hv1: hsval) (n: int64) := let is_inv := is_inv_cmp_int cmp in if Int64.eq n Int64.zero then - let optR0 := make_optR0 true is_inv in + let optR := make_optR true is_inv in let hl := make_lhsv_cmp is_inv hv1 hv1 in - cond_int64u cmp hl optR0 + cond_int64u cmp hl optR else match cmp with | Clt => sltuimm64 hv1 n | _ => - let optR0 := make_optR0 false is_inv in - let hvs := loadimm64 hv1 n in + let optR := make_optR false is_inv in + let hvs := loadimm64 n in let hl := make_lhsv_cmp is_inv hv1 hvs in - cond_int64u cmp hl optR0 + cond_int64u cmp hl optR end. Definition cond_float (cmp: comparison) (lhsv: list_hsval) := @@ -251,46 +260,46 @@ Definition expanse_cond_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) := let hl := make_lhsv_single hvs in if normal' then hvs else fSop (OExoriw Int.one) hl. -(* Branches instructions *) +(** ** Branches instructions *) -Definition transl_cbranch_int32s (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int32s (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbeqw optR0 - | Cne => CEbnew optR0 - | Clt => CEbltw optR0 - | Cle => CEbgew optR0 - | Cgt => CEbltw optR0 - | Cge => CEbgew optR0 + | Ceq => CEbeqw optR + | Cne => CEbnew optR + | Clt => CEbltw optR + | Cle => CEbgew optR + | Cgt => CEbltw optR + | Cge => CEbgew optR end. -Definition transl_cbranch_int32u (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int32u (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbequw optR0 - | Cne => CEbneuw optR0 - | Clt => CEbltuw optR0 - | Cle => CEbgeuw optR0 - | Cgt => CEbltuw optR0 - | Cge => CEbgeuw optR0 + | Ceq => CEbequw optR + | Cne => CEbneuw optR + | Clt => CEbltuw optR + | Cle => CEbgeuw optR + | Cgt => CEbltuw optR + | Cge => CEbgeuw optR end. -Definition transl_cbranch_int64s (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int64s (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbeql optR0 - | Cne => CEbnel optR0 - | Clt => CEbltl optR0 - | Cle => CEbgel optR0 - | Cgt => CEbltl optR0 - | Cge => CEbgel optR0 + | Ceq => CEbeql optR + | Cne => CEbnel optR + | Clt => CEbltl optR + | Cle => CEbgel optR + | Cgt => CEbltl optR + | Cge => CEbgel optR end. -Definition transl_cbranch_int64u (cmp: comparison) (optR0: option bool) := +Definition transl_cbranch_int64u (cmp: comparison) (optR: option oreg) := match cmp with - | Ceq => CEbequl optR0 - | Cne => CEbneul optR0 - | Clt => CEbltul optR0 - | Cle => CEbgeul optR0 - | Cgt => CEbltul optR0 - | Cge => CEbgeul optR0 + | Ceq => CEbequl optR + | Cne => CEbneul optR + | Clt => CEbltul optR + | Cle => CEbgeul optR + | Cgt => CEbltul optR + | Cge => CEbgeul optR end. Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (condition * list_hsval) := @@ -298,9 +307,9 @@ Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (con let normal' := if cnot then negb normal else normal in let hvs := fn_cond cmp lhsv in let hl := make_lhsv_cmp false hvs hvs in - if normal' then ((CEbnew (Some false)), hl) else ((CEbeqw (Some false)), hl). + if normal' then ((CEbnew (Some X0_R)), hl) else ((CEbeqw (Some X0_R)), hl). -(** Target op simplifications using "fake" values *) +(** * Target simplifications using "fake" values *) Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := match op, lr with @@ -308,16 +317,16 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int32s c lhsv optR0) + Some (cond_int32s c lhsv optR) | Ocmp (Ccompu c), a1 :: a2 :: nil => let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int32u c lhsv optR0) + Some (cond_int32u c lhsv optR) | Ocmp (Ccompimm c imm), a1 :: nil => let hv1 := fsi_sreg_get hst a1 in Some (expanse_condimm_int32s c hv1 imm) @@ -328,16 +337,16 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int64s c lhsv optR0) + Some (cond_int64s c lhsv optR) | Ocmp (Ccomplu c), a1 :: a2 :: nil => let hv1 := fsi_sreg_get hst a1 in let hv2 := fsi_sreg_get hst a2 in let is_inv := is_inv_cmp_int c in - let optR0 := make_optR0 false is_inv in + let optR := make_optR false is_inv in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in - Some (cond_int64u c lhsv optR0) + Some (cond_int64u c lhsv optR) | Ocmp (Ccomplimm c imm), a1 :: nil => let hv1 := fsi_sreg_get hst a1 in Some (expanse_condimm_int64s c hv1 imm) @@ -368,6 +377,112 @@ Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_loca let is_inv := is_inv_cmp_float c in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (expanse_cond_fp true cond_single c lhsv) + | Ofloatconst f, nil => + let hvs := loadimm64 (Float.to_bits f) in + let hl := make_lhsv_single hvs in + Some (fSop (Ofloat_of_bits) hl) + | Osingleconst f, nil => + let hvs := loadimm32 (Float32.to_bits f) in + let hl := make_lhsv_single hvs in + Some (fSop (Osingle_of_bits) hl) + | Ointconst n, nil => + Some (loadimm32 n) + | Olongconst n, nil => + Some (loadimm64 n) + | Oaddimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (addimm32 hv1 n None) + | Oaddlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (addimm64 hv1 n None) + | Oandimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (andimm32 hv1 n) + | Oandlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (andimm64 hv1 n) + | Oorimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (orimm32 hv1 n) + | Oorlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (orimm64 hv1 n) + | Oxorimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (xorimm32 hv1 n) + | Oxorlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (xorimm64 hv1 n) + | Ocast8signed, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let hvs := fSop (Oshlimm (Int.repr 24)) hl in + let hl' := make_lhsv_single hvs in + Some (fSop (Oshrimm (Int.repr 24)) hl') + | Ocast16signed, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let hvs := fSop (Oshlimm (Int.repr 16)) hl in + let hl' := make_lhsv_single hvs in + Some (fSop (Oshrimm (Int.repr 16)) hl') + | Ocast32unsigned, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let cast32s_s := fSop Ocast32signed hl in + let cast32s_l := make_lhsv_single cast32s_s in + let sllil_s := fSop (Oshllimm (Int.repr 32)) cast32s_l in + let sllil_l := make_lhsv_single sllil_s in + Some (fSop (Oshrluimm (Int.repr 32)) sllil_l) + | Oshrximm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + if Int.eq n Int.zero then + let lhl := make_lhsv_cmp false hv1 hv1 in + Some (fSop (OEmayundef (MUshrx n)) lhl) + else + if Int.eq n Int.one then + let srliw_s := fSop (Oshruimm (Int.repr 31)) hl in + let srliw_l := make_lhsv_cmp false hv1 srliw_s in + let addw_s := fSop Oadd srliw_l in + let addw_l := make_lhsv_single addw_s in + let sraiw_s := fSop (Oshrimm Int.one) addw_l in + let sraiw_l := make_lhsv_cmp false sraiw_s sraiw_s in + Some (fSop (OEmayundef (MUshrx n)) sraiw_l) + else + let sraiw_s := fSop (Oshrimm (Int.repr 31)) hl in + let sraiw_l := make_lhsv_single sraiw_s in + let srliw_s := fSop (Oshruimm (Int.sub Int.iwordsize n)) sraiw_l in + let srliw_l := make_lhsv_cmp false hv1 srliw_s in + let addw_s := fSop Oadd srliw_l in + let addw_l := make_lhsv_single addw_s in + let sraiw_s' := fSop (Oshrimm n) addw_l in + let sraiw_l' := make_lhsv_cmp false sraiw_s' sraiw_s' in + Some (fSop (OEmayundef (MUshrx n)) sraiw_l') + | Oshrxlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + if Int.eq n Int.zero then + let lhl := make_lhsv_cmp false hv1 hv1 in + Some (fSop (OEmayundef (MUshrxl n)) lhl) + else + if Int.eq n Int.one then + let srlil_s := fSop (Oshrluimm (Int.repr 63)) hl in + let srlil_l := make_lhsv_cmp false hv1 srlil_s in + let addl_s := fSop Oaddl srlil_l in + let addl_l := make_lhsv_single addl_s in + let srail_s := fSop (Oshrlimm Int.one) addl_l in + let srail_l := make_lhsv_cmp false srail_s srail_s in + Some (fSop (OEmayundef (MUshrxl n)) srail_l) + else + let srail_s := fSop (Oshrlimm (Int.repr 63)) hl in + let srail_l := make_lhsv_single srail_s in + let srlil_s := fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) srail_l in + let srlil_l := make_lhsv_cmp false hv1 srlil_s in + let addl_s := fSop Oaddl srlil_l in + let addl_l := make_lhsv_single addl_s in + let srail_s' := fSop (Oshrlimm n) addl_l in + let srail_l' := make_lhsv_cmp false srail_s' srail_s' in + Some (fSop (OEmayundef (MUshrxl n)) srail_l') | _, _ => None end. @@ -375,14 +490,14 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args match cond, args with | (Ccomp c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32s c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (cond, lhsv) | (Ccompu c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32u c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in @@ -392,35 +507,35 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let hv1 := fsi_sreg_get prev a1 in (if Int.eq n Int.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int32s c (make_optR0 true is_inv) in + let cond := transl_cbranch_int32s c (make_optR true is_inv) in Some (cond, lhsv) else - let hvs := loadimm32 hv1 n false in + let hvs := loadimm32 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32s c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompuimm c n), (a1 :: nil) => let is_inv := is_inv_cmp_int c in let hv1 := fsi_sreg_get prev a1 in (if Int.eq n Int.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int32u c (make_optR0 true is_inv) in + let cond := transl_cbranch_int32u c (make_optR true is_inv) in Some (cond, lhsv) else - let hvs := loadimm32 hv1 n false in + let hvs := loadimm32 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int32u c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompl c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64s c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in Some (cond, lhsv) | (Ccomplu c), (a1 :: a2 :: nil) => let is_inv := is_inv_cmp_int c in - let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64u c (make_optR false is_inv) in let hv1 := fsi_sreg_get prev a1 in let hv2 := fsi_sreg_get prev a2 in let lhsv := make_lhsv_cmp is_inv hv1 hv2 in @@ -430,24 +545,24 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args let hv1 := fsi_sreg_get prev a1 in (if Int64.eq n Int64.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int64s c (make_optR0 true is_inv) in + let cond := transl_cbranch_int64s c (make_optR true is_inv) in Some (cond, lhsv) else - let hvs := loadimm64 hv1 n in + let hvs := loadimm64 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64s c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompluimm c n), (a1 :: nil) => let is_inv := is_inv_cmp_int c in let hv1 := fsi_sreg_get prev a1 in (if Int64.eq n Int64.zero then let lhsv := make_lhsv_cmp is_inv hv1 hv1 in - let cond := transl_cbranch_int64u c (make_optR0 true is_inv) in + let cond := transl_cbranch_int64u c (make_optR true is_inv) in Some (cond, lhsv) else - let hvs := loadimm64 hv1 n in + let hvs := loadimm64 n in let lhsv := make_lhsv_cmp is_inv hv1 hvs in - let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in + let cond := transl_cbranch_int64u c (make_optR false is_inv) in Some (cond, lhsv)) | (Ccompf c), (f1 :: f2 :: nil) => let hv1 := fsi_sreg_get prev f1 in @@ -476,9 +591,9 @@ Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args | _, _ => None end. -(** Auxiliary lemmas on comparisons *) +(** * Auxiliary lemmas on comparisons *) -(* Signed ints *) +(** ** Signed ints *) Lemma xor_neg_ltle_cmp: forall v1 v2, Some (Val.xor (Val.cmp Clt v1 v2) (Vint Int.one)) = @@ -493,7 +608,7 @@ Proof. auto. Qed. -(* Unsigned ints *) +(** ** Unsigned ints *) Lemma xor_neg_ltle_cmpu: forall mptr v1 v2, Some (Val.xor (Val.cmpu (Mem.valid_pointer mptr) Clt v1 v2) (Vint Int.one)) = @@ -527,7 +642,7 @@ Proof. rewrite !Int.unsigned_repr; try cbn; try lia. Qed. -(* Signed longs *) +(** ** Signed longs *) Lemma xor_neg_ltle_cmpl: forall v1 v2, Some (Val.xor (Val.maketotal (Val.cmpl Clt v1 v2)) (Vint Int.one)) = @@ -623,7 +738,7 @@ Proof. apply Z.le_ge. trivial. Qed. -(* Unsigned longs *) +(** ** Unsigned longs *) Lemma xor_neg_ltle_cmplu: forall mptr v1 v2, Some (Val.xor (Val.maketotal (Val.cmplu (Mem.valid_pointer mptr) Clt v1 v2)) (Vint Int.one)) = @@ -669,7 +784,7 @@ Proof. repeat destruct (_ && _); simpl; auto. Qed. -(* Floats *) +(** ** Floats *) Lemma xor_neg_eqne_cmpf: forall v1 v2, Some (Val.xor (Val.cmpf Ceq v1 v2) (Vint Int.one)) = @@ -682,7 +797,7 @@ Proof. destruct (Float.cmp _ _ _); simpl; auto. Qed. -(* Singles *) +(** ** Singles *) Lemma xor_neg_eqne_cmpfs: forall v1 v2, Some (Val.xor (Val.cmpfs Ceq v1 v2) (Vint Int.one)) = @@ -695,7 +810,7 @@ Proof. destruct (Float32.cmp _ _ _); simpl; auto. Qed. -(* More useful lemmas *) +(** ** More useful lemmas *) Lemma xor_neg_optb: forall v, Some (Val.xor (Val.of_optbool (option_map negb v)) @@ -738,7 +853,7 @@ Proof. destruct x; destruct y; simpl; auto. rewrite Float32.cmp_swap. auto. Qed. -(* Intermediates lemmas on each expansed instruction *) +(** * Intermediates lemmas on each expanded instruction *) Lemma simplify_ccomp_correct ge sp hst st c r r0 rs0 m0 v v0: forall (SREG: forall r: positive, @@ -842,14 +957,16 @@ Proof. try rewrite OKv1; try rewrite OK2; try rewrite (Int.add_commut _ Int.zero), Int.add_zero_l in H; subst; - try rewrite xor_neg_ltle_cmp; trivial; - unfold Val.cmp, may_undef_int, zero32, Val.add; simpl; + unfold Val.cmp, eval_may_undef, zero32, Val.add; simpl; destruct v; auto. all: try rewrite ltu_12_wordsize; try rewrite <- H; try (apply cmp_ltle_add_one; auto); try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int.add_commut; + try rewrite <- H; try rewrite cmp_ltle_add_one; + try rewrite Int.add_zero_l; try ( simpl; trivial; try rewrite Int.xor_is_zero; @@ -894,14 +1011,15 @@ Proof. try rewrite OKv1; try rewrite OK2; rewrite HMEM; - unfold may_undef_int, Val.cmpu; + unfold eval_may_undef, Val.cmpu; destruct v; simpl; auto; - try rewrite EQIMM; try destruct (Archi.ptr64); simpl; + try rewrite EQIMM; try destruct (Archi.ptr64) eqn:EQARCH; simpl; try rewrite ltu_12_wordsize; trivial; - try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int.add_zero_l; try destruct (Int.ltu _ _) eqn:EQLTU; simpl; - try rewrite EQLTU; simpl; - trivial. + try rewrite EQLTU; simpl; try rewrite EQIMM; + try rewrite EQARCH; trivial. Qed. Lemma simplify_ccompl_correct ge sp hst st c r r0 rs0 m0 v v0: forall @@ -1008,17 +1126,16 @@ Proof. try erewrite !fsi_sreg_get_correct; eauto; try rewrite OKv1; try rewrite OK2; - unfold may_undef_luil; try rewrite (Int64.add_commut _ Int64.zero), Int64.add_zero_l in H; subst; try fold (Val.cmpl Clt v (Vlong imm)); try rewrite xor_neg_ltge_cmpl; trivial; try rewrite xor_neg_ltle_cmpl; trivial; - unfold Val.cmpl, may_undef_luil, Val.addl; + unfold Val.cmpl, Val.addl; try rewrite xorl_zero_eq_cmpl; trivial; try rewrite optbool_mktotal; trivial; - unfold may_undef_int, zero32, Val.add; simpl; + unfold eval_may_undef, zero32, Val.add; simpl; destruct v; auto. - 6,7,8: + 1,2,3,4,5,6,7,8,9,10,11,12: try rewrite <- optbool_mktotal; trivial; try rewrite Int64.add_commut, Int64.add_zero_l in *; try fold (Val.cmpl Clt (Vlong i) (Vlong imm)); @@ -1026,12 +1143,17 @@ Proof. try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo))); try rewrite xor_neg_ltge_cmpl; trivial; try rewrite xor_neg_ltle_cmpl; trivial. + 6: + rewrite <- H; + try apply cmpl_ltle_add_one; auto. all: try rewrite <- H; try apply cmpl_ltle_add_one; auto; + try rewrite <- cmpl_ltle_add_one; auto; try rewrite ltu_12_wordsize; try rewrite Int.add_commut, Int.add_zero_l in *; try rewrite Int64.add_commut, Int64.add_zero_l in *; + try rewrite Int64.add_zero_l; simpl; try rewrite lt_maxsgn_false_long; try (rewrite <- H; trivial; fail); simpl; trivial. @@ -1076,9 +1198,10 @@ Proof. all: try apply xor_neg_ltle_cmplu; trivial. (* Others subcases with swap/negation *) all: - unfold Val.cmplu, may_undef_int, zero64, Val.addl; + unfold Val.cmplu, eval_may_undef, zero64, Val.addl; try apply Int64.same_if_eq in EQLO; subst; try rewrite Int64.add_commut, Int64.add_zero_l in *; trivial; + try rewrite Int64.add_zero_l; try (rewrite <- xor_neg_ltle_cmplu; unfold Val.cmplu; trivial; fail); try (replace (Clt) with (swap_comparison Cgt) by auto; @@ -1198,7 +1321,645 @@ Proof. all: destruct (Float32.cmp _ _ _); trivial. Qed. -(* Main proof of simplification *) +Lemma simplify_floatconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => + Some + (fSop Ofloat_of_bits + (make_lhsv_single (loadimm64 (Float.to_bits n)))) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Ofloatconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm64, load_hilo64; simpl; + specialize make_immed64_sound with (Float.to_bits n); + destruct (make_immed64 (Float.to_bits n)) eqn:EQMKI; intros; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + simpl. + - try rewrite Int64.add_commut, Int64.add_zero_l; inv H; + try rewrite Float.of_to_bits; trivial. + - apply Int64.same_if_eq in EQLO; subst. + try rewrite Int64.add_commut, Int64.add_zero_l in H. + rewrite <- H; try rewrite Float.of_to_bits; trivial. + - rewrite <- H; try rewrite Float.of_to_bits; trivial. + - rewrite <- H; try rewrite Float.of_to_bits; trivial. +Qed. + +Lemma simplify_singleconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => + Some + (fSop Osingle_of_bits + (make_lhsv_single (loadimm32 (Float32.to_bits n)))) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Osingleconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm32, load_hilo32; simpl; + specialize make_immed32_sound with (Float32.to_bits n); + destruct (make_immed32 (Float32.to_bits n)) eqn:EQMKI; intros; + try destruct (Int.eq lo Int.zero) eqn:EQLO; + simpl. + { try rewrite Int.add_commut, Int.add_zero_l; inv H; + try rewrite Float32.of_to_bits; trivial. } + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l in H; simpl; + rewrite ltu_12_wordsize; simpl; try rewrite <- H; + try rewrite Float32.of_to_bits; trivial. +Qed. + +Lemma simplify_addimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (addimm32 (fsi_sreg_get hst a1) n None) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oaddimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold addimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.add (Vint imm) v); rewrite Val.add_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_addlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (addimm64 (fsi_sreg_get hst a1) n None) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oaddlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold addimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.addl (Vlong imm) v); rewrite Val.addl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_andimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (andimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oandimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold andimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.and (Vint imm) v); rewrite Val.and_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_andlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (andimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oandlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold andimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.andl (Vlong imm) v); rewrite Val.andl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_orimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (orimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oorimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold orimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.or (Vint imm) v); rewrite Val.or_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_orlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (orimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oorlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold orimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.orl (Vlong imm) v); rewrite Val.orl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_xorimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (xorimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oxorimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold xorimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.xor (Vint imm) v); rewrite Val.xor_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_xorlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (xorimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oxorlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold xorimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.xorl (Vlong imm) v); rewrite Val.xorl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_intconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => Some (loadimm32 n) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Ointconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm32, load_hilo32, make_lhsv_single; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; try rewrite H; trivial. +Qed. + +Lemma simplify_longconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => Some (loadimm64 n) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Olongconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm64, load_hilo64, make_lhsv_single; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; try rewrite H; trivial. +Qed. + +Lemma simplify_cast8signed_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrimm (Int.repr 24)) + (make_lhsv_single + (fSop (Oshlimm (Int.repr 24)) + (make_lhsv_single (fsi_sreg_get hst a1))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast8signed args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shr, Val.shl, Val.sign_ext; + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + rewrite A. rewrite Int.sign_ext_shr_shl; simpl; trivial. cbn; lia. +Qed. + +Lemma simplify_cast16signed_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrimm (Int.repr 16)) + (make_lhsv_single + (fSop (Oshlimm (Int.repr 16)) + (make_lhsv_single (fsi_sreg_get hst a1))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast16signed args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shr, Val.shl, Val.sign_ext; + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + rewrite A. rewrite Int.sign_ext_shr_shl; simpl; trivial. cbn; lia. +Qed. + +Lemma simplify_shrximm_correct ge sp rs0 m0 lr hst fsv st args m n: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + if Int.eq n Int.zero + then + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fsi_sreg_get hst a1))) + else + if Int.eq n Int.one + then + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))) + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))) + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oshrximm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence). + assert (A: Int.ltu Int.zero (Int.repr 31) = true) by auto. + assert (B: Int.ltu (Int.repr 31) Int.iwordsize = true) by auto. + assert (C: Int.ltu Int.one Int.iwordsize = true) by auto. + destruct (Int.eq n Int.zero) eqn:EQ0; + destruct (Int.eq n Int.one) eqn:EQ1. + { apply Int.same_if_eq in EQ0. + apply Int.same_if_eq in EQ1; subst. discriminate. } + all: + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; + destruct (Val.shrx v (Vint n)) eqn:TOTAL; cbn; + unfold eval_may_undef. + 2,4,6: + unfold Val.shrx in TOTAL; + destruct v; simpl in TOTAL; simpl; try congruence; + try rewrite B; simpl; try rewrite C; simpl; + try destruct (Val.shr _ _); + destruct (Int.ltu n (Int.repr 31)); try congruence. + - destruct v; simpl in TOTAL; try congruence; + apply Int.same_if_eq in EQ0; subst; + rewrite A, Int.shrx_zero in TOTAL; + [auto | cbn; lia]. + - apply Int.same_if_eq in EQ1; subst; + unfold Val.shr, Val.shru, Val.shrx, Val.add; simpl; + destruct v; simpl in *; try discriminate; trivial. + rewrite B, C. + rewrite Int.shrx1_shr in TOTAL; auto. + - exploit Val.shrx_shr_2; eauto. rewrite EQ0. + intros; subst. + destruct v; simpl in *; try discriminate; trivial. + rewrite B in *. + destruct Int.ltu eqn:EQN0 in TOTAL; try discriminate. + simpl in *. + destruct Int.ltu eqn:EQN1 in TOTAL; try discriminate. + replace Int.iwordsize with (Int.repr 32) in * by auto. + rewrite !EQN1. simpl in *. + destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. + rewrite !EQN2. rewrite EQN0. + reflexivity. +Qed. + +Lemma simplify_shrxlimm_correct ge sp rs0 m0 lr hst fsv st args m n: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + if Int.eq n Int.zero + then + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fsi_sreg_get hst a1))) + else + if Int.eq n Int.one + then + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))) + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))) + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oshrxlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence). + assert (A: Int.ltu Int.zero (Int.repr 63) = true) by auto. + assert (B: Int.ltu (Int.repr 63) Int64.iwordsize' = true) by auto. + assert (C: Int.ltu Int.one Int64.iwordsize' = true) by auto. + destruct (Int.eq n Int.zero) eqn:EQ0; + destruct (Int.eq n Int.one) eqn:EQ1. + { apply Int.same_if_eq in EQ0. + apply Int.same_if_eq in EQ1; subst. discriminate. } + all: + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; + destruct (Val.shrxl v (Vint n)) eqn:TOTAL; cbn; + unfold eval_may_undef. + 2,4,6: + unfold Val.shrxl in TOTAL; + destruct v; simpl in TOTAL; simpl; try congruence; + try rewrite B; simpl; try rewrite C; simpl; + try destruct (Val.shrl _ _); + destruct (Int.ltu n (Int.repr 63)); try congruence. + - destruct v; simpl in TOTAL; try congruence; + apply Int.same_if_eq in EQ0; subst; + rewrite A, Int64.shrx'_zero in *. + assumption. + - apply Int.same_if_eq in EQ1; subst; + unfold Val.shrl, Val.shrlu, Val.shrxl, Val.addl; simpl; + destruct v; simpl in *; try discriminate; trivial. + rewrite B, C. + rewrite Int64.shrx'1_shr' in TOTAL; auto. + - exploit Val.shrxl_shrl_2; eauto. rewrite EQ0. + intros; subst. + destruct v; simpl in *; try discriminate; trivial. + rewrite B in *. + destruct Int.ltu eqn:EQN0 in TOTAL; try discriminate. + simpl in *. + destruct Int.ltu eqn:EQN1 in TOTAL; try discriminate. + replace Int64.iwordsize' with (Int.repr 64) in * by auto. + rewrite !EQN1. simpl in *. + destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. + rewrite !EQN2. rewrite EQN0. + reflexivity. +Qed. + +Lemma simplify_cast32unsigned_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrluimm (Int.repr 32)) + (make_lhsv_single + (fSop (Oshllimm (Int.repr 32)) + (make_lhsv_single + (fSop Ocast32signed + (make_lhsv_single (fsi_sreg_get hst a1))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast32unsigned args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shrlu, Val.shll, Val.longofint, Val.longofintu. + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A. rewrite Int64.shru'_shl'; auto. + replace (Int.ltu (Int.repr 32) (Int.repr 32)) with (false) by auto. + rewrite cast32unsigned_from_cast32signed. + replace Int64.zwordsize with 64 by auto. + rewrite Int.unsigned_repr; cbn; try lia. + replace (Int.sub (Int.repr 32) (Int.repr 32)) with (Int.zero) by auto. + rewrite Int64.shru'_zero. reflexivity. +Qed. + +(** * Main proof of simplification *) Lemma target_op_simplify_correct op lr hst fsv ge sp rs0 m0 st args m: forall (H: target_op_simplify op lr hst = Some fsv) @@ -1211,34 +1972,40 @@ Proof. unfold target_op_simplify; simpl. intros H (LREF & SREF & SREG & SMEM) ? ? ?. destruct op; try congruence. + eapply simplify_intconst_correct; eauto. + eapply simplify_longconst_correct; eauto. + eapply simplify_floatconst_correct; eauto. + eapply simplify_singleconst_correct; eauto. + eapply simplify_cast8signed_correct; eauto. + eapply simplify_cast16signed_correct; eauto. + eapply simplify_addimm_correct; eauto. + eapply simplify_andimm_correct; eauto. + eapply simplify_orimm_correct; eauto. + eapply simplify_xorimm_correct; eauto. + eapply simplify_shrximm_correct; eauto. + eapply simplify_cast32unsigned_correct; eauto. + eapply simplify_addlimm_correct; eauto. + eapply simplify_andlimm_correct; eauto. + eapply simplify_orlimm_correct; eauto. + eapply simplify_xorlimm_correct; eauto. + eapply simplify_shrxlimm_correct; eauto. + (* Ocmp expansions *) destruct cond; repeat (destruct lr; simpl; try congruence); simpl in OK1; try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); inv H; inv OK1. - (* Ccomp *) - eapply simplify_ccomp_correct; eauto. - (* Ccompu *) - eapply simplify_ccompu_correct; eauto. - (* Ccompimm *) - eapply simplify_ccompimm_correct; eauto. - (* Ccompuimm *) - eapply simplify_ccompuimm_correct; eauto. - (* Ccompl *) - eapply simplify_ccompl_correct; eauto. - (* Ccomplu *) - eapply simplify_ccomplu_correct; eauto. - (* Ccomplimm *) - eapply simplify_ccomplimm_correct; eauto. - (* Ccompluimm *) - eapply simplify_ccompluimm_correct; eauto. - (* Ccompf *) - eapply simplify_ccompf_correct; eauto. - (* Cnotcompf *) - eapply simplify_cnotcompf_correct; eauto. - (* Ccompfs *) - eapply simplify_ccompfs_correct; eauto. - (* Cnotcompfs *) - eapply simplify_cnotcompfs_correct; eauto. Qed. @@ -1286,13 +2053,15 @@ Proof. try destruct (Int64.eq lo Int64.zero) eqn:EQLO; try apply Int.same_if_eq in EQLO; simpl; trivial; try apply Int64.same_if_eq in EQLO; simpl; trivial; - unfold may_undef_int, may_undef_luil; + unfold eval_may_undef; try erewrite !fsi_sreg_get_correct; eauto; try rewrite OKv1; simpl; trivial; try destruct v; try rewrite H; try rewrite ltu_12_wordsize; try rewrite EQLO; try rewrite Int.add_commut, Int.add_zero_l; try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite Int.add_zero_l; try rewrite Int64.add_zero_l; auto; simpl; try rewrite H in EQIMM; try rewrite EQLO in EQIMM; diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index ca0834db..e0314c6a 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -19,30 +19,38 @@ Require Import Zbits Lia. Definition zero32 := (I Int.zero). Definition zero64 := (L Int64.zero). - -Definition apply_bin_r0 {B} (optR0: option bool) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := - match optR0 with + +(** Functions to select a special register (see Op.v) *) + +Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := + match optR with | None => sem v1 v2 - | Some true => sem vz v1 - | Some false => sem v1 vz + | Some X0_L => sem vz v1 + | Some X0_R => sem v1 vz end. -Definition may_undef_int (is_long: bool) (sem: aval -> aval -> aval) (v1 vimm vz: aval): aval := - if negb is_long then - match v1 with - | I _ => sem vimm vz - | _ => Ifptr Ptop - end - else - match v1 with - | L _ => sem vimm vz - | _ => Ifptr Ptop - end. - -Definition may_undef_luil (v1: aval) (n: int64): aval := - match v1 with - | L _ => sign_ext 32 (shll (L n) (L (Int64.repr 12))) - | _ => Ifptr Ptop +Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := + match mu with + | MUint => match v1, v2 with + | I _, I _ => v2 + | _, _ => Ifptr Ptop + end + | MUlong => match v1, v2 with + | L _, I _ => v2 + | _, _ => Ifptr Ptop + end + | MUshrx i => + match v1, v2 with + | I _, I _ => + if Int.ltu i (Int.repr 31) then v2 else Ifptr Ptop + | _, _ => Ifptr Ptop + end + | MUshrxl i => + match v1, v2 with + | L _, L _ => + if Int.ltu i (Int.repr 63) then v2 else Ifptr Ptop + | _, _ => Ifptr Ptop + end end. Definition eval_static_condition (cond: condition) (vl: list aval): abool := @@ -59,22 +67,22 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) - | CEbeqw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32 - | CEbnew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32 - | CEbequw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32 - | CEbneuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Cne) v1 v2 zero32 - | CEbltw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Clt) v1 v2 zero32 - | CEbltuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Clt) v1 v2 zero32 - | CEbgew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Cge) v1 v2 zero32 - | CEbgeuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Cge) v1 v2 zero32 - | CEbeql optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64 - | CEbnel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64 - | CEbequl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64 - | CEbneul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Cne) v1 v2 zero64 - | CEbltl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Clt) v1 v2 zero64 - | CEbltul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64 - | CEbgel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Cge) v1 v2 zero64 - | CEbgeul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Cge) v1 v2 zero64 + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 | _, _ => Bnone end. @@ -214,29 +222,36 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | OEseqw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32) - | OEsnew optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32) - | OEsequw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32) - | OEsneuw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Cne) v1 v2 zero32) - | OEsltw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Clt) v1 v2 zero32) - | OEsltuw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Clt) v1 v2 zero32) + | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32) | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) | OExoriw n, v1::nil => xor v1 (I n) - | OEluiw n is_long, v1::nil => may_undef_int is_long shl v1 (I n) (I (Int.repr 12)) - | OEaddiwr0 n is_long, v1::nil => may_undef_int is_long add v1 (I n) zero32 - | OEseql optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64) - | OEsnel optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64) - | OEsequl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64) - | OEsneul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Cne) v1 v2 zero64) - | OEsltl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Clt) v1 v2 zero64) - | OEsltul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64) + | OEluiw n, nil => shl (I n) (I (Int.repr 12)) + | OEaddiw optR n, nil => apply_bin_oreg optR add (I n) (Ifptr Ptop) zero32 + | OEaddiw optR n, v1::nil => apply_bin_oreg optR add v1 (I n) (Ifptr Ptop) + | OEandiw n, v1::nil => and (I n) v1 + | OEoriw n, v1::nil => or (I n) v1 + | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64) + | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64) + | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64) + | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64) + | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64) + | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64) | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) + | OEandil n, v1::nil => andl (L n) v1 + | OEoril n, v1::nil => orl (L n) v1 | OExoril n, v1::nil => xorl v1 (L n) - | OEluil n, v1::nil => may_undef_luil v1 n - | OEaddilr0 n, v1::nil => may_undef_int true addl v1 (L n) zero64 + | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) + | OEaddil optR n, nil => apply_bin_oreg optR addl (L n) (Ifptr Ptop) zero64 + | OEaddil optR n, v1::nil => apply_bin_oreg optR addl v1 (L n) (Ifptr Ptop) | OEloadli n, nil => L (n) + | OEmayundef mu, v1 :: v2 :: nil => eval_may_undef mu v1 v2 | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) | OEfltd, v1::v2::nil => of_optbool (cmpf_bool Clt v1 v2) | OEfled, v1::v2::nil => of_optbool (cmpf_bool Cle v1 v2) @@ -340,7 +355,7 @@ Proof. inv H2. destruct cond; simpl; eauto with va. 17: destruct cond; simpl; eauto with va. - all: destruct optR0 as [[]|]; unfold apply_bin_r0, Op.apply_bin_r0; + all: destruct optR as [[]|]; unfold apply_bin_oreg, Op.apply_bin_oreg; unfold zero32, Op.zero32, zero64, Op.zero64; eauto with va. Qed. @@ -397,53 +412,53 @@ Proof. inv H; auto. simpl. destruct b; constructor. Qed. -Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR0 m, +Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR m, c = Ceq \/ c = Cne \/ c = Clt-> vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) - (of_optbool (apply_bin_r0 optR0 (cmpu_bool c) b1 b0 zero32)). + vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. Qed. -Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR0 m, +Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR m, c = Ceq \/ c = Cne \/ c = Clt-> vmatch bc a1 b1 -> vmatch bc a0 b0 -> vmatch bc (Val.maketotal - (Op.apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) c) a1 a0 + (Op.apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) c) a1 a0 Op.zero64)) - (of_optbool (apply_bin_r0 optR0 (cmplu_bool c) b1 b0 zero64)). + (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. Qed. -Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR0 cmp, +Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> - vmatch bc (Op.apply_bin_r0 optR0 (Val.cmp cmp) a1 a0 Op.zero32) - (of_optbool (apply_bin_r0 optR0 (cmp_bool cmp) b1 b0 zero32)). + vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. Qed. -Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR0 cmp, +Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR cmp, vmatch bc a1 b1 -> vmatch bc a0 b0 -> vmatch bc - (Val.maketotal (Op.apply_bin_r0 optR0 (Val.cmpl cmp) a1 a0 Op.zero64)) - (of_optbool (apply_bin_r0 optR0 (cmpl_bool cmp) b1 b0 zero64)). + (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64)) + (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64)). Proof. intros. - destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. Qed. @@ -459,24 +474,38 @@ Proof. destruct (propagate_float_constants tt); constructor. rewrite Ptrofs.add_zero_l; eauto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. - + 3,4,6: apply eval_cmpu_sound; auto. 1,2,3: apply eval_cmp_sound; auto. unfold Val.cmp; apply of_optbool_sound; eauto with va. unfold Val.cmpu; apply of_optbool_sound; eauto with va. - unfold zero32; simpl; eauto with va. - - 1,2,11,12: - try unfold Op.may_undef_int, may_undef_int, Op.zero32, zero32, Op.zero64, zero64; - try unfold Op.may_undef_luil, may_undef_luil; simpl; unfold ntop1; - inv H1; try destruct is_long; simpl; try destruct (Int.ltu _ _); eauto with va; - try apply vmatch_ifptr_i; try apply vmatch_ifptr_l. - - 3,4,6: apply eval_cmplu_sound; auto. - 1,2,3: apply eval_cmpl_sound; auto. - unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. - unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. - unfold zero64; simpl; eauto with va. + + { destruct optR as [[]|]; simpl; eauto with va. } + { destruct optR as [[]|]; + unfold apply_bin_oreg, Op.apply_bin_oreg; eauto with va. } + { fold (Val.and (Vint n) a1); eauto with va. } + { fold (Val.or (Vint n) a1); eauto with va. } + { simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; + try apply vmatch_ifptr_undef. } + 9: { destruct optR as [[]|]; simpl; eauto with va. } + 9: { destruct optR as [[]|]; + unfold apply_bin_oreg, Op.apply_bin_oreg; eauto with va. } + 9: { fold (Val.andl (Vlong n) a1); eauto with va. } + 9: { fold (Val.orl (Vlong n) a1); eauto with va. } + 9: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; + apply vmatch_ifptr_l. } + + 1,10: simpl; eauto with va. + 10: + unfold Op.eval_may_undef, eval_may_undef; destruct mu; + inv H1; inv H0; eauto with va; + try destruct (Int.ltu _ _); simpl; + try eapply vmatch_ifptr_p, pmatch_top'; eauto with va. + + 4,5,7: apply eval_cmplu_sound; auto. + 1,3,4: apply eval_cmpl_sound; auto. + 2: { unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. } + 2: { unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. } all: unfold Val.cmpf; apply of_optbool_sound; eauto with va. Qed. diff --git a/scheduling/RTLpath.v b/scheduling/RTLpath.v index 0f303597..a4fce97e 100644 --- a/scheduling/RTLpath.v +++ b/scheduling/RTLpath.v @@ -28,8 +28,6 @@ Require Import Op Registers. Require Import RTL Linking. Require Import Lia. -Declare Scope option_monad_scope. - Notation "'SOME' X <- A 'IN' B" := (match A with Some X => B | None => None end) (at level 200, X ident, A at level 100, B at level 200) : option_monad_scope. diff --git a/scheduling/RTLpathLivegenaux.ml b/scheduling/RTLpathLivegenaux.ml index 9b93bc32..2a20a15d 100644 --- a/scheduling/RTLpathLivegenaux.ml +++ b/scheduling/RTLpathLivegenaux.ml @@ -82,13 +82,15 @@ let get_path_map code entry join_points = let visited = ref (PTree.map (fun n i -> false) code) in let path_map = ref PTree.empty in let rec dig_path e = - let psize = ref (-1) in - let path_successors = ref [] in - let rec dig_path_rec n : (path_info * node list) option = - if not (get_some @@ PTree.get n !visited) then + if (get_some @@ PTree.get e !visited) then + () + else begin + visited := PTree.set e true !visited; + let psize = ref (-1) in + let path_successors = ref [] in + let rec dig_path_rec n : (path_info * node list) option = let inst = get_some @@ PTree.get n code in begin - visited := PTree.set n true !visited; psize := !psize + 1; let successor = match predicted_successor inst with | None -> None @@ -102,15 +104,15 @@ let get_path_map code entry join_points = input_regs = Regset.empty; pre_output_regs = Regset.empty; output_regs = Regset.empty }, !path_successors @ successors_inst inst) end - else None - in match dig_path_rec e with - | None -> () - | Some ret -> - let (path_info, succs) = ret in - begin - path_map := PTree.set e path_info !path_map; - List.iter dig_path succs - end + in match dig_path_rec e with + | None -> () + | Some ret -> + let (path_info, succs) = ret in + begin + path_map := PTree.set e path_info !path_map; + List.iter dig_path succs + end + end in begin dig_path entry; !path_map diff --git a/scheduling/RTLpathSE_impl.v b/scheduling/RTLpathSE_impl.v index 12aba56b..e21d7cd1 100644 --- a/scheduling/RTLpathSE_impl.v +++ b/scheduling/RTLpathSE_impl.v @@ -819,7 +819,7 @@ Proof. rewrite <- X, sok_local_set_sreg. intuition eauto. - destruct REF; intuition eauto. - generalize REF; intros (OKEQ & _). rewrite OKEQ in * |-; erewrite red_PTree_set_refines; eauto. - Qed. +Qed. Global Opaque hslocal_set_sreg. Local Hint Resolve hslocal_set_sreg_correct: wlp. diff --git a/scheduling/RTLpathSE_simu_specs.v b/scheduling/RTLpathSE_simu_specs.v index 21f89f90..5051d805 100644 --- a/scheduling/RTLpathSE_simu_specs.v +++ b/scheduling/RTLpathSE_simu_specs.v @@ -106,13 +106,12 @@ with hsmem_proj hm := | HSstore hm chk addr hl hv _ => Sstore (hsmem_proj hm) chk addr (hsval_list_proj hl) (hsval_proj hv) end. -Declare Scope hse. -Local Open Scope hse. - - (** We use a Notation instead a Definition, in order to get more automation "for free" *) Notation "'seval_hsval' ge sp hsv" := (seval_sval ge sp (hsval_proj hsv)) (only parsing, at level 0, ge at next level, sp at next level, hsv at next level): hse. + +Local Open Scope hse. + Notation "'seval_list_hsval' ge sp lhv" := (seval_list_sval ge sp (hsval_list_proj lhv)) (only parsing, at level 0, ge at next level, sp at next level, lhv at next level): hse. Notation "'seval_hsmem' ge sp hsm" := (seval_smem ge sp (hsmem_proj hsm)) @@ -310,7 +309,6 @@ End HFINAL_REFINES. Section FAKE_HSVAL. (* BEGIN "fake" hsval without real hash-consing *) (* TODO: - 1) put these definitions elsewhere ? in RTLpathSE_simu_specs.v ? 2) reuse these definitions in hSinput, hSop, etc in order to factorize proofs ? *) diff --git a/scheduling/RTLpathScheduler.v b/scheduling/RTLpathScheduler.v index 1baf3fca..31680256 100644 --- a/scheduling/RTLpathScheduler.v +++ b/scheduling/RTLpathScheduler.v @@ -180,7 +180,7 @@ Proof. apply H in EQ2. rewrite EQ2. simpl. repeat (constructor; eauto). exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. -Qed. +Qed. Record match_function (dupmap: PTree.t node) (f1 f2: RTLpath.function): Prop := { preserv_fnsig: fn_sig f1 = fn_sig f2; diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml index 378bf097..aeed39df 100644 --- a/scheduling/RTLpathScheduleraux.ml +++ b/scheduling/RTLpathScheduleraux.ml @@ -284,9 +284,7 @@ let rec do_schedule code pm = function | [] -> (code, pm) | sb :: lsb -> (*debug_flag := true;*) - let (code_exp, pm) = - if !Clflags.option_fexpanse_rtlcond then (expanse sb code pm) - else (code, pm) in + let (code_exp, pm) = expanse sb code pm in (*debug_flag := false;*) (* Trick: instead of turning loads into non trap as needed.. * First, we turn them all into non-trap. @@ -298,12 +296,12 @@ let rec do_schedule code pm = function let new_code = apply_schedule code' sb schedule in begin (*debug_flag := true;*) + if code != code_exp then ( debug "Old Code: "; print_code code; - debug "Exp Code: "; print_code code_exp; + debug "Exp Code: "; print_code code_exp); debug "\nSchedule to apply: "; print_arrayp schedule; debug "\nNew Code: "; print_code new_code; debug "\n"; - (*debug_flag := false; *) do_schedule new_code pm lsb end @@ -321,7 +319,6 @@ let scheduler f = debug "Pathmap:\n"; debug "\n"; print_path_map pm; debug "Superblocks:\n"; - (*debug_flag := true; *) (*print_code code; flush stdout; flush stderr;*) (*debug_flag := false;*) (*print_superblocks lsb code; debug "\n";*) diff --git a/scheduling/abstractbb/AbstractBasicBlocksDef.v b/scheduling/abstractbb/AbstractBasicBlocksDef.v index 34d72de1..fec716c4 100644 --- a/scheduling/abstractbb/AbstractBasicBlocksDef.v +++ b/scheduling/abstractbb/AbstractBasicBlocksDef.v @@ -273,8 +273,6 @@ with list_term := Scheme term_mut := Induction for term Sort Prop with list_term_mut := Induction for list_term Sort Prop. -Declare Scope pattern_scope. -Declare Scope term_scope. Bind Scope pattern_scope with term. Delimit Scope term_scope with term. Delimit Scope pattern_scope with pattern. diff --git a/test/aarch64/README.md b/test/aarch64/README.md deleted file mode 100644 index f943489c..00000000 --- a/test/aarch64/README.md +++ /dev/null @@ -1,15 +0,0 @@ -# Testing the Machblock --> Asmblock translation -1. Get the reference version of compcert-aarch in the father's directory if this repo (checkout `aarch64-ref`) -2. Compile both repo for aarch64 -3. CD in this folder (`test/aarch64`) -4. Launch `./asmb_aarch64_gen_test.sh` - -## Options -The script takes following options : -- `-c` to clear generated files at the end -- `-w` to suppress warnings from Compcert - -## Tests files -The variable `DIRS` in the script takes the list of directories containing c files. -The tests under `test/aarch64/c` are simpler and useful to debug only one feature at a time. -Most of them comes from [here](https://cis.temple.edu/~ingargio/cis71/code/). diff --git a/test/aarch64/gen_tests/asmb_aarch64_gen_test.sh b/test/aarch64/gen_tests/asmb_aarch64_gen_test.sh deleted file mode 100755 index 38235f14..00000000 --- a/test/aarch64/gen_tests/asmb_aarch64_gen_test.sh +++ /dev/null @@ -1,106 +0,0 @@ -#!/bin/bash - -CLEAN=0 -WOFF=0 -while getopts ':cw' 'OPTKEY'; do - case ${OPTKEY} in - c) CLEAN=1;; - w) WOFF=1;; - esac -done - -DIRS=( - ../c/*.c # Special simple tests - #../../c/*.c - ../../clightgen/*.c - #../../compression/*.c - ../../cse2/*.c - - # Monniaux test directory - ../../monniaux/binary_search/*.c - ../../monniaux/complex/*.c - #../../monniaux/crypto-algorithms/*.c # Warnings - ../../monniaux/cse2/*.c - #../../monniaux/des/*.c # Unsupported feature? - ../../monniaux/expect/*.c - ../../monniaux/fill_buffer/*.c - ../../monniaux/genann/*.c - #../../monniaux/heptagon_radio_transmitter/*.c # Warnings - ../../monniaux/idea/*.c - ../../monniaux/jumptable/*.c - ../../monniaux/licm/*.c - ../../monniaux/longjmp/*.c - ../../monniaux/loop/*.c - ../../monniaux/lustrev4_lustrec_heater_control/*.c - ../../monniaux/lustrev4_lv4_heater_control/*.c - ../../monniaux/lustrev4_lv6-en-2cgc_heater_control/*.c - #../../monniaux/lustrev6-carlightV2/*.c # Warnings - #../../monniaux/lustrev6-convertible-2cgc/*.c # Unsupported feature? - #../../monniaux/lustrev6-convertible-en-2cgc/*.c - #../../monniaux/lustrev6-convertible/*.c # Warnings - ../../monniaux/madd/*.c - #../../monniaux/math/*.c # Unsupported feature? - ../../monniaux/memcpy/*.c - #../../monniaux/micro-bunzip/*.c # Warnings - ../../monniaux/moves/*.c - ../../monniaux/multithreaded_volatile/*.c - ../../monniaux/nand/*.c - #../../monniaux/ncompress/*.c # Warnings - ../../monniaux/number_theoretic_transform/*.c - ../../monniaux/predicated/*.c - ../../monniaux/regalloc/*.c - ../../monniaux/rotate/*.c - ../../monniaux/scheduling/*.c - ../../monniaux/send_through/*.c - ../../monniaux/tiny-AES-c/*.c - ../../monniaux/varargs/*.c - ../../monniaux/xor_and_mat/*.c - #../../monniaux/zlib-1.2.11/*.c # Warnings -) -#FILES=../c/*.c -CCOMP_BBLOCKS="../../../ccomp -fno-postpass" -CCOMP_REF="../../../../CompCert_kvx/ccomp" -COUNT=0 - -if [ $WOFF -eq 1 ] -then - CCOMP_BBLOCKS="${CCOMP_BBLOCKS} -w" - CCOMP_REF="${CCOMP_REF} -w" -fi - -for files in ${DIRS[@]} -do - for f in $files - do - BNAME=$(basename -s .c $f) - SNAME="$BNAME".s - SREFNAME="$BNAME"_ref.s - ./$CCOMP_BBLOCKS -S $f -o $SNAME - ./$CCOMP_REF -dmach -S $f -o $SREFNAME - #diff -I '^//*' <(cut -c-5 $SNAME) <(cut -c-5 $SREFNAME) > /dev/null 2>&1 - diff -I '^//*' $SNAME $SREFNAME > /dev/null 2>&1 - - error=$? - if [ $error -eq 0 ] - then - echo "[$BNAME] OK" - COUNT=$((COUNT + 1)) - elif [ $error -eq 1 ] - then - echo "[$BNAME] FAIL" - diff -I '^//*' -y $SNAME $SREFNAME - exit 1 - else - echo "[$BNAME] FAIL" - echo "[WARNING] There was something wrong with the diff command !" - exit 1 - fi - done -done - -echo "[TOTAL] $COUNT tests PASSED" - -if [ $CLEAN -eq 1 ] -then - rm *.s *.mach -fi diff --git a/test/aarch64/postpass_tests/postpass_exec_c_test.sh b/test/aarch64/postpass_tests/postpass_exec_c_test.sh deleted file mode 100755 index 73422990..00000000 --- a/test/aarch64/postpass_tests/postpass_exec_c_test.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/bash - -CLEAN=0 -WOFF=0 -SRC="" -while getopts ':cwi:' 'OPTKEY'; do - case ${OPTKEY} in - c) CLEAN=1;; - w) WOFF=1;; - i) SRC=${OPTARG};; - esac -done - -CCOMP="../../../ccomp -static" - -if [ $WOFF -eq 1 ] -then - CCOMP="${CCOMP} -w" -fi - -BNAME=$(basename -s .c $SRC) -SNAME="$BNAME".s -SREFNAME="$BNAME"_ref.s -ENAME="$BNAME" -EREFNAME="$BNAME"_ref -./$CCOMP -S $SRC -o $SNAME -./$CCOMP -fno-postpass -S $SRC -o $SREFNAME -./$CCOMP $SRC -o $ENAME -./$CCOMP -fno-postpass $SRC -o $EREFNAME - -#diff -I '^//*' -y $SNAME $SREFNAME - -if [ $CLEAN -eq 1 ] -then - rm $SNAME $SREFNAME $ENAME $EREFNAME -fi diff --git a/test/aarch64/c/add_return.c b/test/gourdinl/c/add_return.c index c29aeb16..c29aeb16 100644 --- a/test/aarch64/c/add_return.c +++ b/test/gourdinl/c/add_return.c diff --git a/test/aarch64/c/addresses.c b/test/gourdinl/c/addresses.c index e3cb5201..e3cb5201 100644 --- a/test/aarch64/c/addresses.c +++ b/test/gourdinl/c/addresses.c diff --git a/test/aarch64/c/arith.c b/test/gourdinl/c/arith.c index 02df141b..02df141b 100644 --- a/test/aarch64/c/arith.c +++ b/test/gourdinl/c/arith.c diff --git a/test/aarch64/c/arith_print.c b/test/gourdinl/c/arith_print.c index d404a151..d404a151 100644 --- a/test/aarch64/c/arith_print.c +++ b/test/gourdinl/c/arith_print.c diff --git a/test/aarch64/c/armstrong.c b/test/gourdinl/c/armstrong.c index c5d838f9..c5d838f9 100644 --- a/test/aarch64/c/armstrong.c +++ b/test/gourdinl/c/armstrong.c diff --git a/test/aarch64/c/array1.c b/test/gourdinl/c/array1.c index 5840ca66..5840ca66 100644 --- a/test/aarch64/c/array1.c +++ b/test/gourdinl/c/array1.c diff --git a/test/aarch64/c/array2.c b/test/gourdinl/c/array2.c index 389e1596..389e1596 100644 --- a/test/aarch64/c/array2.c +++ b/test/gourdinl/c/array2.c diff --git a/test/aarch64/c/biggest_of_3_int.c b/test/gourdinl/c/biggest_of_3_int.c index 346908fc..346908fc 100644 --- a/test/aarch64/c/biggest_of_3_int.c +++ b/test/gourdinl/c/biggest_of_3_int.c diff --git a/test/aarch64/c/bitwise1.c b/test/gourdinl/c/bitwise1.c index d20641de..d20641de 100644 --- a/test/aarch64/c/bitwise1.c +++ b/test/gourdinl/c/bitwise1.c diff --git a/test/aarch64/c/cpintarray.c b/test/gourdinl/c/cpintarray.c index 8049fdfb..8049fdfb 100644 --- a/test/aarch64/c/cpintarray.c +++ b/test/gourdinl/c/cpintarray.c diff --git a/test/aarch64/c/enum1.c b/test/gourdinl/c/enum1.c index d1f6b48d..d1f6b48d 100644 --- a/test/aarch64/c/enum1.c +++ b/test/gourdinl/c/enum1.c diff --git a/test/aarch64/c/enum2.c b/test/gourdinl/c/enum2.c index a18acb80..a18acb80 100644 --- a/test/aarch64/c/enum2.c +++ b/test/gourdinl/c/enum2.c diff --git a/test/aarch64/c/floop.c b/test/gourdinl/c/floop.c index 30270892..30270892 100644 --- a/test/aarch64/c/floop.c +++ b/test/gourdinl/c/floop.c diff --git a/test/aarch64/c/floor.c b/test/gourdinl/c/floor.c index 33a57af3..33a57af3 100644 --- a/test/aarch64/c/floor.c +++ b/test/gourdinl/c/floor.c diff --git a/test/aarch64/c/funcs.c b/test/gourdinl/c/funcs.c index 49e610d6..49e610d6 100644 --- a/test/aarch64/c/funcs.c +++ b/test/gourdinl/c/funcs.c diff --git a/test/aarch64/c/hello.c b/test/gourdinl/c/hello.c index 0279269e..0279269e 100644 --- a/test/aarch64/c/hello.c +++ b/test/gourdinl/c/hello.c diff --git a/test/aarch64/c/if.c b/test/gourdinl/c/if.c index 7d2e249a..7d2e249a 100644 --- a/test/aarch64/c/if.c +++ b/test/gourdinl/c/if.c diff --git a/test/aarch64/c/msb_pos.c b/test/gourdinl/c/msb_pos.c index f2e7fe09..f2e7fe09 100644 --- a/test/aarch64/c/msb_pos.c +++ b/test/gourdinl/c/msb_pos.c diff --git a/test/aarch64/c/power2.c b/test/gourdinl/c/power2.c index 64707df9..64707df9 100644 --- a/test/aarch64/c/power2.c +++ b/test/gourdinl/c/power2.c diff --git a/test/aarch64/c/prime.c b/test/gourdinl/c/prime.c index 6c51db32..6c51db32 100644 --- a/test/aarch64/c/prime.c +++ b/test/gourdinl/c/prime.c diff --git a/test/aarch64/c/random.c b/test/gourdinl/c/random.c index 50aa5737..50aa5737 100644 --- a/test/aarch64/c/random.c +++ b/test/gourdinl/c/random.c diff --git a/test/aarch64/c/simple_op.c b/test/gourdinl/c/simple_op.c index 7c43b081..7c43b081 100644 --- a/test/aarch64/c/simple_op.c +++ b/test/gourdinl/c/simple_op.c diff --git a/test/aarch64/c/wloop.c b/test/gourdinl/c/wloop.c index 5ba67419..5ba67419 100644 --- a/test/aarch64/c/wloop.c +++ b/test/gourdinl/c/wloop.c diff --git a/test/gourdinl/clause.h b/test/gourdinl/clause.h new file mode 100644 index 00000000..3eb44402 --- /dev/null +++ b/test/gourdinl/clause.h @@ -0,0 +1,12 @@ +typedef struct { + int b; + int a; +} * CLAUSE; +__inline__ int g(CLAUSE c) { return c->b; } +__inline__ int d(CLAUSE c) { return c->a; } +__inline__ void clause_SetNumOfConsLits(CLAUSE c, int e) { + c->b = e; + c->a = e; +} +__inline__ int f(CLAUSE c) { return g(c) + d(c); } +__inline__ int clause_LastLitIndex(c) { return f(c); } diff --git a/test/gourdinl/clause2.c b/test/gourdinl/clause2.c new file mode 100644 index 00000000..42cd0fa6 --- /dev/null +++ b/test/gourdinl/clause2.c @@ -0,0 +1,23 @@ +#include "clause.h" +int a, b; +void c(); +void h() { + int f = clause_LastLitIndex(d); + a = clause_LastLitIndex(0); + if (f) + if (a) + 1; +} +void i() { + CLAUSE e = 0; + int *g[] = {h, c}; + for (; b;) + l(e); +} +void m() { + int k, j; + for (; k <= 0;) + ; + clause_SetNumOfConsLits(0, j); + n(0 - j); +} diff --git a/test/gourdinl/cond_exp_mini_cse.c b/test/gourdinl/cond_exp_mini_cse.c new file mode 100644 index 00000000..3a2ce9c3 --- /dev/null +++ b/test/gourdinl/cond_exp_mini_cse.c @@ -0,0 +1,6 @@ +int main(int x, int y, int* t) { + if (x + *t < 7) + if (y < 7) + return 421; + return 0; +} diff --git a/test/gourdinl/cscript.sh b/test/gourdinl/cscript.sh new file mode 100755 index 00000000..8bf3a613 --- /dev/null +++ b/test/gourdinl/cscript.sh @@ -0,0 +1,20 @@ +#!/bin/bash + +/home/yuki/Work/VERIMAG/Compcert_neutral/ccomp -stdlib ../../runtime -dparse -dclight -S -fstruct-return -c clause2.c > log 2>&1 + +b1=$(cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr64") +sb1=$? +b2=$(cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32") +sb2=$? +b3=$(cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str32") +sb3=$? +b4=$(cat log | ack "STP_CONSEC_PEEP_IMM_INC_str64") +sb4=$? + +#if [ "$sb1" == 0 ] && [ "$sb2" == 0 ] && [ "$sb3" == 0 ] && [ "$sb4" == 0 ] +if [ "$sb1" == 0 ] && [ "$sb2" == 0 ] && [ "$sb3" == 0 ] && [ "$sb4" == 0 ] +then + exit 0 +else + exit 1 +fi diff --git a/test/gourdinl/fp_init.c b/test/gourdinl/fp_init.c new file mode 100644 index 00000000..1d835994 --- /dev/null +++ b/test/gourdinl/fp_init.c @@ -0,0 +1,7 @@ +int main (float *x) { + double a = 1.0; + float b = 1.0f; + printf("%f", a); + *x = b; + return b; +} diff --git a/test/gourdinl/gen_asm_files.sh b/test/gourdinl/gen_asm_files.sh new file mode 100755 index 00000000..08cd4b3d --- /dev/null +++ b/test/gourdinl/gen_asm_files.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +../../ccomp -S clause2.c -o clause2.nopostpass.noph.s -fno-coalesce-mem -fno-postpass +../../ccomp -S clause2.c -o clause2.nopostpass.ph.s -fcoalesce-mem -fno-postpass +../../ccomp -S clause2.c -o clause2.noph.s -fno-coalesce-mem +../../ccomp -S clause2.c -o clause2.ph.s -fcoalesce-mem diff --git a/test/monniaux/profiling/compcert_profiling.dat b/test/monniaux/profiling/compcert_profiling.dat Binary files differnew file mode 100644 index 00000000..bd2f90da --- /dev/null +++ b/test/monniaux/profiling/compcert_profiling.dat diff --git a/test/monniaux/profiling/test_profiling b/test/monniaux/profiling/test_profiling Binary files differnew file mode 100755 index 00000000..33e22d11 --- /dev/null +++ b/test/monniaux/profiling/test_profiling diff --git a/test/monniaux/profiling/test_profiling.c b/test/monniaux/profiling/test_profiling.c new file mode 100644 index 00000000..013b1d68 --- /dev/null +++ b/test/monniaux/profiling/test_profiling.c @@ -0,0 +1,15 @@ +#include <stdlib.h> +#include <stdio.h> + +int main(int argc, char **argv) { + if (argc < 2) return 1; + int i = atoi(argv[1]); + if (i > 0) { + printf("positive\n"); + } else if (i==0) { + printf("zero\n"); + } else { + printf("negative\n"); + } + return 0; +} |