diff options
| -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/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 | 1 | ||||
| -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 | 2 | ||||
| -rw-r--r-- | driver/Configuration.ml | 1 | ||||
| -rw-r--r-- | driver/Configuration.mli | 3 | ||||
| -rw-r--r-- | driver/Driver.ml | 2 | ||||
| -rw-r--r-- | driver/Frontend.ml | 5 | ||||
| -rwxr-xr-x | make_docker.sh | 3 | ||||
| -rw-r--r-- | riscV/Asmexpand.ml | 9 | ||||
| -rw-r--r-- | riscV/Asmgen.v | 344 | ||||
| -rw-r--r-- | riscV/Asmgenproof.v | 162 | ||||
| -rw-r--r-- | riscV/Asmgenproof1.v | 919 | ||||
| -rw-r--r-- | riscV/ExpansionOracle.ml | 140 | ||||
| -rw-r--r-- | riscV/RTLpathSE_simplify.v | 10 | ||||
| -rw-r--r-- | scheduling/RTLpath.v | 2 | ||||
| -rw-r--r-- | scheduling/RTLpathLivegenaux.ml | 30 | ||||
| -rw-r--r-- | scheduling/RTLpathSE_simu_specs.v | 7 | ||||
| -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 | ||||
| -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 |
67 files changed, 604 insertions, 2212 deletions
@@ -297,6 +297,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 6d8611a9..84762c74 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -51,7 +51,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/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 9ec1d563..53959152 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -231,8 +231,8 @@ module Target (*: 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 08061aa4..a5aa5177 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -869,7 +869,6 @@ Remark transl_destroyed_by_op: forall op e, destroyed_by_op (transl_op e op) = destroyed_by_op op. Proof. intros; destruct op; try reflexivity; simpl. - all: destruct optR as [[]|]; simpl; try reflexivity. 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 @@ -584,9 +584,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!";; @@ -710,6 +710,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 73b71ea0..4f5a93d2 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -242,7 +242,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; @@ -275,7 +275,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 54436758..07b55832 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -88,7 +88,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 gcc_extensions : t -> 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 ed036f87..9b7b5c4d 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -105,8 +105,6 @@ 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_others = ref true 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 1d40214a..ecc2aba6 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 7192ba4b..c9eacadc 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -444,8 +444,6 @@ let cmdline_actions = @ f_opt "madd" option_fmadd @ 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 c99da945..c8890046 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" -> Machine.aarch64 | _ -> assert false end; 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/Asmexpand.ml b/riscV/Asmexpand.ml index c5cd6817..3f9d3359 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -23,6 +23,7 @@ open Asm open Asmexpandaux open AST open Camlcoq +open Asmgen open! Integers exception Error of string @@ -44,11 +45,13 @@ let align n a = (n + a - 1) land (-a) (* Emit instruction sequences that set or offset a register by a constant. *) let expand_loadimm32 dst n = - List.iter emit (Asmgen.loadimm32 dst n []) + match make_immed32 n with + | Imm32_single imm -> emit (Paddiw (dst, X0, imm)) + | Imm32_pair (hi, lo) -> List.iter emit (load_hilo32 dst hi lo []) let expand_addptrofs dst src n = - List.iter emit (Asmgen.addptrofs dst src n []) + List.iter emit (addptrofs dst src n []) let expand_storeind_ptr src base ofs = - List.iter emit (Asmgen.storeind_ptr src base ofs []) + List.iter emit (storeind_ptr src base ofs []) (* Built-ins. They come in two flavors: - annotation statements: take their arguments in registers or stack diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index 3e84e950..da6c0101 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -86,12 +86,6 @@ Definition make_immed64 (val: int64) := Definition load_hilo32 (r: ireg) (hi lo: int) k := if Int.eq lo Int.zero then Pluiw r hi :: k else Pluiw r hi :: Paddiw r r lo :: k. - -Definition loadimm32 (r: ireg) (n: int) (k: code) := - match make_immed32 n with - | Imm32_single imm => Paddiw r X0 imm :: k - | Imm32_pair hi lo => load_hilo32 r hi lo k - end. Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int -> instruction) @@ -102,23 +96,11 @@ Definition opimm32 (op: ireg -> ireg0 -> ireg0 -> instruction) end. 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 else Pluil r hi :: Paddil r r lo :: k. -Definition loadimm64 (r: ireg) (n: int64) (k: code) := - match make_immed64 n with - | Imm64_single imm => Paddil r X0 imm :: k - | Imm64_pair hi lo => load_hilo64 r hi lo k - | Imm64_large imm => Ploadli r imm :: k - end. - Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) (opimm: ireg -> ireg0 -> int64 -> instruction) (rd rs: ireg) (n: int64) (k: code) := @@ -129,11 +111,6 @@ Definition opimm64 (op: ireg -> ireg0 -> ireg0 -> instruction) end. 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 @@ -143,68 +120,6 @@ Definition addptrofs (rd rs: ireg) (n: ptrofs) (k: code) := then addimm64 rd rs (Ptrofs.to_int64 n) k else addimm32 rd rs (Ptrofs.to_int n) k. -(** Translation of conditional branches. *) - -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 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) := @@ -223,59 +138,6 @@ Definition get_oreg (optR: option oreg) (r: ireg0) := Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - 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 (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 (transl_cbranch_int64s c r1 r2 lbl :: k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - 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; let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in @@ -344,133 +206,6 @@ Definition transl_cbranch 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]. *) @@ -483,22 +218,6 @@ Definition transl_op | FR r, FR a => OK (Pfmv r a :: k) | _ , _ => Error(msg "Asmgen.Omove") end - | Ointconst n, nil => - do rd <- ireg_of res; - OK (loadimm32 rd n k) - | Olongconst n, nil => - do rd <- ireg_of res; - OK (loadimm64 rd n k) - | Ofloatconst f, nil => - do rd <- freg_of res; - OK (if Float.eq_dec f Float.zero - then Pfcvtdw rd X0 :: k - else Ploadfi rd f :: k) - | Osingleconst f, nil => - do rd <- freg_of res; - OK (if Float32.eq_dec f Float32.zero - then Pfcvtsw rd X0 :: k - else Ploadsi rd f :: k) | Oaddrsymbol s ofs, nil => do rd <- ireg_of res; OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) @@ -508,18 +227,9 @@ Definition transl_op do rd <- ireg_of res; OK (addptrofs rd SP n k) - | Ocast8signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 24) :: Psraiw rd rd (Int.repr 24) :: k) - | Ocast16signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 16) :: Psraiw rd rd (Int.repr 16) :: k) | Oadd, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddw rd rs1 rs2 :: k) - | Oaddimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm32 rd rs n k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubw rd X0 rs :: k) @@ -550,21 +260,12 @@ Definition transl_op | Oand, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandw rd rs1 rs2 :: k) - | Oandimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm32 rd rs n k) | Oor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porw rd rs1 rs2 :: k) - | Oorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm32 rd rs n k) | Oxor, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorw rd rs1 rs2 :: k) - | Oxorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm32 rd rs n k) | Oshl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psllw rd rs1 rs2 :: k) @@ -583,19 +284,6 @@ Definition transl_op | Oshruimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrliw rd rs n :: k) - | Oshrximm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero - then Pmv rd rs :: k - else if Int.eq n Int.one - then Psrliw X31 rs (Int.repr 31) :: - Paddw X31 rs X31 :: - Psraiw rd X31 Int.one :: k - else Psraiw X31 rs (Int.repr 31) :: - Psrliw X31 X31 (Int.sub Int.iwordsize n) :: - Paddw X31 rs X31 :: - Psraiw rd X31 n :: k) - (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -604,16 +292,9 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; assertion (ireg_eq rd rs); OK (Pcvtw2l rd :: k) - | Ocast32unsigned, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - assertion (ireg_eq rd rs); - OK (Pcvtw2l rd :: Psllil rd rd (Int.repr 32) :: Psrlil rd rd (Int.repr 32) :: k) | Oaddl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Paddl rd rs1 rs2 :: k) - | Oaddlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm64 rd rs n k) | Onegl, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psubl rd X0 rs :: k) @@ -644,21 +325,12 @@ Definition transl_op | Oandl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pandl rd rs1 rs2 :: k) - | Oandlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm64 rd rs n k) | Oorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Porl rd rs1 rs2 :: k) - | Oorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm64 rd rs n k) | Oxorl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pxorl rd rs1 rs2 :: k) - | Oxorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm64 rd rs n k) | Oshll, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pslll rd rs1 rs2 :: k) @@ -677,19 +349,6 @@ Definition transl_op | Oshrluimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Psrlil rd rs n :: k) - | Oshrxlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (if Int.eq n Int.zero - then Pmv rd rs :: k - else if Int.eq n Int.one - then Psrlil X31 rs (Int.repr 63) :: - Paddl X31 rs X31 :: - Psrail rd X31 Int.one :: k - else Psrail X31 rs (Int.repr 63) :: - Psrlil X31 X31 (Int.sub Int64.iwordsize' n) :: - Paddl X31 rs X31 :: - Psrail rd X31 n :: k) - | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs :: k) @@ -784,9 +443,6 @@ Definition transl_op | Osingleoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) - | Ocmp cmp, _ => - do rd <- ireg_of res; - transl_cond_op cmp rd args k (* Instructions expanded in RTL *) | OEseqw optR, a1 :: a2 :: nil => diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 509eac94..4af8352c 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -115,14 +115,6 @@ Qed. Section TRANSL_LABEL. -Remark loadimm32_label: - forall r n k, tail_nolabel k (loadimm32 r n k). -Proof. - intros; unfold loadimm32. destruct (make_immed32 n); TailNoLabel. - unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel. -Qed. -Hint Resolve loadimm32_label: labels. - Remark opimm32_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -134,14 +126,6 @@ Proof. Qed. Hint Resolve opimm32_label: labels. -Remark loadimm64_label: - forall r n k, tail_nolabel k (loadimm64 r n k). -Proof. - intros; unfold loadimm64. destruct (make_immed64 n); TailNoLabel. - unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel. -Qed. -Hint Resolve loadimm64_label: labels. - Remark opimm64_label: forall op opimm r1 r2 n k, (forall r1 r2 r3, nolabel (op r1 r2 r3)) -> @@ -161,165 +145,25 @@ 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. -- 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. + all: 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. + unfold transl_op; intros; destruct op; TailNoLabel; + try (destruct optR as [[]|]; simpl in *; 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 2293e001..faa066b0 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -129,22 +129,6 @@ Proof. intros; Simpl. Qed. -Lemma loadimm32_correct: - forall rd n k rs m, - exists rs', - exec_straight ge fn (loadimm32 rd n k) rs m k rs' m - /\ rs'#rd = Vint n - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. - destruct (make_immed32 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int.add_zero_l; Simpl. - intros; Simpl. -- rewrite E. apply load_hilo32_correct. -Qed. - Lemma opimm32_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int -> instruction) @@ -195,27 +179,6 @@ Proof. intros; Simpl. Qed. -Lemma loadimm64_correct: - forall rd n k rs m, - exists rs', - exec_straight ge fn (loadimm64 rd n k) rs m k rs' m - /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> X31 -> rs'#r = rs#r. -Proof. - unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int64.add_zero_l; Simpl. - intros; Simpl. -- exploit load_hilo64_correct; eauto. intros (rs' & A & B & C). - rewrite E. exists rs'; eauto. -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -Qed. - Lemma opimm64_correct: forall (op: ireg -> ireg0 -> ireg0 -> instruction) (opi: ireg -> ireg0 -> int64 -> instruction) @@ -290,102 +253,6 @@ 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 @@ -417,219 +284,46 @@ 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. - - 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. + all: + destruct optR as [[]|]; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; + unfold zero32, Op.zero32 in *; + unfold zero64, Op.zero64 in *; inv EQ2; + try (destruct (rs x); simpl in EVAL'; discriminate; fail); + try (eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto; fail). + all: + destruct (rs x) eqn:EQRS; simpl in *; try congruence; + 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. + - assert (HB: (Int.eq i Int.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - 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. + - 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. + - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - 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. + - 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. + - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - 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. + - 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. + - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. rewrite <- HB; destruct b; simpl; auto. - + rewrite EQRS; - destruct (rs x0); try congruence. + - 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: @@ -663,417 +357,6 @@ 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: - forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). -Proof. - intros. apply Int64.same_bits_eq; intros. - rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. - rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). - change Int.zwordsize with 32. - destruct (zlt i0 32). auto. apply Int.bits_above. auto. -Qed. - (* Translation of arithmetic operations *) Ltac SimplEval H := @@ -1103,28 +386,6 @@ Opaque Int.eq. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. (* move *) { destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. } - (* intconst *) - { exploit loadimm32_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* longconst *) - { exploit loadimm64_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* floatconst *) - { destruct (Float.eq_dec n Float.zero). - + subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. } - (* singleconst *) - { destruct (Float32.eq_dec n Float32.zero). - + subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. } (* addrsymbol *) { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). @@ -1141,138 +402,6 @@ Opaque Int.eq. (* stackoffset *) { exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). exists rs'; split; eauto. auto with asmgen. } - (* cast8signed *) - { econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } - (* cast16signed *) - { econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. - split; intros; Simpl. - assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } - (* addimm *) - { exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* andimm *) - { exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* orimm *) - exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. - { intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* xorimm *) - { exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* shrximm *) - { destruct (Val.shrx (rs x0) (Vint n)) eqn:TOTAL; cbn. - { - exploit Val.shrx_shr_3; eauto. intros E; subst v. - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - } - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. } - (* longofintu *) - { econstructor; split. - eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. - split; intros; Simpl. destruct (rs x0); auto. simpl. - assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. - rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. - rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. } - (* addlimm *) - { exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* andimm *) - { exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* orimm *) - { exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* xorimm *) - { exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. } - (* shrxlimm *) - { destruct (Val.shrxl (rs x0) (Vint n)) eqn:TOTAL. - { - exploit Val.shrxl_shrl_3; eauto. intros E; subst v. - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - - * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - } - destruct (Int.eq n Int.zero). - + econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. - + destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - - * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - 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 *) 9,10,19,20: econstructor; split; try apply exec_straight_one; simpl; eauto; diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml index def90a6a..5d739375 100644 --- a/riscV/ExpansionOracle.ml +++ b/riscV/ExpansionOracle.ml @@ -22,13 +22,11 @@ open! Integers open Camlcoq open Option open AST -open Printf +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 *) -let exp_debug = false - (** Managing virtual registers and node index *) let reg = ref 1 @@ -80,9 +78,9 @@ type numb = { } let print_list_pos l = - if exp_debug then eprintf "["; - List.iter (fun i -> if exp_debug then eprintf "%d;" (p2i i)) l; - if exp_debug then eprintf "]\n" + 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 } @@ -93,11 +91,11 @@ let rec get_nvalues vn = function let v = match Hashtbl.find_opt !vn.nreg r with | Some v -> - if exp_debug then eprintf "getnval r=%d |-> v=%d\n" (p2i r) v; + debug "getnval r=%d |-> v=%d\n" (p2i r) v; v | None -> let n = !vn.nnext in - if exp_debug then eprintf "getnval r=%d |-> v=%d\n" (p2i r) n; + 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 ]; @@ -112,17 +110,17 @@ let get_nval_ornil vn v = let forget_reg vn rd = match Hashtbl.find_opt !vn.nreg rd with | Some v -> - if exp_debug then eprintf "forget_reg: r=%d |-> v=%d\n" (p2i rd) v; + debug "forget_reg: r=%d |-> v=%d\n" (p2i rd) v; let old_regs = get_nval_ornil vn v in - if exp_debug then eprintf "forget_reg: old_regs are:\n"; + 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 -> - if exp_debug then eprintf "forget_reg: no mapping for r=%d\n" (p2i rd) + debug "forget_reg: no mapping for r=%d\n" (p2i rd) let update_reg vn rd v = - if exp_debug then eprintf "update_reg: update v=%d with r=%d\n" v (p2i rd); + 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) @@ -132,7 +130,7 @@ let rec find_valnum_rhs rh = function | Seq (v, rh') :: tl -> if rh = rh' then Some v else find_valnum_rhs rh tl let set_unknown vn rd = - if exp_debug then eprintf "set_unknown: rd=%d\n" (p2i rd); + debug "set_unknown: rd=%d\n" (p2i rd); forget_reg vn rd; Hashtbl.remove !vn.nreg rd @@ -141,19 +139,19 @@ 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 -> - if exp_debug then eprintf "addrhs: Some v=%d\n" 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 - if exp_debug then eprintf "addrhs: None v=%d\n" n; + 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 = - if exp_debug then eprintf "addsop\n"; + debug "addsop\n"; if op = Omove then ( update_reg vn rd (List.hd v); Hashtbl.replace !vn.nreg rd (List.hd v)) @@ -167,11 +165,11 @@ let rec kill_mem_operations = function | eq :: tl -> eq :: kill_mem_operations tl let reg_valnum vn v = - if exp_debug then eprintf "reg_valnum: trying to find a mapping for v=%d\n" v; + debug "reg_valnum: trying to find a mapping for v=%d\n" v; match Hashtbl.find !vn.nval v with | [] -> None | r :: rs -> - if exp_debug then eprintf "reg_valnum: found a mapping r=%d\n" (p2i r); + debug "reg_valnum: found a mapping r=%d\n" (p2i r); Some r let rec reg_valnums vn = function @@ -216,7 +214,7 @@ let addinst vn op args rd = let rh = Sop (op, v) in match find_rhs vn rh with | Some r -> - if exp_debug then eprintf "addinst: rhs found with r=%d\n" (p2i r); + debug "addinst: rhs found with r=%d\n" (p2i r); Sr r | None -> addsop vn v op rd; @@ -627,8 +625,7 @@ let get_regs_inst = function (** Modify pathmap according to the size of the expansion list *) let write_pathmap initial esize pm' = - if exp_debug then - eprintf "write_pathmap: initial=%d, esize=%d\n" (p2i initial) esize; + 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' = @@ -655,7 +652,7 @@ let get_arguments vn vals args = (** Update the code tree with the expansion list *) let rec write_tree vn exp initial current code' new_order fturn = - if exp_debug then eprintf "wt: node is %d\n" !node; + 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 @@ -685,7 +682,7 @@ let rec write_tree vn exp initial current code' new_order fturn = (** Main expansion function - TODO gourdinl to split? *) let expanse (sb : superblock) code pm = - if exp_debug then eprintf "#### New superblock for expansion oracle\n"; + debug "#### New superblock for expansion oracle\n"; let new_order = ref [] in let liveins = ref sb.liveins in let exp = ref [] in @@ -699,139 +696,138 @@ let expanse (sb : superblock) code pm = was_branch := false; was_exp := false; let inst = get_some @@ PTree.get n code in - if exp_debug then eprintf "We are checking node %d\n" (p2i n); - (if !Clflags.option_fexpanse_rtlcond then - match inst with + debug "We are checking node %d\n" (p2i n); + (match inst with (* Expansion of conditions - Ocmp *) | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ccomp\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompu\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompuimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompl\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccomplu\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccomplimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompluimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompf\n"; + 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) -> - if exp_debug then eprintf "Iop/Cnotcompf\n"; + 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) -> - if exp_debug then eprintf "Iop/Ccompfs\n"; + 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) -> - if exp_debug then eprintf "Iop/Cnotcompfs\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccomp\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompu\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompimm\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompuimm\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompl\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccomplu\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccomplimm\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompluimm\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompf\n"; + 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) -> - if exp_debug then eprintf "Icond/Cnotcompf\n"; + 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) -> - if exp_debug then eprintf "Icond/Ccompfs\n"; + 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) -> - if exp_debug then eprintf "Icond/Cnotcompfs\n"; + 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 + (if not !was_exp then match inst with | Iop (Ofloatconst f, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ofloatconst\n"; + debug "Iop/Ofloatconst\n"; let r = r2pi () in let l = loadimm64 vn r (Floats.Float.to_bits f) in let r', l' = extract_arg l in @@ -839,7 +835,7 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Osingleconst f, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Osingleconst\n"; + debug "Iop/Osingleconst\n"; let r = r2pi () in let l = loadimm32 vn r (Floats.Float32.to_bits f) in let r', l' = extract_arg l in @@ -847,57 +843,57 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ointconst n, nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ointconst\n"; + 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) -> - if exp_debug then eprintf "Iop/Olongconst\n"; + 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) -> - if exp_debug then eprintf "Iop/Oaddimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oaddlimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oandimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oandlimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oorimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oorlimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oxorimm\n"; + 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) -> - if exp_debug then eprintf "Iop/Oxorlimm\n"; + 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) -> - if exp_debug then eprintf "Iop/cast8signed\n"; + 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 @@ -907,7 +903,7 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast16signed, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/cast16signed\n"; + 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 @@ -917,7 +913,7 @@ let expanse (sb : superblock) code pm = exp := extract_final vn !exp dest succ; was_exp := true | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> - if exp_debug then eprintf "Iop/Ocast32unsigned\n"; + debug "Iop/Ocast32unsigned\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Ocast32signed in @@ -934,10 +930,10 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Oshrximm n, a1 :: nil, dest, succ) -> if Int.eq n Int.zero then ( - if exp_debug then eprintf "Iop/Oshrximm1\n"; + debug "Iop/Oshrximm1\n"; exp := [ addinst vn (OEmayundef (MUshrx n)) [ a1; a1 ] dest ]) else if Int.eq n Int.one then ( - if exp_debug then eprintf "Iop/Oshrximm2\n"; + debug "Iop/Oshrximm2\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in @@ -953,7 +949,7 @@ let expanse (sb : superblock) code pm = let r3, l3 = extract_arg (i3 :: l2) in exp := addinst vn (OEmayundef (MUshrx n)) [ r3; r3 ] dest :: l3) else ( - if exp_debug then eprintf "Iop/Oshrximm3\n"; + debug "Iop/Oshrximm3\n"; let r1 = r2pi () in let r2 = r2pi () in let r3 = r2pi () in @@ -977,10 +973,10 @@ let expanse (sb : superblock) code pm = was_exp := true | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> if Int.eq n Int.zero then ( - if exp_debug then eprintf "Iop/Oshrxlimm1\n"; + debug "Iop/Oshrxlimm1\n"; exp := [ addinst vn (OEmayundef (MUshrxl n)) [ a1; a1 ] dest ]) else if Int.eq n Int.one then ( - if exp_debug then eprintf "Iop/Oshrxlimm2\n"; + debug "Iop/Oshrxlimm2\n"; let r1 = r2pi () in let r2 = r2pi () in let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in @@ -996,7 +992,7 @@ let expanse (sb : superblock) code pm = let r3, l3 = extract_arg (i3 :: l2) in exp := addinst vn (OEmayundef (MUshrxl n)) [ r3; r3 ] dest :: l3) else ( - if exp_debug then eprintf "Iop/Oshrxlimm3\n"; + debug "Iop/Oshrxlimm3\n"; let r1 = r2pi () in let r2 = r2pi () in let r3 = r2pi () in diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v index ca049962..7aca1772 100644 --- a/riscV/RTLpathSE_simplify.v +++ b/riscV/RTLpathSE_simplify.v @@ -853,6 +853,16 @@ Proof. destruct x; destruct y; simpl; auto. rewrite Float32.cmp_swap. auto. Qed. +Remark cast32unsigned_from_cast32signed: + forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). +Proof. + intros. apply Int64.same_bits_eq; intros. + rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. + rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). + change Int.zwordsize with 32. + destruct (zlt i0 32). auto. apply Int.bits_above. auto. +Qed. + (** * Intermediates lemmas on each expanded instruction *) Lemma simplify_ccomp_correct ge sp hst st c r r0 rs0 m0 v v0: forall diff --git a/scheduling/RTLpath.v b/scheduling/RTLpath.v index 5b34dc16..2f73f1fa 100644 --- a/scheduling/RTLpath.v +++ b/scheduling/RTLpath.v @@ -27,8 +27,6 @@ Require Import AST Integers Values Events Memory Globalenvs Smallstep. Require Import Op Registers. Require Import RTL Linking. -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_simu_specs.v b/scheduling/RTLpathSE_simu_specs.v index c3266db9..4bb3e18e 100644 --- a/scheduling/RTLpathSE_simu_specs.v +++ b/scheduling/RTLpathSE_simu_specs.v @@ -105,13 +105,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)) 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/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; +} |