diff options
68 files changed, 6572 insertions, 1811 deletions
@@ -133,6 +133,7 @@ BACKEND=\ Mach.v \ Bounds.v Stacklayout.v Stacking.v Stackingproof.v \ Asm.v Asmgen.v Asmgenproof.v Asmaux.v \ + RTLpathSE_simplify.v \ $(BACKENDLIB) SCHEDULING= \ @@ -140,7 +141,7 @@ SCHEDULING= \ RTLpathLivegen.v RTLpathSE_impl.v \ RTLpathproof.v RTLpathSE_theory.v \ RTLpathSchedulerproof.v RTLpath.v \ - RTLpathScheduler.v + RTLpathScheduler.v RTLpathWFcheck.v # C front-end modules (in cfrontend/) @@ -296,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/aarch64/Asm.v b/aarch64/Asm.v index 5f109224..067d32fb 100644 --- a/aarch64/Asm.v +++ b/aarch64/Asm.v @@ -201,7 +201,7 @@ Inductive instruction: Type := | Pstrx_a (rs: ireg) (a: addressing) (**r store int64 as any64 *) | Pstrb (rs: ireg) (a: addressing) (**r store int8 *) | Pstrh (rs: ireg) (a: addressing) (**r store int16 *) - | Pstpw (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) + | Pstpw (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int32 *) | Pstpx (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) (** Integer arithmetic, immediate *) | Paddimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r addition *) diff --git a/aarch64/ExpansionOracle.ml b/aarch64/ExpansionOracle.ml new file mode 100644 index 00000000..3b63b80d --- /dev/null +++ b/aarch64/ExpansionOracle.ml @@ -0,0 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open RTLpathCommon + +let expanse (sb : superblock) code pm = (code, pm) + +let find_last_node_reg c = () 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/RTLpathSE_simplify.v b/aarch64/RTLpathSE_simplify.v new file mode 100644 index 00000000..1ee7dac5 --- /dev/null +++ b/aarch64/RTLpathSE_simplify.v @@ -0,0 +1,42 @@ +Require Import Coqlib Floats Values Memory. +Require Import Integers. +Require Import Op Registers. +Require Import RTLpathSE_theory. +Require Import RTLpathSE_simu_specs. + +(** Target op simplifications using "fake" values *) + +Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := + None. + +Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args: list reg) : option (condition * list_hsval) := + None. + +(* Main proof of simplification *) + +Lemma target_op_simplify_correct op lr hst fsv ge sp rs0 m0 st args m: forall + (H: target_op_simplify op lr hst = Some fsv) + (REF: hsilocal_refines ge sp rs0 m0 hst st) + (OK0: hsok_local ge sp rs0 m0 hst) + (OK1: seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args) + (OK2: seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = eval_operation ge sp op args m. +Proof. + unfold target_op_simplify; simpl. + intros H (LREF & SREF & SREG & SMEM) ? ? ?. + congruence. +Qed. + +Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall + (TARGET: target_cbranch_expanse hst c l = Some (c', l')) + (LREF : hsilocal_refines ge sp rs0 m0 hst st) + (OK: hsok_local ge sp rs0 m0 hst), + seval_condition ge sp c' (hsval_list_proj l') (si_smem st) rs0 m0 = + seval_condition ge sp c (list_sval_inj (map (si_sreg st) l)) (si_smem st) rs0 m0. +Proof. + unfold target_cbranch_expanse, seval_condition; simpl. + intros H (LREF & SREF & SREG & SMEM) ?. + congruence. +Qed. +Global Opaque target_op_simplify. +Global Opaque target_cbranch_expanse. 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/arm/ExpansionOracle.ml b/arm/ExpansionOracle.ml new file mode 120000 index 00000000..ee2674bf --- /dev/null +++ b/arm/ExpansionOracle.ml @@ -0,0 +1 @@ +../aarch64/ExpansionOracle.ml
\ No newline at end of file diff --git a/arm/RTLpathSE_simplify.v b/arm/RTLpathSE_simplify.v new file mode 120000 index 00000000..55bf0e52 --- /dev/null +++ b/arm/RTLpathSE_simplify.v @@ -0,0 +1 @@ +../aarch64/RTLpathSE_simplify.v
\ No newline at end of file diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index db150521..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 @@ -343,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 @@ -372,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 *) @@ -972,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/Selectionproof.v b/backend/Selectionproof.v index 4d075f4a..8f3f5f00 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -783,6 +783,8 @@ Lemma sel_select_opt_correct: Cminor.eval_expr ge sp e m cond vcond -> Cminor.eval_expr ge sp e m a1 v1 -> Cminor.eval_expr ge sp e m a2 v2 -> + Val.has_type v1 ty -> + Val.has_type v2 ty -> Val.bool_of_val vcond b -> env_lessdef e e' -> Mem.extends m m' -> exists v', eval_expr tge sp e' m' le a v' /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v'. @@ -792,7 +794,7 @@ Proof. exploit sel_expr_correct. eexact H0. eauto. eauto. intros (vcond' & EVC & LDC). exploit sel_expr_correct. eexact H1. eauto. eauto. intros (v1' & EV1 & LD1). exploit sel_expr_correct. eexact H2. eauto. eauto. intros (v2' & EV2 & LD2). - assert (Val.bool_of_val vcond' b) by (inv H3; inv LDC; constructor). + assert (Val.bool_of_val vcond' b) by (inv H5; inv LDC; constructor). exploit eval_condition_of_expr. eexact EVC. eauto. rewrite C. intros (vargs' & EVARGS & EVCOND). exploit eval_select; eauto. intros (v' & X & Y). exists v'; split; eauto. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index d3fcdb91..a5aa5177 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -868,7 +868,7 @@ Qed. Remark transl_destroyed_by_op: forall op e, destroyed_by_op (transl_op e op) = destroyed_by_op op. Proof. - intros; destruct op; reflexivity. + intros; destruct op; try reflexivity; simpl. Qed. Remark transl_destroyed_by_load: diff --git a/common/DebugPrint.ml b/common/DebugPrint.ml index f68432d9..6f8449ee 100644 --- a/common/DebugPrint.ml +++ b/common/DebugPrint.ml @@ -5,7 +5,7 @@ open Registers let debug_flag = ref false let debug fmt = - if !debug_flag then (flush stderr; Printf.eprintf fmt) + if !debug_flag then (flush stderr; flush stdout; Printf.eprintf fmt) else Printf.ifprintf stderr fmt let print_ptree_bool oc pt = diff --git a/common/Values.v b/common/Values.v index 4146dd59..5d32e54e 100644 --- a/common/Values.v +++ b/common/Values.v @@ -89,6 +89,27 @@ Definition has_type (v: val) (t: typ) : Prop := | _, _ => False end. +Definition has_type_b (v: val) (t: typ) := + match v, t with + | Vundef, _ => true + | Vint _, Tint => true + | Vlong _, Tlong => true + | Vfloat _, Tfloat => true + | Vsingle _, Tsingle => true + | Vptr _ _, Tint => negb Archi.ptr64 + | Vptr _ _, Tlong => Archi.ptr64 + | (Vint _ | Vsingle _), Tany32 => true + | Vptr _ _, Tany32 => negb Archi.ptr64 + | _, Tany64 => true + | _, _ => false + end. + +Lemma has_type_b_correct: forall v t, + has_type_b v t = true <-> has_type v t. +Proof. + destruct v; destruct t; cbn; destruct Archi.ptr64; cbn; split; intros; auto; discriminate. +Qed. + Fixpoint has_type_list (vl: list val) (tl: list typ) {struct vl} : Prop := match vl, tl with | nil, nil => True @@ -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 @@ -842,6 +843,13 @@ BACKENDLIB=Machblock.v Machblockgen.v Machblockgenproof.v\\ EOF fi +if [ "$arch" = "riscV" ] ; then +cat >> Makefile.config <<EOF +EXTRA_EXTRACTION=Asm.ireg_eq Asm.ireg0_eq +BACKENDLIB=Asmgenproof0.v Asmgenproof1.v ExtValues.v +EOF +fi + # # Generate Merlin and CoqProject files to simplify development # 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/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/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/filter_peeplog.fish b/filter_peeplog.fish index b7ba1d28..72a0eaf1 100755 --- a/filter_peeplog.fish +++ b/filter_peeplog.fish @@ -1,9 +1,39 @@ -echo "LDP_CONSEC_PEEP_IMM_INC" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC" | wc -l) -echo "LDP_CONSEC_PEEP_IMM_DEC" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC" | wc -l) -echo "LDP_FORW_SPACED_PEEP_IMM_INC" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC" | wc -l) -echo "LDP_FORW_SPACED_PEEP_IMM_DEC" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC" | wc -l) -echo "STP_CONSEC_PEEP_IMM_INC" (cat log | ack "STP_CONSEC_PEEP_IMM_INC" | wc -l) -echo "STP_FORW_SPACED_PEEP_IMM_INC" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC" | wc -l) -echo "LDP_BACK_SPACED_PEEP_IMM_INC" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC" | wc -l) -echo "LDP_BACK_SPACED_PEEP_IMM_DEC" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC" | wc -l) -echo "STP_BACK_SPACED_PEEP_IMM_INC" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC" | wc -l)
\ No newline at end of file +echo "LDP_CONSEC_PEEP_IMM_INC_ldr32" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr32" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_INC_ldr64" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr64" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr32" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr32" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr64" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr64" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64" | wc -l) +echo "\n" +echo "LDP_CONSEC_PEEP_IMM_INC_ldr32f" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr32f" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_INC_ldr64f" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr64f" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr32f" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr32f" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr64f" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr64f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64f" | wc -l) +echo "\n" +echo "STP_CONSEC_PEEP_IMM_INC_str32" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str32" | wc -l) +echo "STP_CONSEC_PEEP_IMM_INC_str64" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str64" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str32" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str32" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str64" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str64" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str32" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str32" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str64" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str64" | wc -l) +echo "\n" +echo "STP_CONSEC_PEEP_IMM_INC_str32f" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str32f" | wc -l) +echo "STP_CONSEC_PEEP_IMM_INC_str64f" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str64f" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str32f" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str32f" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str64f" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str64f" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str32f" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str32f" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str64f" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str64f" | wc -l) diff --git a/kvx/ExpansionOracle.ml b/kvx/ExpansionOracle.ml new file mode 120000 index 00000000..ee2674bf --- /dev/null +++ b/kvx/ExpansionOracle.ml @@ -0,0 +1 @@ +../aarch64/ExpansionOracle.ml
\ No newline at end of file diff --git a/kvx/RTLpathSE_simplify.v b/kvx/RTLpathSE_simplify.v new file mode 120000 index 00000000..55bf0e52 --- /dev/null +++ b/kvx/RTLpathSE_simplify.v @@ -0,0 +1 @@ +../aarch64/RTLpathSE_simplify.v
\ No newline at end of file diff --git a/powerpc/ExpansionOracle.ml b/powerpc/ExpansionOracle.ml new file mode 120000 index 00000000..ee2674bf --- /dev/null +++ b/powerpc/ExpansionOracle.ml @@ -0,0 +1 @@ +../aarch64/ExpansionOracle.ml
\ No newline at end of file diff --git a/powerpc/RTLpathSE_simplify.v b/powerpc/RTLpathSE_simplify.v new file mode 120000 index 00000000..55bf0e52 --- /dev/null +++ b/powerpc/RTLpathSE_simplify.v @@ -0,0 +1 @@ +../aarch64/RTLpathSE_simplify.v
\ No newline at end of file diff --git a/riscV/Asm.v b/riscV/Asm.v index dc410a3b..a16f57b5 100644 --- a/riscV/Asm.v +++ b/riscV/Asm.v @@ -30,6 +30,7 @@ Require Import Smallstep. Require Import Locations. Require Stacklayout. Require Import Conventions. +Require ExtValues. (** * Abstract syntax *) @@ -62,10 +63,10 @@ Inductive freg: Type := | F24: freg | F25: freg | F26: freg | F27: freg | F28: freg | F29: freg | F30: freg | F31: freg. -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Definition ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. Proof. decide equality. Defined. -Lemma ireg0_eq: forall (x y: ireg0), {x=y} + {x<>y}. +Definition ireg0_eq: forall (x y: ireg0), {x=y} + {x<>y}. Proof. decide equality. apply ireg_eq. Defined. Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. @@ -255,8 +256,10 @@ Inductive instruction : Type := (* floating point register move *) | Pfmv (rd: freg) (rs: freg) (**r move *) - | Pfmvxs (rd: ireg) (rs: freg) (**r move FP single to integer register *) - | Pfmvxd (rd: ireg) (rs: freg) (**r move FP double to integer register *) + | Pfmvxs (rd: ireg) (rs: freg) (**r bitwise move FP single to integer register *) + | Pfmvxd (rd: ireg) (rs: freg) (**r bitwise move FP double to integer register *) + | Pfmvsx (rd: freg) (rs: ireg) (**r bitwise move integer register to FP single *) + | Pfmvdx (rd: freg) (rs: ireg) (**r bitwise move integer register to FP double*) (* 32-bit (single-precision) floating point *) | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *) @@ -345,6 +348,7 @@ Inductive instruction : Type := | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) | Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Pselectl (rd: ireg) (rb: ireg0) (rt: ireg0) (rf: ireg0) | Pnop : instruction. (**r nop instruction *) @@ -918,6 +922,17 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out Next (nextinstr (rs#d <- (Val.floatofsingle rs#s))) m | Pfcvtsd d s => Next (nextinstr (rs#d <- (Val.singleoffloat rs#s))) m + + | Pfmvxs d s => + Next (nextinstr (rs#d <- (ExtValues.bits_of_single rs#s))) m + | Pfmvxd d s => + Next (nextinstr (rs#d <- (ExtValues.bits_of_float rs#s))) m + + | Pfmvsx d s => + Next (nextinstr (rs#d <- (ExtValues.single_of_bits rs#s))) m + | Pfmvdx d s => + Next (nextinstr (rs#d <- (ExtValues.float_of_bits rs#s))) m + (** Pseudo-instructions *) | Pallocframe sz pos => @@ -940,6 +955,10 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | _ => Stuck end end + | Pselectl rd rb rt rf => + Next (nextinstr (rs#rd <- (ExtValues.select01_long + (rs###rb) (rs###rt) (rs###rf))) + #X31 <- Vundef) m | Plabel lbl => Next (nextinstr rs) m | Ploadsymbol rd s ofs => @@ -963,14 +982,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out end | Pbuiltin ef args res => Stuck (**r treated specially below *) + | Pnop => Next (nextinstr rs) m (**r Pnop is used by an oracle during expansion *) (** The following instructions and directives are not generated directly by Asmgen, so we do not model them. *) | Pfence - | Pfmvxs _ _ - | Pfmvxd _ _ - | Pfmins _ _ _ | Pfmaxs _ _ _ | Pfsqrts _ _ @@ -986,7 +1003,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out | Pfmsubd _ _ _ _ | Pfnmaddd _ _ _ _ | Pfnmsubd _ _ _ _ - | Pnop => Stuck end. diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 810514a3..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 @@ -582,9 +585,49 @@ let expand_builtin_inline name args res = raise (Error ("unrecognized builtin " ^ name)) (* Expansion of instructions *) - + let expand_instruction instr = match instr with + | Pselectl(rd, rb, rt, rf) -> + if not Archi.ptr64 + then failwith "Pselectl not available on RV32, only on RV64" + else + if ireg0_eq rt rf then + begin + if ireg0_eq (X rd) rt then + begin + end + else + begin + emit (Paddl(rd, X0, rt)) + end + end + else + if (ireg0_eq (X rd) rt) then + begin + emit (Psubl(X31, X0, rb)); + emit (Pandl(X31, X X31, rt)); + emit (Paddil(rd, rb, Int64.mone)); + emit (Pandl(rd, X rd, rf)); + emit (Porl(rd, X rd, X X31)) + end + else + if (ireg0_eq (X rd) rf) then + begin + emit (Paddil(X31, rb, Int64.mone)); + emit (Pandl(X31, X X31, rf)); + emit (Psubl(rd, X0, rb)); + emit (Pandl(rd, X rd, rt)); + emit (Porl(rd, X rd, X X31)) + end + else + begin + emit (Psubl(X31, X0, rb)); + emit (Paddil(rd, rb, Int64.mone)); + emit (Pandl(X31, X X31, rt)); + emit (Pandl(rd, X rd, rf)); + emit (Porl(rd, X rd, X X31)) + end | Pallocframe (sz, ofs) -> let sg = get_current_function_sig() in emit (Pmv (X30, X2)); diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index b431d63d..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,257 +120,95 @@ 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. +(** Functions to select a special register according to the op "oreg" argument from RTL *) -Definition transl_cbranch_int32u (cmp: comparison) (r1 r2: ireg0) (lbl: label) := - match cmp with - | Ceq => Pbeqw r1 r2 lbl - | Cne => Pbnew r1 r2 lbl - | Clt => Pbltuw r1 r2 lbl - | Cle => Pbgeuw r2 r1 lbl - | Cgt => Pbltuw r2 r1 lbl - | Cge => Pbgeuw r1 r2 lbl - end. +Definition apply_bin_oreg_ireg0 (optR: option oreg) (r1 r2: ireg0): (ireg0 * ireg0) := + match optR with + | None => (r1, r2) + | Some X0_L => (X0, r1) + | Some X0_R => (r1, X0) + end. -Definition 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 get_oreg (optR: option oreg) (r: ireg0) := + match optR with + | Some X0_L | Some X0_R => X0 + | _ => r + 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. - Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with - | Ccomp c, a1 :: a2 :: nil => + | CEbeqw optR, 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 => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeqw r1' r2' lbl :: k) + | CEbnew optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (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 => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnew r1' r2' lbl :: k) + | CEbequw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cbranch_int64s c r1 r2 lbl :: k) - | Ccomplu c, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeqw r1' r2' lbl :: k) + | CEbneuw optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (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) - | _, _ => - 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 => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnew r1' r2' lbl :: k) + | CEbltw optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltw r1' r2' lbl :: k) + | CEbltuw optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltuw r1' r2' lbl :: k) + | CEbgew optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgew r1' r2' lbl :: k) + | CEbgeuw optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgeuw r1' r2' lbl :: k) + | CEbeql optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeql r1' r2' lbl :: k) + | CEbnel optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnel r1' r2' lbl :: k) + | CEbequl optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbeql r1' r2' lbl :: k) + | CEbneul optR, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbnel r1' r2' lbl :: k) + | CEbltl optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32s c rd r1 r2 k) - | Ccompu c, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltl r1' r2' lbl :: k) + | CEbltul optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - 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 => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbltul r1' r2' lbl :: k) + | CEbgel optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64s c rd r1 r2 k) - | Ccomplu c, a1 :: a2 :: nil => + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgel r1' r2' lbl :: k) + | CEbgeul optR, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - 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) + let (r1', r2') := apply_bin_oreg_ireg0 optR r1 r2 in + OK (Pbgeul r1' r2' lbl :: k) | _, _ => - Error(msg "Asmgen.transl_cond_op") + Error(msg "Asmgen.transl_cond_branch") end. (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) - + Definition transl_op (op: operation) (args: list mreg) (res: mreg) (k: code) := match op, args with @@ -403,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) @@ -428,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) @@ -470,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) @@ -503,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; @@ -524,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) @@ -564,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) @@ -597,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) @@ -705,10 +444,202 @@ Definition transl_op do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) - | Ocmp cmp, _ => + (* Instructions expanded in RTL *) + | OEseqw optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseqw rd rs1' rs2' :: k) + | OEsnew optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnew rd rs1' rs2' :: k) + | OEsequw optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseqw rd rs1' rs2' :: k) + | OEsneuw optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnew rd rs1' rs2' :: k) + | OEsltw optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltw rd rs1' rs2' :: k) + | OEsltuw optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltuw rd rs1' rs2' :: k) + | OEsltiw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltiw rd rs n :: k) + | OEsltiuw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltiuw rd rs n :: k) + | OExoriw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pxoriw rd rs n :: k) + | OEluiw n, nil => + do rd <- ireg_of res; + OK (Pluiw rd n :: k) + | OEaddiw optR n, nil => + do rd <- ireg_of res; + let rs := get_oreg optR X0 in + OK (Paddiw rd rs n :: k) + | OEaddiw optR n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + let rs' := get_oreg optR rs in + OK (Paddiw rd rs' n :: k) + | OEandiw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pandiw rd rs n :: k) + | OEoriw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Poriw rd rs n :: k) + | OEseql optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseql rd rs1' rs2' :: k) + | OEsnel optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnel rd rs1' rs2' :: k) + | OEsequl optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Pseql rd rs1' rs2' :: k) + | OEsneul optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psnel rd rs1' rs2' :: k) + | OEsltl optR, a1 :: a2 :: nil => do rd <- ireg_of res; - transl_cond_op cmp rd args k + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltl rd rs1' rs2' :: k) + | OEsltul optR, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + let (rs1', rs2') := apply_bin_oreg_ireg0 optR rs1 rs2 in + OK (Psltul rd rs1' rs2' :: k) + | OEsltil n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltil rd rs n :: k) + | OEsltiul n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltiul rd rs n :: k) + | OExoril n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pxoril rd rs n :: k) + | OEluil n, nil => + do rd <- ireg_of res; + OK (Pluil rd n :: k) + | OEaddil optR n, nil => + do rd <- ireg_of res; + let rs := get_oreg optR X0 in + OK (Paddil rd rs n :: k) + | OEaddil optR n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + let rs' := get_oreg optR rs in + OK (Paddil rd rs' n :: k) + | OEandil n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pandil rd rs n :: k) + | OEoril n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Poril rd rs n :: k) + | OEloadli n, nil => + do rd <- ireg_of res; + OK (Ploadli rd n :: k) + | OEfeqd, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfeqd rd r1 r2 :: k) + | OEfltd, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfltd rd r1 r2 :: k) + | OEfled, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfled rd r1 r2 :: k) + | OEfeqs, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfeqs rd r1 r2 :: k) + | OEflts, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pflts rd r1 r2 :: k) + | OEfles, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfles rd r1 r2 :: k) + | OEmayundef _, a1 :: a2 :: nil => + do rd <- ireg_of res; + do r2 <- ireg_of a2; + if ireg_eq rd r2 then + OK (Pnop :: k) + else + OK (Pmv rd r2 :: k) + | Obits_of_single, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfmvxs rd rs :: k) + | Obits_of_float, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfmvxd rd rs :: k) + | Osingle_of_bits, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfmvsx rd rs :: k) + | Ofloat_of_bits, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfmvdx rd rs :: k) + | Oselectl, b::t::f::nil => + do rd <- ireg_of res; + do rb <- ireg_of b; + do rt <- ireg_of t; + do rf <- ireg_of f; + OK (Pselectl rd rb rt rf :: k) | _, _ => Error(msg "Asmgen.transl_op") end. diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 8e9f022c..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,112 +145,12 @@ 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. -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. + all: destruct optR as [[]|]; simpl in *; TailNoLabel. Qed. Remark transl_op_label: @@ -274,24 +158,12 @@ Remark transl_op_label: 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. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index d2255e66..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. - -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,82 +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. + 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. + - assert (HB: (Int.eq i Int.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - destruct (rs x0); try congruence. + assert (HB: (Int.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - assert (HB: negb (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + - assert (HB: negb (Int.eq i Int.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - destruct (rs x0); try congruence. + assert (HB: negb (Int.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - assert (HB: (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + - assert (HB: (Int64.eq i Int64.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - destruct (rs x0); try congruence. + assert (HB: (Int64.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + - assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. + - destruct (rs x0); try congruence. + assert (HB: negb (Int64.eq i i0) = b) by congruence. + rewrite <- HB; destruct b; simpl; auto. Qed. Lemma transl_cbranch_correct_true: @@ -526,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 := @@ -964,180 +384,72 @@ Proof. Opaque Int.eq. intros until c; intros TR EV. 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))). - exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. - intros (rs2 & A & B & C). - exists rs2; split. - apply exec_straight_step with rs1 m; auto. - split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). - rewrite Genv.shift_symbol_address. - replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). - exact B. - intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. -+ TranslOpSimpl. -- (* 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. + (* move *) + { destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. } + (* addrsymbol *) + { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + + set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. + intros (rs2 & A & B & C). + exists rs2; split. + apply exec_straight_step with rs1 m; auto. + split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). + rewrite Genv.shift_symbol_address. + replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). + exact B. + intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. + + TranslOpSimpl. } + (* stackoffset *) + { exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. } + (* Expanded instructions from RTL *) + 9,10,19,20: + econstructor; split; try apply exec_straight_one; simpl; eauto; + split; intros; Simpl; try destruct (rs x0); + try rewrite Int64.add_commut; + try rewrite Int.add_commut; auto; + try rewrite Int64.and_commut; + try rewrite Int.and_commut; auto; + try rewrite Int64.or_commut; + try rewrite Int.or_commut; auto. + 1-16: + destruct optR as [[]|]; try discriminate; + unfold apply_bin_oreg_ireg0, apply_bin_oreg in *; try inv EQ3; try inv EQ2; + try destruct (Int.eq _ _) eqn:A; try inv H0; + try destruct (Int64.eq _ _) eqn:A; try inv H1; + econstructor; split; try apply exec_straight_one; simpl; eauto; + split; intros; Simpl; + try apply Int.same_if_eq in A; subst; + try apply Int64.same_if_eq in A; subst; + unfold get_sp; + try destruct (rs x0); auto; + try destruct (rs x1); auto; + try destruct (rs X2); auto; + try destruct Archi.ptr64 eqn:B; + try fold (Val.add (Vint Int.zero) (get_sp (rs X2))); + try fold (Val.addl (Vlong Int64.zero) (get_sp (rs X2))); + try rewrite Val.add_commut; auto; + try rewrite Val.addl_commut; auto; + try rewrite Int.add_commut; auto; + try rewrite Int64.add_commut; auto; + replace (Ptrofs.of_int Int.zero) with (Ptrofs.zero) by auto; + replace (Ptrofs.of_int64 Int64.zero) with (Ptrofs.zero) by auto; + try rewrite Ptrofs.add_zero; auto. + (* mayundef *) + { destruct (ireg_eq x x0); inv EQ2; + econstructor; split; + try apply exec_straight_one; simpl; eauto; + split; unfold eval_may_undef; + destruct mu eqn:EQMU; simpl; intros; Simpl; auto. + all: + destruct (rs (preg_of m0)) eqn:EQM0; simpl; auto; + destruct (rs x0); simpl; auto; Simpl; + try destruct (Int.ltu _ _); simpl; + Simpl; auto. } + (* select *) + { econstructor; split. apply exec_straight_one. simpl; eauto. auto. split; intros; Simpl. - 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. + apply Val.lessdef_normalize. } Qed. (** Memory accesses *) @@ -1445,6 +757,3 @@ Proof. Qed. End CONSTRUCTORS. - - - diff --git a/riscV/Builtins1.v b/riscV/Builtins1.v index 53c83d7e..47bacffa 100644 --- a/riscV/Builtins1.v +++ b/riscV/Builtins1.v @@ -18,16 +18,35 @@ Require Import String Coqlib. Require Import AST Integers Floats Values. Require Import Builtins0. +Require ExtValues. -Inductive platform_builtin : Type := . +Inductive platform_builtin : Type := +| BI_bits_of_float +| BI_bits_of_double +| BI_float_of_bits +| BI_double_of_bits. Local Open Scope string_scope. Definition platform_builtin_table : list (string * platform_builtin) := - nil. + ("__builtin_bits_of_float", BI_bits_of_float) + :: ("__builtin_bits_of_double", BI_bits_of_double) + :: ("__builtin_float_of_bits", BI_float_of_bits) + :: ("__builtin_double_of_bits", BI_double_of_bits) + :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := - match b with end. + match b with + | BI_bits_of_float => mksignature (Tsingle :: nil) Tint cc_default + | BI_bits_of_double => mksignature (Tfloat :: nil) Tlong cc_default + | BI_float_of_bits => mksignature (Tint :: nil) Tsingle cc_default + | BI_double_of_bits => mksignature (Tlong :: nil) Tfloat cc_default + end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := - match b with end. + match b with + | BI_bits_of_float => mkbuiltin_n1t Tsingle Tint Float32.to_bits + | BI_bits_of_double => mkbuiltin_n1t Tfloat Tlong Float.to_bits + | BI_float_of_bits => mkbuiltin_n1t Tint Tsingle Float32.of_bits + | BI_double_of_bits => mkbuiltin_n1t Tlong Tfloat Float.of_bits + end. diff --git a/riscV/CBuiltins.ml b/riscV/CBuiltins.ml index a2087cb7..00b44fd5 100644 --- a/riscV/CBuiltins.ml +++ b/riscV/CBuiltins.ml @@ -46,6 +46,14 @@ let builtins = { (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fmin", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_bits_of_double", + (TInt(IULong, []), [TFloat(FDouble, [])], false); + "__builtin_bits_of_float", + (TInt(IUInt, []), [TFloat(FFloat, [])], false); + "__builtin_double_of_bits", + (TFloat(FDouble, []), [TInt(IULong, [])], false); + "__builtin_float_of_bits", + (TFloat(FFloat, []), [TInt(IUInt, [])], false); ] } diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml new file mode 100644 index 00000000..4f67b9af --- /dev/null +++ b/riscV/ExpansionOracle.ml @@ -0,0 +1,1066 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open RTLpathLivegenaux +open RTLpathCommon +open Datatypes +open Maps +open RTL +open Op +open Asmgen +open RTLpath +open! Integers +open Camlcoq +open Option +open AST +open Printf + +(** 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 + +let node = ref 1 + +let p2i r = P.to_int r + +let r2p () = P.of_int !reg + +let n2p () = P.of_int !node + +let r2pi () = + reg := !reg + 1; + r2p () + +let n2pi () = + node := !node + 1; + n2p () + +(** Below are the types for rhs and equations *) + +type rhs = Sop of operation * int list | Smove + +type seq = Seq of int * rhs + +(** This is a mini abstraction to have a simpler representation during expansion + - Snop will be converted to Inop + - (Sr r) is inserted if the value was found in register r + - (Sexp dest rhs args succ) represent an instruction + (succesor may not be defined at this point, hence the use of type option) + - (Sfinalcond cond args succ1 succ2 info) represents a condition (which must + always be the last instruction in expansion list *) + +type expl = + | Snop of P.t + | Sr of P.t + | Sexp of P.t * rhs * P.t list * node option + | Sfinalcond of condition * P.t list * node * node * bool option + +(** Record used during the "dynamic" value numbering *) + +type numb = { + mutable nnext : int; (** Next unusued value number *) + mutable seqs : seq list; (** equations *) + mutable nreg : (P.t, int) Hashtbl.t; (** mapping registers to values *) + mutable nval : (int, P.t list) Hashtbl.t; + (** reverse mapping values to registers containing it *) +} + +let print_list_pos l = + if exp_debug then eprintf "["; + List.iter (fun i -> if exp_debug then eprintf "%d;" (p2i i)) l; + if exp_debug then eprintf "]\n" + +let empty_numbering () = + { nnext = 1; seqs = []; nreg = Hashtbl.create 100; nval = Hashtbl.create 100 } + +let rec get_nvalues vn = function + | [] -> [] + | r :: rs -> + let v = + match Hashtbl.find_opt !vn.nreg r with + | Some v -> + if exp_debug then eprintf "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; + !vn.nnext <- !vn.nnext + 1; + Hashtbl.replace !vn.nreg r n; + Hashtbl.replace !vn.nval n [ r ]; + n + in + let vs = get_nvalues vn rs in + v :: vs + +let get_nval_ornil vn v = + match Hashtbl.find_opt !vn.nval v with None -> [] | Some l -> l + +let forget_reg vn rd = + match Hashtbl.find_opt !vn.nreg rd with + | Some v -> + if exp_debug then eprintf "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"; + 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) + +let update_reg vn rd v = + if exp_debug then eprintf "update_reg: update v=%d with r=%d\n" v (p2i rd); + forget_reg vn rd; + let old_regs = get_nval_ornil vn v in + Hashtbl.replace !vn.nval v (rd :: old_regs) + +let rec find_valnum_rhs rh = function + | [] -> None + | Seq (v, rh') :: tl -> if rh = rh' then Some v else find_valnum_rhs rh tl + +let set_unknown vn rd = + if exp_debug then eprintf "set_unknown: rd=%d\n" (p2i rd); + forget_reg vn rd; + Hashtbl.remove !vn.nreg rd + +let set_res_unknown vn res = match res with BR r -> set_unknown vn r | _ -> () + +let addrhs vn rd rh = + match find_valnum_rhs rh !vn.seqs with + | Some vres -> + if exp_debug then eprintf "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; + !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"; + if op = Omove then ( + update_reg vn rd (List.hd v); + Hashtbl.replace !vn.nreg rd (List.hd v)) + else addrhs vn rd (Sop (op, v)) + +let rec kill_mem_operations = function + | (Seq (v, Sop (op, vl)) as eq) :: tl -> + if op_depends_on_memory op then kill_mem_operations tl + else eq :: kill_mem_operations tl + | [] -> [] + | eq :: tl -> eq :: kill_mem_operations tl + +let reg_valnum vn v = + if exp_debug then eprintf "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); + Some r + +let rec reg_valnums vn = function + | [] -> Some [] + | v :: vs -> ( + match (reg_valnum vn v, reg_valnums vn vs) with + | Some r, Some rs -> Some (r :: rs) + | _, _ -> None) + +let find_rhs vn rh = + match find_valnum_rhs rh !vn.seqs with + | None -> None + | Some vres -> reg_valnum vn vres + +(** Functions to perform the dynamic reduction during CSE *) + +let extract_arg l = + if List.length l > 0 then + match List.hd l with + | Sr r -> (r, List.tl l) + | Sexp (rd, _, _, _) -> (rd, l) + | _ -> failwith "extract_arg: final instruction arg can not be extracted" + else failwith "extract_arg: trying to extract on an empty list" + +let extract_final vn fl fdest succ = + if List.length fl > 0 then + match List.hd fl with + | Sr r -> + if not (P.eq r fdest) then ( + let v = get_nvalues vn [ r ] in + addsop vn v Omove fdest; + Sexp (fdest, Smove, [ r ], Some succ) :: List.tl fl) + else Snop succ :: List.tl fl + | Sexp (rd, rh, args, None) -> + assert (rd = fdest); + Sexp (fdest, rh, args, Some succ) :: List.tl fl + | _ -> fl + else failwith "extract_final: trying to extract on an empty list" + +let addinst vn op args rd = + let v = get_nvalues vn args in + let rh = Sop (op, v) in + match find_rhs vn rh with + | Some r -> + if exp_debug then eprintf "addinst: rhs found with r=%d\n" (p2i r); + Sr r + | None -> + addsop vn v op rd; + Sexp (rd, rh, args, None) + +(** Expansion functions *) + +type immt = + | Addiw + | Addil + | Andiw + | Andil + | Oriw + | Oril + | Xoriw + | Xoril + | Sltiw + | Sltiuw + | Sltil + | Sltiul + +let load_hilo32 vn dest hi lo = + let op1 = OEluiw hi in + if Int.eq lo Int.zero then [ addinst vn op1 [] dest ] + else + let r = r2pi () in + let op2 = OEaddiw (None, lo) in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + let i2 = addinst vn op2 [ r' ] dest in + i2 :: l + +let load_hilo64 vn dest hi lo = + let op1 = OEluil hi in + if Int64.eq lo Int64.zero then [ addinst vn op1 [] dest ] + else + let r = r2pi () in + let op2 = OEaddil (None, lo) in + let i1 = addinst vn op1 [] r in + let r', l = extract_arg [ i1 ] in + let i2 = addinst vn op2 [ r' ] dest in + i2 :: l + +let loadimm32 vn dest n = + match make_immed32 n with + | Imm32_single imm -> + let op1 = OEaddiw (Some X0_R, imm) in + [ addinst vn op1 [] dest ] + | Imm32_pair (hi, lo) -> load_hilo32 vn dest hi lo + +let loadimm64 vn dest n = + match make_immed64 n with + | Imm64_single imm -> + let op1 = OEaddil (Some X0_R, imm) in + [ addinst vn op1 [] dest ] + | Imm64_pair (hi, lo) -> load_hilo64 vn dest hi lo + | Imm64_large imm -> + let op1 = OEloadli imm in + [ addinst vn op1 [] dest ] + +let get_opimm optR imm = function + | Addiw -> OEaddiw (optR, imm) + | Andiw -> OEandiw imm + | Oriw -> OEoriw imm + | Xoriw -> OExoriw imm + | Sltiw -> OEsltiw imm + | Sltiuw -> OEsltiuw imm + | Addil -> OEaddil (optR, imm) + | Andil -> OEandil imm + | Oril -> OEoril imm + | Xoril -> OExoril imm + | Sltil -> OEsltil imm + | Sltiul -> OEsltiul imm + +let opimm32 vn a1 dest n optR op opimm = + match make_immed32 n with + | Imm32_single imm -> [ addinst vn (get_opimm optR imm opimm) [ a1 ] dest ] + | Imm32_pair (hi, lo) -> + let r = r2pi () in + let l = load_hilo32 vn r hi lo in + let r', l' = extract_arg l in + let i = addinst vn op [ a1; r' ] dest in + i :: l' + +let opimm64 vn a1 dest n optR op opimm = + match make_immed64 n with + | Imm64_single imm -> [ addinst vn (get_opimm optR imm opimm) [ a1 ] dest ] + | Imm64_pair (hi, lo) -> + let r = r2pi () in + let l = load_hilo64 vn r hi lo in + let r', l' = extract_arg l in + let i = addinst vn op [ a1; r' ] dest in + i :: l' + | Imm64_large imm -> + let r = r2pi () in + let op1 = OEloadli imm in + let i1 = addinst vn op1 [] r in + let r', l' = extract_arg [ i1 ] in + let i2 = addinst vn op [ a1; r' ] dest in + i2 :: l' + +let addimm32 vn a1 dest n optR = opimm32 vn a1 dest n optR Oadd Addiw + +let andimm32 vn a1 dest n = opimm32 vn a1 dest n None Oand Andiw + +let orimm32 vn a1 dest n = opimm32 vn a1 dest n None Oor Oriw + +let xorimm32 vn a1 dest n = opimm32 vn a1 dest n None Oxor Xoriw + +let sltimm32 vn a1 dest n = opimm32 vn a1 dest n None (OEsltw None) Sltiw + +let sltuimm32 vn a1 dest n = opimm32 vn a1 dest n None (OEsltuw None) Sltiuw + +let addimm64 vn a1 dest n optR = opimm64 vn a1 dest n optR Oaddl Addil + +let andimm64 vn a1 dest n = opimm64 vn a1 dest n None Oandl Andil + +let orimm64 vn a1 dest n = opimm64 vn a1 dest n None Oorl Oril + +let xorimm64 vn a1 dest n = opimm64 vn a1 dest n None Oxorl Xoril + +let sltimm64 vn a1 dest n = opimm64 vn a1 dest n None (OEsltl None) Sltil + +let sltuimm64 vn a1 dest n = opimm64 vn a1 dest n None (OEsltul None) Sltiul + +let is_inv_cmp = function Cle | Cgt -> true | _ -> false + +let make_optR is_x0 is_inv = + if is_x0 then if is_inv then Some X0_L else Some X0_R else None + +let cbranch_int32s is_x0 cmp a1 a2 info succ1 succ2 k = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Sfinalcond (CEbeqw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbnew optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgew optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgew optR, [ a1; a2 ], succ1, succ2, info) :: k + +let cbranch_int32u is_x0 cmp a1 a2 info succ1 succ2 k = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Sfinalcond (CEbequw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbneuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltuw optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgeuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltuw optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgeuw optR, [ a1; a2 ], succ1, succ2, info) :: k + +let cbranch_int64s is_x0 cmp a1 a2 info succ1 succ2 k = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Sfinalcond (CEbeql optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbnel optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgel optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltl optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgel optR, [ a1; a2 ], succ1, succ2, info) :: k + +let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Sfinalcond (CEbequl optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Sfinalcond (CEbneul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Sfinalcond (CEbltul optR, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Sfinalcond (CEbgeul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Sfinalcond (CEbltul optR, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Sfinalcond (CEbgeul optR, [ a1; a2 ], succ1, succ2, info) :: k + +let cond_int32s vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> [ addinst vn (OEseqw optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsnew optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltw optR) [ a1; a2 ] dest ] + | Cle -> + let r = r2pi () in + let op = OEsltw optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltw optR) [ a2; a1 ] dest ] + | Cge -> + let r = r2pi () in + let op = OEsltw optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + +let cond_int32u vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> [ addinst vn (OEsequw optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsneuw optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltuw optR) [ a1; a2 ] dest ] + | Cle -> + let r = r2pi () in + let op = OEsltuw optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltuw optR) [ a2; a1 ] dest ] + | Cge -> + let r = r2pi () in + let op = OEsltuw optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + +let cond_int64s vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> [ addinst vn (OEseql optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsnel optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltl optR) [ a1; a2 ] dest ] + | Cle -> + let r = r2pi () in + let op = OEsltl optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltl optR) [ a2; a1 ] dest ] + | Cge -> + let r = r2pi () in + let op = OEsltl optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + +let cond_int64u vn is_x0 cmp a1 a2 dest = + let optR = make_optR is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> [ addinst vn (OEsequl optR) [ a1; a2 ] dest ] + | Cne -> [ addinst vn (OEsneul optR) [ a1; a2 ] dest ] + | Clt -> [ addinst vn (OEsltul optR) [ a1; a2 ] dest ] + | Cle -> + let r = r2pi () in + let op = OEsltul optR in + let i1 = addinst vn op [ a2; a1 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + | Cgt -> [ addinst vn (OEsltul optR) [ a2; a1 ] dest ] + | Cge -> + let r = r2pi () in + let op = OEsltul optR in + let i1 = addinst vn op [ a1; a2 ] r in + let r', l = extract_arg [ i1 ] in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + +let is_normal_cmp = function Cne -> false | _ -> true + +let cond_float vn cmp f1 f2 dest = + match cmp with + | Ceq -> [ addinst vn OEfeqd [ f1; f2 ] dest ] + | Cne -> [ addinst vn OEfeqd [ f1; f2 ] dest ] + | Clt -> [ addinst vn OEfltd [ f1; f2 ] dest ] + | Cle -> [ addinst vn OEfled [ f1; f2 ] dest ] + | Cgt -> [ addinst vn OEfltd [ f2; f1 ] dest ] + | Cge -> [ addinst vn OEfled [ f2; f1 ] dest ] + +let cond_single vn cmp f1 f2 dest = + match cmp with + | Ceq -> [ addinst vn OEfeqs [ f1; f2 ] dest ] + | Cne -> [ addinst vn OEfeqs [ f1; f2 ] dest ] + | Clt -> [ addinst vn OEflts [ f1; f2 ] dest ] + | Cle -> [ addinst vn OEfles [ f1; f2 ] dest ] + | Cgt -> [ addinst vn OEflts [ f2; f1 ] dest ] + | Cge -> [ addinst vn OEfles [ f2; f1 ] dest ] + +let expanse_cbranchimm_int32s vn cmp a1 n info succ1 succ2 = + if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 [] + else + let r = r2pi () in + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cbranch_int32s false cmp a1 r' info succ1 succ2 l' + +let expanse_cbranchimm_int32u vn cmp a1 n info succ1 succ2 = + if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 [] + else + let r = r2pi () in + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cbranch_int32u false cmp a1 r' info succ1 succ2 l' + +let expanse_cbranchimm_int64s vn cmp a1 n info succ1 succ2 = + if Int64.eq n Int64.zero then + cbranch_int64s true cmp a1 a1 info succ1 succ2 [] + else + let r = r2pi () in + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cbranch_int64s false cmp a1 r' info succ1 succ2 l' + +let expanse_cbranchimm_int64u vn cmp a1 n info succ1 succ2 = + if Int64.eq n Int64.zero then + cbranch_int64u true cmp a1 a1 info succ1 succ2 [] + else + let r = r2pi () in + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cbranch_int64u false cmp a1 r' info succ1 succ2 l' + +let expanse_condimm_int32s vn cmp a1 n dest = + if Int.eq n Int.zero then cond_int32s vn true cmp a1 a1 dest + else + match cmp with + | Ceq | Cne -> + let r = r2pi () in + let l = xorimm32 vn a1 r n in + let r', l' = extract_arg l in + cond_int32s vn true cmp r' r' dest @ l' + | Clt -> sltimm32 vn a1 dest n + | Cle -> + if Int.eq n (Int.repr Int.max_signed) then + let l = loadimm32 vn dest Int.one in + let r, l' = extract_arg l in + addinst vn (OEmayundef MUint) [ a1; r ] dest :: l' + else sltimm32 vn a1 dest (Int.add n Int.one) + | _ -> + let r = r2pi () in + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cond_int32s vn false cmp a1 r' dest @ l' + +let expanse_condimm_int32u vn cmp a1 n dest = + if Int.eq n Int.zero then cond_int32u vn true cmp a1 a1 dest + else + match cmp with + | Clt -> sltuimm32 vn a1 dest n + | _ -> + let r = r2pi () in + let l = loadimm32 vn r n in + let r', l' = extract_arg l in + cond_int32u vn false cmp a1 r' dest @ l' + +let expanse_condimm_int64s vn cmp a1 n dest = + if Int64.eq n Int64.zero then cond_int64s vn true cmp a1 a1 dest + else + match cmp with + | Ceq | Cne -> + let r = r2pi () in + let l = xorimm64 vn a1 r n in + let r', l' = extract_arg l in + cond_int64s vn true cmp r' r' dest @ l' + | Clt -> sltimm64 vn a1 dest n + | Cle -> + if Int64.eq n (Int64.repr Int64.max_signed) then + let l = loadimm32 vn dest Int.one in + let r, l' = extract_arg l in + addinst vn (OEmayundef MUlong) [ a1; r ] dest :: l' + else sltimm64 vn a1 dest (Int64.add n Int64.one) + | _ -> + let r = r2pi () in + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cond_int64s vn false cmp a1 r' dest @ l' + +let expanse_condimm_int64u vn cmp a1 n dest = + if Int64.eq n Int64.zero then cond_int64u vn true cmp a1 a1 dest + else + match cmp with + | Clt -> sltuimm64 vn a1 dest n + | _ -> + let r = r2pi () in + let l = loadimm64 vn r n in + let r', l' = extract_arg l in + cond_int64u vn false cmp a1 r' dest @ l' + +let expanse_cond_fp vn cnot fn_cond cmp f1 f2 dest = + let normal = is_normal_cmp cmp in + let normal' = if cnot then not normal else normal in + let insn = fn_cond vn cmp f1 f2 dest in + if normal' then insn + else + let r', l = extract_arg insn in + addinst vn (OExoriw Int.one) [ r' ] dest :: l + +let expanse_cbranch_fp vn cnot fn_cond cmp f1 f2 info succ1 succ2 = + let r = r2pi () in + let normal = is_normal_cmp cmp in + let normal' = if cnot then not normal else normal in + let insn = fn_cond vn cmp f1 f2 r in + let r', l = extract_arg insn in + if normal' then + Sfinalcond (CEbnew (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l + else Sfinalcond (CEbeqw (Some X0_R), [ r'; r' ], succ1, succ2, info) :: l + +(** Form a list containing both sources and destination regs of an instruction *) + +let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] + +let get_regs_inst = function + | Inop _ -> [] + | Iop (_, args, dest, _) -> dest :: args + | Iload (_, _, _, args, dest, _) -> dest :: args + | Istore (_, _, args, src, _) -> src :: args + | Icall (_, t, args, dest, _) -> dest :: (get_regindent t @ args) + | Itailcall (_, t, args) -> get_regindent t @ args + | Ibuiltin (_, args, dest, _) -> + AST.params_of_builtin_res dest @ AST.params_of_builtin_args args + | Icond (_, args, _, _, _) -> args + | Ijumptable (arg, _) -> [ arg ] + | Ireturn (Some r) -> [ r ] + | _ -> [] + +(** 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; + 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' = + { + psize = npsize; + input_regs = path.input_regs; + pre_output_regs = path.pre_output_regs; + output_regs = path.output_regs; + } + in + pm' := PTree.set initial path' !pm' + +(** Write a single instruction in the tree and update order *) + +let write_inst target_node inst code' new_order = + code' := PTree.set (P.of_int target_node) inst !code'; + new_order := P.of_int target_node :: !new_order + +(** Return olds args if the CSE numbering is empty *) + +let get_arguments vn vals args = + match reg_valnums vn vals with Some args' -> args' | None -> args + +(** Update the code tree with the expansion list *) + +let rec write_tree vn exp initial current code' new_order fturn = + if exp_debug then eprintf "wt: node is %d\n" !node; + let target_node, next_node = + if fturn then (P.to_int initial, current) else (current, current - 1) + in + match exp with + | Sr r :: _ -> + failwith "write_tree: there are still some symbolic values in the list" + | Sexp (rd, Sop (op, vals), args, None) :: k -> + let args = get_arguments vn vals args in + let inst = Iop (op, args, rd, P.of_int next_node) in + write_inst target_node inst code' new_order; + write_tree vn k initial next_node code' new_order false + | [ Snop succ ] -> + let inst = Inop succ in + write_inst target_node inst code' new_order + | [ Sexp (rd, Sop (op, vals), args, Some succ) ] -> + let args = get_arguments vn vals args in + let inst = Iop (op, args, rd, succ) in + write_inst target_node inst code' new_order + | [ Sexp (rd, Smove, args, Some succ) ] -> + let inst = Iop (Omove, args, rd, succ) in + write_inst target_node inst code' new_order + | [ Sfinalcond (cond, args, succ1, succ2, info) ] -> + let inst = Icond (cond, args, succ1, succ2, info) in + write_inst target_node inst code' new_order + | [] -> () + | _ -> failwith "write_tree: invalid list" + +(** Main expansion function - TODO gourdinl to split? *) +let expanse (sb : superblock) code pm = + if exp_debug then eprintf "#### New superblock for expansion oracle\n"; + let new_order = ref [] in + let liveins = ref sb.liveins in + let exp = ref [] in + let was_branch = ref false in + let was_exp = ref false in + let code' = ref code in + let pm' = ref pm in + let vn = ref (empty_numbering ()) in + Array.iter + (fun n -> + was_branch := false; + was_exp := false; + let inst = get_some @@ PTree.get n code in + if exp_debug then eprintf "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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + exp := + expanse_cbranch_fp vn true cond_single c f1 f2 info succ1 succ2; + was_branch := true; + was_exp := true + | _ -> ()); + (if not !was_exp then + match inst with + | Iop (Ofloatconst f, nil, dest, succ) -> + if exp_debug then eprintf "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 + exp := addinst vn Ofloat_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Osingleconst f, nil, dest, succ) -> + if exp_debug then eprintf "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 + exp := addinst vn Osingle_of_bits [ r' ] dest :: l'; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ointconst n, nil, dest, succ) -> + if exp_debug then eprintf "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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + 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"; + let op = Oshlimm (Int.repr (Z.of_sint 24)) in + let r = r2pi () in + let i1 = addinst vn op [ a1 ] r in + let r', l = extract_arg [ i1 ] in + exp := + addinst vn (Oshrimm (Int.repr (Z.of_sint 24))) [ r' ] dest :: l; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocast16signed, a1 :: nil, dest, succ) -> + if exp_debug then eprintf "Iop/cast16signed\n"; + let op = Oshlimm (Int.repr (Z.of_sint 16)) in + let r = r2pi () in + let i1 = addinst vn op [ a1 ] r in + let r', l = extract_arg [ i1 ] in + exp := + addinst vn (Oshrimm (Int.repr (Z.of_sint 16))) [ r' ] dest :: l; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Ocast32unsigned, a1 :: nil, dest, succ) -> + if exp_debug then eprintf "Iop/Ocast32unsigned\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Ocast32signed in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oshllimm (Int.repr (Z.of_sint 32)) in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oshrluimm (Int.repr (Z.of_sint 32)) in + exp := addinst vn op3 [ r2' ] dest :: l2; + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oshrximm n, a1 :: nil, dest, succ) -> + if Int.eq n Int.zero then ( + if exp_debug then eprintf "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"; + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshruimm (Int.repr (Z.of_sint 31)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oadd in + let i2 = addinst vn op2 [ a1; r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oshrimm Int.one in + let i3 = addinst vn op3 [ r2' ] dest in + let r3, l3 = extract_arg (i3 :: l2) in + exp := addinst vn (OEmayundef (MUshrx n)) [ r3; r3 ] dest :: l3) + else ( + if exp_debug then eprintf "Iop/Oshrximm3\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrimm (Int.repr (Z.of_sint 31)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oshruimm (Int.sub Int.iwordsize n) in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oadd in + let i3 = addinst vn op3 [ a1; r2' ] r3 in + let r3', l3 = extract_arg (i3 :: l2) in + + let op4 = Oshrimm n in + let i4 = addinst vn op4 [ r3' ] dest in + let r4, l4 = extract_arg (i4 :: l3) in + exp := addinst vn (OEmayundef (MUshrx n)) [ r4; r4 ] dest :: l4); + exp := extract_final vn !exp dest succ; + was_exp := true + | Iop (Oshrxlimm n, a1 :: nil, dest, succ) -> + if Int.eq n Int.zero then ( + if exp_debug then eprintf "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"; + let r1 = r2pi () in + let r2 = r2pi () in + let op1 = Oshrluimm (Int.repr (Z.of_sint 63)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oaddl in + let i2 = addinst vn op2 [ a1; r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oshrlimm Int.one in + let i3 = addinst vn op3 [ r2' ] dest in + let r3, l3 = extract_arg (i3 :: l2) in + exp := addinst vn (OEmayundef (MUshrxl n)) [ r3; r3 ] dest :: l3) + else ( + if exp_debug then eprintf "Iop/Oshrxlimm3\n"; + let r1 = r2pi () in + let r2 = r2pi () in + let r3 = r2pi () in + let op1 = Oshrlimm (Int.repr (Z.of_sint 63)) in + let i1 = addinst vn op1 [ a1 ] r1 in + let r1', l1 = extract_arg [ i1 ] in + + let op2 = Oshrluimm (Int.sub Int64.iwordsize' n) in + let i2 = addinst vn op2 [ r1' ] r2 in + let r2', l2 = extract_arg (i2 :: l1) in + + let op3 = Oaddl in + let i3 = addinst vn op3 [ a1; r2' ] r3 in + let r3', l3 = extract_arg (i3 :: l2) in + + let op4 = Oshrlimm n in + let i4 = addinst vn op4 [ r3' ] dest in + let r4, l4 = extract_arg (i4 :: l3) in + exp := addinst vn (OEmayundef (MUshrxl n)) [ r4; r4 ] dest :: l4); + exp := extract_final vn !exp dest succ; + was_exp := true + | _ -> ()); + (* Update the CSE numbering *) + (if not !was_exp then + match inst with + | Iop (op, args, dest, succ) -> + let v = get_nvalues vn args in + addsop vn v op dest + | Iload (_, _, _, _, dst, _) -> set_unknown vn dst + | Istore (chk, addr, args, src, s) -> + !vn.seqs <- kill_mem_operations !vn.seqs + | Icall (_, _, _, _, _) | Itailcall (_, _, _) | Ibuiltin (_, _, _, _) -> + vn := empty_numbering () + | _ -> ()); + (* Update code, liveins, pathmap, and order of the superblock for one expansion *) + if !was_exp then ( + (if !was_branch && List.length !exp > 1 then + let lives = PTree.get n !liveins in + match lives with + | Some lives -> + let new_branch_pc = P.of_int (!node + 1) in + liveins := PTree.set new_branch_pc lives !liveins; + liveins := PTree.remove n !liveins + | _ -> ()); + node := !node + List.length !exp - 1; + write_pathmap sb.instructions.(0) (List.length !exp - 1) pm'; + write_tree vn (List.rev !exp) n !node code' new_order true) + else new_order := n :: !new_order) + sb.instructions; + sb.instructions <- Array.of_list (List.rev !new_order); + sb.liveins <- !liveins; + (!code', !pm') + +(** Compute the last used node and reg indexs *) + +let rec find_last_node_reg = function + | [] -> () + | (pc, i) :: k -> + let rec traverse_list var = function + | [] -> () + | e :: t -> + let e' = p2i e in + if e' > !var then var := e'; + traverse_list var t + in + traverse_list node [ pc ]; + traverse_list reg (get_regs_inst i); + find_last_node_reg k diff --git a/riscV/ExtValues.v b/riscV/ExtValues.v new file mode 100644 index 00000000..edf359ef --- /dev/null +++ b/riscV/ExtValues.v @@ -0,0 +1,123 @@ +Require Import Coqlib. +Require Import Integers. +Require Import Values. +Require Import Floats. +Require Import Memory. +Require Import Lia. + +Definition bits_of_float x := + match x with + | Vfloat f => Vlong (Float.to_bits f) + | _ => Vundef + end. + +Definition bits_of_single x := + match x with + | Vsingle f => Vint (Float32.to_bits f) + | _ => Vundef + end. + +Definition float_of_bits x := + match x with + | Vlong f => Vfloat (Float.of_bits f) + | _ => Vundef + end. + +Definition single_of_bits x := + match x with + | Vint f => Vsingle (Float32.of_bits f) + | _ => Vundef + end. + +Definition bitwise_select_long b vtrue vfalse := + Int64.or (Int64.and (Int64.neg b) vtrue) + (Int64.and (Int64.sub b Int64.one) vfalse). + +Lemma bitwise_select_long_true : + forall vtrue vfalse, + bitwise_select_long Int64.one vtrue vfalse = vtrue. +Proof. + intros. unfold bitwise_select_long. cbn. + change (Int64.neg Int64.one) with Int64.mone. + rewrite Int64.and_commut. + rewrite Int64.and_mone. + rewrite Int64.sub_idem. + rewrite Int64.and_commut. + rewrite Int64.and_zero. + apply Int64.or_zero. +Qed. + +Lemma bitwise_select_long_false : + forall vtrue vfalse, + bitwise_select_long Int64.zero vtrue vfalse = vfalse. +Proof. + intros. unfold bitwise_select_long. cbn. + rewrite Int64.neg_zero. + rewrite Int64.and_commut. + rewrite Int64.and_zero. + rewrite Int64.sub_zero_r. + change (Int64.neg Int64.one) with Int64.mone. + rewrite Int64.and_commut. + rewrite Int64.and_mone. + rewrite Int64.or_commut. + apply Int64.or_zero. +Qed. + +Definition select01_long (vb : val) (vtrue : val) (vfalse : val) : val := + match vb with + | (Vint b) => + if Int.eq b Int.one + then vtrue + else if Int.eq b Int.zero + then vfalse + else Vundef + | _ => Vundef + end. + +Lemma normalize_select01: + forall x y z, Val.normalize (select01_long x y z) AST.Tlong = select01_long x (Val.normalize y AST.Tlong) (Val.normalize z AST.Tlong). +Proof. + unfold select01_long. + intros. + destruct x; cbn; trivial. + destruct (Int.eq i Int.one); trivial. + destruct (Int.eq i Int.zero); trivial. +Qed. + +Lemma select01_long_true: + forall vt vf, + select01_long Vtrue vt vf = vt. +Proof. + intros. unfold select01_long. cbn. + rewrite Int.eq_true. reflexivity. +Qed. + +Lemma select01_long_false: + forall vt vf, + select01_long Vfalse vt vf = vf. +Proof. + intros. unfold select01_long. cbn. + rewrite Int.eq_true. + rewrite Int.eq_false. reflexivity. + cbv. discriminate. +Qed. + +Lemma float_bits_normalize: + forall v1, + ExtValues.float_of_bits (Val.normalize (ExtValues.bits_of_float v1) AST.Tlong) = + Val.normalize v1 AST.Tfloat. +Proof. + destruct v1; cbn; trivial. + f_equal. + apply Float.of_to_bits. +Qed. + +Lemma single_bits_normalize: + forall v1, + ExtValues.single_of_bits (Val.normalize (ExtValues.bits_of_single v1) AST.Tint) = + Val.normalize v1 AST.Tsingle. +Proof. + destruct v1; cbn; trivial. + f_equal. + apply Float32.of_to_bits. +Qed. diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 117bbcb4..7d66cbb8 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -87,6 +87,45 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c + | OEseqw _ => op2 (default nv) + | OEsnew _ => op2 (default nv) + | OEsequw _ => op2 (default nv) + | OEsneuw _ => op2 (default nv) + | OEsltw _ => op2 (default nv) + | OEsltuw _ => op2 (default nv) + | OEsltiw _ => op1 (default nv) + | OEsltiuw _ => op1 (default nv) + | OExoriw _ => op1 (bitwise nv) + | OEluiw _ => op1 (default nv) + | OEaddiw _ _ => op1 (default nv) + | OEandiw n => op1 (andimm nv n) + | OEoriw n => op1 (orimm nv n) + | OEseql _ => op2 (default nv) + | OEsnel _ => op2 (default nv) + | OEsequl _ => op2 (default nv) + | OEsneul _ => op2 (default nv) + | OEsltl _ => op2 (default nv) + | OEsltul _ => op2 (default nv) + | OEsltil _ => op1 (default nv) + | OEsltiul _ => op1 (default nv) + | OExoril _ => op1 (default nv) + | OEluil _ => op1 (default nv) + | OEaddil _ _ => op1 (default nv) + | OEandil _ => op1 (default nv) + | OEoril _ => op1 (default nv) + | OEloadli _ => op1 (default nv) + | OEmayundef _ => op2 (default nv) + | OEfeqd => op2 (default nv) + | OEfltd => op2 (default nv) + | OEfled => op2 (default nv) + | OEfeqs => op2 (default nv) + | OEflts => op2 (default nv) + | OEfles => op2 (default nv) + | Obits_of_single => op1 (default nv) + | Obits_of_float => op1 (default nv) + | Osingle_of_bits => op1 (default nv) + | Ofloat_of_bits => op1 (default nv) + | Oselectl => All :: nv :: nv :: nil end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -154,6 +193,27 @@ Proof. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. +- fold (Val.and (Vint n) v0); + fold (Val.and (Vint n) v2); + rewrite (Val.and_commut (Vint n) v0); + rewrite (Val.and_commut (Vint n) v2); + apply andimm_sound; auto. +- fold (Val.or (Vint n) v0); + fold (Val.or (Vint n) v2); + rewrite (Val.or_commut (Vint n) v0); + rewrite (Val.or_commut (Vint n) v2); + apply orimm_sound; auto. +- apply xor_sound; auto with na. +- (* selectl *) + unfold ExtValues.select01_long. + destruct v0; auto with na. + assert (Val.lessdef (Vint i) v4) as LESSDEF by auto with na. + inv LESSDEF. + destruct (Int.eq i Int.one). + { apply normalize_sound; auto. } + destruct (Int.eq i Int.zero). + { apply normalize_sound; auto. } + cbn. auto with na. Qed. Lemma operation_is_redundant_sound: @@ -32,11 +32,18 @@ Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. +Require ExtValues. Set Implicit Arguments. (** Conditions (boolean-valued operators). *) +(** Type to modelize the use of a special register in arith operations *) + +Inductive oreg: Type := + | X0_L: oreg + | X0_R: oreg. + Inductive condition : Type := | Ccomp (c: comparison) (**r signed integer comparison *) | Ccompu (c: comparison) (**r unsigned integer comparison *) @@ -49,7 +56,32 @@ Inductive condition : Type := | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) - | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) + | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *) + (* Expansed branches *) + | CEbeqw (optR: option oreg) (**r branch-if-equal signed *) + | CEbnew (optR: option oreg) (**r branch-if-not-equal signed *) + | CEbequw (optR: option oreg) (**r branch-if-equal unsigned *) + | CEbneuw (optR: option oreg) (**r branch-if-not-equal unsigned *) + | CEbltw (optR: option oreg) (**r branch-if-less signed *) + | CEbltuw (optR: option oreg) (**r branch-if-less unsigned *) + | CEbgew (optR: option oreg) (**r branch-if-greater-or-equal signed *) + | CEbgeuw (optR: option oreg) (**r branch-if-greater-or-equal unsigned *) + | CEbeql (optR: option oreg) (**r branch-if-equal signed *) + | CEbnel (optR: option oreg) (**r branch-if-not-equal signed *) + | CEbequl (optR: option oreg) (**r branch-if-equal unsigned *) + | CEbneul (optR: option oreg) (**r branch-if-not-equal unsigned *) + | CEbltl (optR: option oreg) (**r branch-if-less signed *) + | CEbltul (optR: option oreg) (**r branch-if-less unsigned *) + | CEbgel (optR: option oreg) (**r branch-if-greater-or-equal signed *) + | CEbgeul (optR: option oreg). (**r branch-if-greater-or-equal unsigned *) + +(* This type will define the eval function of a OEmayundef operation. *) + +Inductive mayundef: Type := + | MUint: mayundef + | MUlong: mayundef + | MUshrx: int -> mayundef + | MUshrxl: int -> mayundef. (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -152,7 +184,47 @@ Inductive operation : Type := | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) (*c Boolean tests: *) - | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + (* Expansed conditions *) + | OEseqw (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) + | OEsnew (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) + | OEsequw (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneuw (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltw (optR: option oreg) (**r set-less-than *) + | OEsltuw (optR: option oreg) (**r set-less-than unsigned *) + | OEsltiw (n: int) (**r set-less-than immediate *) + | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) + | OEaddiw (optR: option oreg) (n: int) (**r add immediate *) + | OEandiw (n: int) (**r and immediate *) + | OEoriw (n: int) (**r or immediate *) + | OExoriw (n: int) (**r xor immediate *) + | OEluiw (n: int) (**r load upper-immediate *) + | OEseql (optR: option oreg) (**r [rd <- rs1 == rs2] signed *) + | OEsnel (optR: option oreg) (**r [rd <- rs1 != rs2] signed *) + | OEsequl (optR: option oreg) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneul (optR: option oreg) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltl (optR: option oreg) (**r set-less-than *) + | OEsltul (optR: option oreg) (**r set-less-than unsigned *) + | OEsltil (n: int64) (**r set-less-than immediate *) + | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) + | OEaddil (optR: option oreg) (n: int64) (**r add immediate *) + | OEandil (n: int64) (**r and immediate *) + | OEoril (n: int64) (**r or immediate *) + | OExoril (n: int64) (**r xor immediate *) + | OEluil (n: int64) (**r load upper-immediate *) + | OEloadli (n: int64) (**r load an immediate int64 *) + | OEmayundef (mu: mayundef) + | OEfeqd (**r compare equal *) + | OEfltd (**r compare less-than *) + | OEfled (**r compare less-than/equal *) + | OEfeqs (**r compare equal *) + | OEflts (**r compare less-than *) + | OEfles (**r compare less-than/equal *) + | Obits_of_single + | Obits_of_float + | Osingle_of_bits + | Ofloat_of_bits + | Oselectl. (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -164,11 +236,15 @@ Inductive addressing: Type := (** Comparison functions (used in modules [CSE] and [Allocation]). *) +Definition oreg_eq: forall (x y: oreg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + Definition eq_condition (x y: condition) : {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec; intro. + generalize Int.eq_dec Int64.eq_dec bool_dec oreg_eq; intros. assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. decide equality. + all: destruct optR, optR0; decide equality. Defined. Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. @@ -179,8 +255,9 @@ Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec Val.eq oreg_eq; intros. decide equality. + all: try destruct optR, optR0; try decide equality. Defined. (* Alternate definition: @@ -197,6 +274,44 @@ Defined. Global Opaque eq_condition eq_addressing eq_operation. +(** Generic function to evaluate an instruction according to the given specific register *) + +Definition zero32 := (Vint Int.zero). +Definition zero64 := (Vlong Int64.zero). + +Definition apply_bin_oreg {B} (optR: option oreg) (sem: val -> val -> B) (v1 v2 vz: val): B := + match optR with + | None => sem v1 v2 + | Some X0_L => sem vz v1 + | Some X0_R => sem v1 vz + end. + +(** Mayundef evaluation according to the above defined type *) + +Definition eval_may_undef (mu: mayundef) (v1 v2: val): val := + match mu with + | MUint => match v1, v2 with + | Vint _, Vint _ => v2 + | _, _ => Vundef + end + | MUlong => match v1, v2 with + | Vlong _, Vint _ => v2 + | _, _ => Vundef + end + | MUshrx i => + match v1, v2 with + | Vint _, Vint _ => + if Int.ltu i (Int.repr 31) then v2 else Vundef + | _, _ => Vundef + end + | MUshrxl i => + match v1, v2 with + | Vlong _, Vlong _ => + if Int.ltu i (Int.repr 63) then v2 else Vundef + | _, _ => Vundef + end + end. + (** * Evaluation functions *) (** Evaluation of conditions, operators and addressing modes applied @@ -218,9 +333,34 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) + (* Expansed branches *) + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 | _, _ => None end. +(** Assert sp is a pointer *) + +Definition get_sp sp := + match sp with + | Vptr _ _ => sp + | _ => Vundef + end. + Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := @@ -317,7 +457,49 @@ Definition eval_operation | Olonguofsingle, v1::nil => Some (Val.maketotal (Val.longuofsingle v1)) | Osingleoflong, v1::nil => Some (Val.maketotal (Val.singleoflong v1)) | Osingleoflongu, v1::nil => Some (Val.maketotal (Val.singleoflongu v1)) + | Obits_of_single, v1::nil => Some (ExtValues.bits_of_single v1) + | Obits_of_float, v1::nil => Some (ExtValues.bits_of_float v1) + | Osingle_of_bits, v1::nil => Some (ExtValues.single_of_bits v1) + | Ofloat_of_bits, v1::nil => Some (ExtValues.float_of_bits v1) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) + (* Expansed conditions *) + | OEseqw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmp Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => Some (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) + | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) + | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) + | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) + | OEluiw n, nil => Some (Val.shl (Vint n) (Vint (Int.repr 12))) + | OEaddiw optR n, nil => Some (apply_bin_oreg optR Val.add (Vint n) Vundef zero32) + | OEaddiw optR n, v1::nil => Some (apply_bin_oreg optR Val.add v1 (Vint n) Vundef) + | OEandiw n, v1::nil => Some (Val.and (Vint n) v1) + | OEoriw n, v1::nil => Some (Val.or (Vint n) v1) + | OEseql optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Ceq) v1 v2 zero64)) + | OEsnel optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Cne) v1 v2 zero64)) + | OEsequl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) + | OEsneul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) + | OEsltl optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmpl Clt) v1 v2 zero64)) + | OEsltul optR, v1::v2::nil => Some (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) + | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) + | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) + | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | OEluil n, nil => Some (Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12)))) + | OEaddil optR n, nil => Some (apply_bin_oreg optR Val.addl (Vlong n) Vundef zero64) + | OEaddil optR n, v1::nil => Some (apply_bin_oreg optR Val.addl v1 (Vlong n) Vundef) + | OEandil n, v1::nil => Some (Val.andl (Vlong n) v1) + | OEoril n, v1::nil => Some (Val.orl (Vlong n) v1) + | OEloadli n, nil => Some (Vlong n) + | OEmayundef mu, v1 :: v2 :: nil => Some (eval_may_undef mu v1 v2) + | OEfeqd, v1::v2::nil => Some (Val.cmpf Ceq v1 v2) + | OEfltd, v1::v2::nil => Some (Val.cmpf Clt v1 v2) + | OEfled, v1::v2::nil => Some (Val.cmpf Cle v1 v2) + | OEfeqs, v1::v2::nil => Some (Val.cmpfs Ceq v1 v2) + | OEflts, v1::v2::nil => Some (Val.cmpfs Clt v1 v2) + | OEfles, v1::v2::nil => Some (Val.cmpfs Cle v1 v2) + | Oselectl, vb::vt::vf::nil => Some (Val.normalize (ExtValues.select01_long vb vt vf) Tlong) | _, _ => None end. @@ -348,9 +530,9 @@ Qed. Ltac FuncInv := match goal with | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => - destruct x; simpl in H; FuncInv + destruct x; cbn in H; FuncInv | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => - destruct v; simpl in H; FuncInv + destruct v; cbn in H; FuncInv | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => destruct Archi.ptr64 eqn:?; FuncInv | H: (Some _ = Some _) |- _ => @@ -377,6 +559,31 @@ Definition type_of_condition (c: condition) : list typ := | Cnotcompf _ => Tfloat :: Tfloat :: nil | Ccompfs _ => Tsingle :: Tsingle :: nil | Cnotcompfs _ => Tsingle :: Tsingle :: nil + | CEbeqw _ => Tint :: Tint :: nil + | CEbnew _ => Tint :: Tint :: nil + | CEbequw _ => Tint :: Tint :: nil + | CEbneuw _ => Tint :: Tint :: nil + | CEbltw _ => Tint :: Tint :: nil + | CEbltuw _ => Tint :: Tint :: nil + | CEbgew _ => Tint :: Tint :: nil + | CEbgeuw _ => Tint :: Tint :: nil + | CEbeql _ => Tlong :: Tlong :: nil + | CEbnel _ => Tlong :: Tlong :: nil + | CEbequl _ => Tlong :: Tlong :: nil + | CEbneul _ => Tlong :: Tlong :: nil + | CEbltl _ => Tlong :: Tlong :: nil + | CEbltul _ => Tlong :: Tlong :: nil + | CEbgel _ => Tlong :: Tlong :: nil + | CEbgeul _ => Tlong :: Tlong :: nil + end. + +(** The type of mayundef and addsp is dynamic *) + +Definition type_of_mayundef mu := + match mu with + | MUint | MUshrx _ => (Tint :: Tint :: nil, Tint) + | MUlong => (Tlong :: Tint :: nil, Tint) + | MUshrxl _ => (Tlong :: Tlong :: nil, Tlong) end. Definition type_of_operation (op: operation) : list typ * typ := @@ -474,6 +681,47 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) + | OEseqw _ => (Tint :: Tint :: nil, Tint) + | OEsnew _ => (Tint :: Tint :: nil, Tint) + | OEsequw _ => (Tint :: Tint :: nil, Tint) + | OEsneuw _ => (Tint :: Tint :: nil, Tint) + | OEsltw _ => (Tint :: Tint :: nil, Tint) + | OEsltuw _ => (Tint :: Tint :: nil, Tint) + | OEsltiw _ => (Tint :: nil, Tint) + | OEsltiuw _ => (Tint :: nil, Tint) + | OExoriw _ => (Tint :: nil, Tint) + | OEluiw _ => (nil, Tint) + | OEaddiw None _ => (Tint :: nil, Tint) + | OEaddiw (Some _) _ => (nil, Tint) + | OEandiw _ => (Tint :: nil, Tint) + | OEoriw _ => (Tint :: nil, Tint) + | OEseql _ => (Tlong :: Tlong :: nil, Tint) + | OEsnel _ => (Tlong :: Tlong :: nil, Tint) + | OEsequl _ => (Tlong :: Tlong :: nil, Tint) + | OEsneul _ => (Tlong :: Tlong :: nil, Tint) + | OEsltl _ => (Tlong :: Tlong :: nil, Tint) + | OEsltul _ => (Tlong :: Tlong :: nil, Tint) + | OEsltil _ => (Tlong :: nil, Tint) + | OEsltiul _ => (Tlong :: nil, Tint) + | OEandil _ => (Tlong :: nil, Tlong) + | OEoril _ => (Tlong :: nil, Tlong) + | OExoril _ => (Tlong :: nil, Tlong) + | OEluil _ => (nil, Tlong) + | OEaddil None _ => (Tlong :: nil, Tlong) + | OEaddil (Some _) _ => (nil, Tlong) + | OEloadli _ => (nil, Tlong) + | OEmayundef mu => type_of_mayundef mu + | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) + | OEfltd => (Tfloat :: Tfloat :: nil, Tint) + | OEfled => (Tfloat :: Tfloat :: nil, Tint) + | OEfeqs => (Tsingle :: Tsingle :: nil, Tint) + | OEflts => (Tsingle :: Tsingle :: nil, Tint) + | OEfles => (Tsingle :: Tsingle :: nil, Tint) + | Obits_of_single => (Tsingle :: nil, Tint) + | Obits_of_float => (Tfloat :: nil, Tlong) + | Osingle_of_bits => (Tint :: nil, Tsingle) + | Ofloat_of_bits => (Tlong :: nil, Tfloat) + | Oselectl => (Tint :: Tlong :: Tlong :: nil, Tlong) end. Definition type_of_addressing (addr: addressing) : list typ := @@ -504,6 +752,14 @@ Proof. intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. Qed. +Remark type_mayundef: + forall mu v1 v2, Val.has_type (eval_may_undef mu v1 v2) (snd (type_of_mayundef mu)). +Proof. + intros. unfold eval_may_undef. + destruct mu eqn:EQMU, v1, v2; simpl; auto. + all: destruct Int.ltu; simpl; auto. +Qed. + Lemma type_of_operation_sound: forall op vl sp v m, op <> Omove -> @@ -513,7 +769,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). intros. destruct op; simpl; simpl in H0; FuncInv; subst; simpl. (* move *) - - congruence. + - simpl in H; congruence. (* intconst, longconst, floatconst, singleconst *) - exact I. - exact I. @@ -680,6 +936,110 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m)... destruct b... + (* OEseqw *) + - destruct optR as [[]|]; simpl; unfold Val.cmp; + destruct Val.cmp_bool... all: destruct b... + (* OEsnew *) + - destruct optR as [[]|]; simpl; unfold Val.cmp; + destruct Val.cmp_bool... all: destruct b... + (* OEsequw *) + - destruct optR as [[]|]; simpl; unfold Val.cmpu; + destruct Val.cmpu_bool... all: destruct b... + (* OEsneuw *) + - destruct optR as [[]|]; simpl; unfold Val.cmpu; + destruct Val.cmpu_bool... all: destruct b... + (* OEsltw *) + - destruct optR as [[]|]; simpl; unfold Val.cmp; + destruct Val.cmp_bool... all: destruct b... + (* OEsltuw *) + - destruct optR as [[]|]; simpl; unfold Val.cmpu; + destruct Val.cmpu_bool... all: destruct b... + (* OEsltiw *) + - unfold Val.cmp; destruct Val.cmp_bool... + all: destruct b... + (* OEsltiuw *) + - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... + (* OEaddiw *) + - destruct optR as [[]|]; simpl in *; trivial. + - destruct optR as [[]|]; simpl in *; trivial; + apply type_add. + (* OEandiw *) + - destruct v0... + (* OEoriw *) + - destruct v0... + (* OExoriw *) + - destruct v0... + (* OEluiw *) + - destruct (Int.ltu _ _); cbn; trivial. + (* OEseql *) + - destruct optR as [[]|]; simpl; unfold Val.cmpl; + destruct Val.cmpl_bool... all: destruct b... + (* OEsnel *) + - destruct optR as [[]|]; simpl; unfold Val.cmpl; + destruct Val.cmpl_bool... all: destruct b... + (* OEsequl *) + - destruct optR as [[]|]; simpl; unfold Val.cmplu; + destruct Val.cmplu_bool... all: destruct b... + (* OEsneul *) + - destruct optR as [[]|]; simpl; unfold Val.cmplu; + destruct Val.cmplu_bool... all: destruct b... + (* OEsltl *) + - destruct optR as [[]|]; simpl; unfold Val.cmpl; + destruct Val.cmpl_bool... all: destruct b... + (* OEsltul *) + - destruct optR as [[]|]; simpl; unfold Val.cmplu; + destruct Val.cmplu_bool... all: destruct b... + (* OEsltil *) + - unfold Val.cmpl; destruct Val.cmpl_bool... + all: destruct b... + (* OEsltiul *) + - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... + (* OEaddil *) + - destruct optR as [[]|]; simpl in *; trivial. + - destruct optR as [[]|]; simpl in *; trivial; + apply type_addl. + (* OEandil *) + - destruct v0... + (* OEoril *) + - destruct v0... + (* OExoril *) + - destruct v0... + (* OEluil *) + - simpl; trivial. + (* OEloadli *) + - trivial. + (* OEmayundef *) + - apply type_mayundef. + (* OEfeqd *) + - destruct v0; destruct v1; cbn; auto. + destruct Float.cmp; cbn; auto. + (* OEfltd *) + - destruct v0; destruct v1; cbn; auto. + destruct Float.cmp; cbn; auto. + (* OEfled *) + - destruct v0; destruct v1; cbn; auto. + destruct Float.cmp; cbn; auto. + (* OEfeqs *) + - destruct v0; destruct v1; cbn; auto. + destruct Float32.cmp; cbn; auto. + (* OEflts *) + - destruct v0; destruct v1; cbn; auto. + destruct Float32.cmp; cbn; auto. + (* OEfles *) + - destruct v0; destruct v1; cbn; auto. + destruct Float32.cmp; cbn; auto. + (* Bits_of_single, float *) + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. + (* single, float of bits *) + - destruct v0; cbn; trivial. + - destruct v0; cbn; trivial. + (* selectl *) + - destruct v0; cbn; trivial. + destruct Int.eq; cbn. + apply Val.normalize_type. + destruct Int.eq; cbn; trivial. + apply Val.normalize_type. Qed. (* This should not be simplified to "false" because it breaks proofs elsewhere. *) @@ -701,11 +1061,14 @@ Lemma is_trapping_op_sound: eval_operation genv sp op vl m <> None. Proof. unfold args_of_operation. - destruct op; destruct eq_operation; intros; simpl in *; try congruence. + destruct op eqn:E; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). + all: try destruct optR as [[]|]; simpl in H0; try discriminate. + all: try destruct Archi.ptr64; simpl in *; try discriminate. + all: try destruct mu; simpl in *; try discriminate. Qed. End SOUNDNESS. @@ -749,6 +1112,22 @@ Definition negate_condition (cond: condition): condition := | Cnotcompf c => Ccompf c | Ccompfs c => Cnotcompfs c | Cnotcompfs c => Ccompfs c + | CEbeqw optR => CEbnew optR + | CEbnew optR => CEbeqw optR + | CEbequw optR => CEbneuw optR + | CEbneuw optR => CEbequw optR + | CEbltw optR => CEbgew optR + | CEbltuw optR => CEbgeuw optR + | CEbgew optR => CEbltw optR + | CEbgeuw optR => CEbltuw optR + | CEbeql optR => CEbnel optR + | CEbnel optR => CEbeql optR + | CEbequl optR => CEbneul optR + | CEbneul optR => CEbequl optR + | CEbltl optR => CEbgel optR + | CEbltul optR => CEbgeul optR + | CEbgel optR => CEbltl optR + | CEbgeul optR => CEbltul optR end. Lemma eval_negate_condition: @@ -768,6 +1147,39 @@ Proof. repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. repeat (destruct vl; auto). repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. + + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR as [[]|]; + apply Val.negate_cmplu_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR as [[]|]; + apply Val.negate_cmplu_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR as [[]|]; + apply Val.negate_cmplu_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR as [[]|]; + apply Val.negate_cmplu_bool. Qed. (** Shifting stack-relative references. This is used in [Stacking]. *) @@ -793,7 +1205,8 @@ Qed. Lemma type_shift_stack_operation: forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. Proof. - intros. destruct op; auto. + intros. destruct op; auto; + try destruct optR as [[]|]; simpl; auto. Qed. Lemma eval_shift_stack_addressing: @@ -810,7 +1223,7 @@ Lemma eval_shift_stack_operation: eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. Proof. - intros. destruct op; simpl; auto. destruct vl; auto. + intros. destruct op eqn:E; simpl; auto; destruct vl; auto. rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. Qed. @@ -864,12 +1277,28 @@ Definition cond_depends_on_memory (cond : condition) : bool := | Ccompuimm _ _ => negb Archi.ptr64 | Ccomplu _ => Archi.ptr64 | Ccompluimm _ _ => Archi.ptr64 + | CEbequw _ => negb Archi.ptr64 + | CEbneuw _ => negb Archi.ptr64 + | CEbltuw _ => negb Archi.ptr64 + | CEbgeuw _ => negb Archi.ptr64 + | CEbequl _ => Archi.ptr64 + | CEbneul _ => Archi.ptr64 + | CEbltul _ => Archi.ptr64 + | CEbgeul _ => Archi.ptr64 | _ => false end. Definition op_depends_on_memory (op: operation) : bool := match op with | Ocmp cmp => cond_depends_on_memory cmp + | OEsequw _ => negb Archi.ptr64 + | OEsneuw _ => negb Archi.ptr64 + | OEsltiuw _ => negb Archi.ptr64 + | OEsltuw _ => negb Archi.ptr64 + | OEsequl _ => Archi.ptr64 + | OEsneul _ => Archi.ptr64 + | OEsltul _ => Archi.ptr64 + | OEsltiul _ => Archi.ptr64 | _ => false end. @@ -893,6 +1322,11 @@ Proof. intros until m2. destruct op; simpl; try congruence. intro DEPEND. f_equal. f_equal. apply cond_depends_on_memory_correct; trivial. + all: intros; repeat (destruct args; auto); + unfold Val.cmpu, Val.cmpu_bool, Val.cmplu, Val.cmplu_bool; + try destruct optR as [[]|]; simpl; + destruct v; try destruct v0; simpl; auto; + try apply negb_false_iff in H; try rewrite H; auto. Qed. Lemma cond_valid_pointer_eq: @@ -902,7 +1336,9 @@ Lemma cond_valid_pointer_eq: Proof. intros until m2. intro MEM. destruct cond eqn:COND; simpl; try congruence. all: repeat (destruct args; simpl; try congruence); - erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + try destruct optR as [[]|]; simpl; + try destruct v, v0; try rewrite !MEM; auto; + try erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. Lemma op_valid_pointer_eq: @@ -911,8 +1347,11 @@ Lemma op_valid_pointer_eq: eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. intros until m2. destruct op; simpl; try congruence. - intros MEM; destruct cond; repeat (destruct args; simpl; try congruence); - erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + intro MEM; erewrite cond_valid_pointer_eq; eauto. + all: intros MEM; repeat (destruct args; simpl; try congruence); + try destruct optR as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; + unfold Val.cmpu, Val.cmplu; + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1019,6 +1458,90 @@ Ltac InvInject := | _ => idtac end. +Lemma eval_cmpu_bool_inj': forall b c v v' v0 v0', + Val.inject f v v' -> + Val.inject f v0 v0' -> + Val.cmpu_bool (Mem.valid_pointer m1) c v v0 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m2) c v' v0' = Some b. +Proof. + intros. + eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +Qed. + +Lemma eval_cmpu_bool_inj: forall c v v' v0 v'0, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (Val.cmpu (Mem.valid_pointer m1) c v v0) + (Val.cmpu (Mem.valid_pointer m2) c v' v'0). +Proof. + intros until v'0. intros HV1 HV2. + unfold Val.cmpu; + destruct (Val.cmpu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto. + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + +Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) + (apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). +Proof. + intros until optR. intros HV1 HV2. + destruct optR as [[]|]; simpl; unfold zero32, Val.cmpu; + destruct (Val.cmpu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; + assert (HVI: Val.inject f (Vint Int.zero) (Vint Int.zero)) by apply Val.inject_int. + + exploit eval_cmpu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmpu_bool_inj'. eapply HV1. instantiate (1:=v'0). + eauto. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + +Lemma eval_cmplu_bool_inj': forall b c v v' v0 v0', + Val.inject f v v' -> + Val.inject f v0 v0' -> + Val.cmplu_bool (Mem.valid_pointer m1) c v v0 = Some b -> + Val.cmplu_bool (Mem.valid_pointer m2) c v' v0' = Some b. +Proof. + intros. + eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +Qed. + +Lemma eval_cmplu_bool_inj: forall c v v' v0 v'0, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (Val.maketotal (Val.cmplu (Mem.valid_pointer m1) c v v0)) + (Val.maketotal (Val.cmplu (Mem.valid_pointer m2) c v' v'0)). +Proof. + intros until v'0. intros HV1 HV2. + unfold Val.cmplu; + destruct (Val.cmplu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto. + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + +Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) + (Val.maketotal (apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). +Proof. + intros until optR. intros HV1 HV2. + destruct optR as [[]|]; simpl; unfold zero64, Val.cmplu; + destruct (Val.cmplu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; + assert (HVI: Val.inject f (Vlong Int64.zero) (Vlong Int64.zero)) by apply Val.inject_long. + + exploit eval_cmplu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmplu_bool_inj'. eapply HV1. instantiate (1:=v'0). + eauto. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + Lemma eval_condition_inj: forall cond vl1 vl2 b, Val.inject_list f vl1 vl2 -> @@ -1026,6 +1549,9 @@ Lemma eval_condition_inj: eval_condition cond vl2 m2 = Some b. Proof. intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + all: assert (HVI32: Val.inject f (Vint Int.zero) (Vint Int.zero)) by apply Val.inject_int; + assert (HVI64: Val.inject f (Vlong Int64.zero) (Vlong Int64.zero)) by apply Val.inject_long; + try unfold zero32, zero64. - inv H3; inv H2; simpl in H0; inv H0; auto. - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. - inv H3; simpl in H0; inv H0; auto. @@ -1038,6 +1564,38 @@ Proof. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmplu_bool_inj'; eauto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmplu_bool_inj'; eauto. +- destruct optR as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmplu_bool_inj'; eauto. +- destruct optR as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR as [[]|]; unfold apply_bin_oreg in *; + eapply eval_cmplu_bool_inj'; eauto. Qed. Ltac TrivialExists := @@ -1183,7 +1741,7 @@ Proof. (* shru, shruimm *) - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shrx *) + (* shrx *) - inv H4; cbn; try apply Val.val_inject_undef. destruct (Int.ltu n (Int.repr 63)); cbn. apply Val.inject_long. @@ -1246,6 +1804,109 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + (* OEseqw *) + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; + inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsnew *) + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; + inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsequw *) + - apply eval_cmpu_bool_inj_opt; auto. + (* OEsneuw *) + - apply eval_cmpu_bool_inj_opt; auto. + (* OEsltw *) + - destruct optR as [[]|]; simpl; unfold zero32, Val.cmp; + inv H4; inv H2; simpl; try destruct (Int.lt _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsltuw *) + - apply eval_cmpu_bool_inj_opt; auto. + (* OEsltiw *) + - inv H4; simpl; cbn; auto; try destruct (Int.lt _ _); apply Val.inject_int. + (* OEsltiuw *) + - apply eval_cmpu_bool_inj; auto. + (* OEaddiw *) + - destruct optR as [[]|]; auto; simpl. + rewrite Int.add_zero_l; auto. + rewrite Int.add_commut, Int.add_zero_l; auto. + - destruct optR as [[]|]; auto; simpl; + eapply Val.add_inject; auto. + (* OEandiw *) + - inv H4; cbn; auto. + (* OEoriw *) + - inv H4; cbn; auto. + (* OExoriw *) + - inv H4; simpl; auto. + (* OEluiw *) + - destruct (Int.ltu _ _); auto. + (* OEseql *) + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; + inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsnel *) + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; + inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsequl *) + - apply eval_cmplu_bool_inj_opt; auto. + (* OEsneul *) + - apply eval_cmplu_bool_inj_opt; auto. + (* OEsltl *) + - destruct optR as [[]|]; simpl; unfold zero64, Val.cmpl; + inv H4; inv H2; simpl; try destruct (Int64.lt _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsltul *) + - apply eval_cmplu_bool_inj_opt; auto. + (* OEsltil *) + - inv H4; simpl; cbn; auto; try destruct (Int64.lt _ _); apply Val.inject_int. + (* OEsltiul *) + - apply eval_cmplu_bool_inj; auto. + (* OEaddil *) + - destruct optR as [[]|]; auto; simpl. + rewrite Int64.add_zero_l; auto. + rewrite Int64.add_commut, Int64.add_zero_l; auto. + - destruct optR as [[]|]; auto; simpl; + eapply Val.addl_inject; auto. + (* OEandil *) + - inv H4; cbn; auto. + (* OEoril *) + - inv H4; cbn; auto. + (* OExoril *) + - inv H4; simpl; auto. + (* OEmayundef *) + - destruct mu; inv H4; inv H2; simpl; auto; + try destruct (Int.ltu _ _); simpl; auto. + all: eapply Val.inject_ptr; eauto. + (* OEfeqd *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfltd *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfled *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfeqs *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float32.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEflts *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float32.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfles *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float32.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* Bits_of_single, double *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* single, double of bits *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* selectl *) + - inv H4; trivial. cbn. + destruct (Int.eq i Int.one). + + auto using Val.normalize_inject. + + destruct (Int.eq i Int.zero); cbn; auto using Val.normalize_inject. Qed. Lemma eval_addressing_inj: @@ -1503,4 +2164,4 @@ Definition builtin_arg_ok match ba with | (BA _ | BA_splitlong (BA _) (BA _)) => true | _ => builtin_arg_ok_1 ba c - end. + end. diff --git a/riscV/OpWeights.ml b/riscV/OpWeights.ml index 75a913c6..0a1d9ad4 100644 --- a/riscV/OpWeights.ml +++ b/riscV/OpWeights.ml @@ -1,161 +1,168 @@ -open Op;; -open PrepassSchedulingOracleDeps;; - -module Rocket = - struct - (* Attempt at modeling the Rocket core *) - - let resource_bounds = [| 1 |];; - let nr_non_pipelined_units = 1;; (* divider *) - - let latency_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> 4 - - | Onegf -> 1 (*r [rd = - r1] *) - | Oabsf (*r [rd = abs(r1)] *) - | Oaddf (*r [rd = r1 + r2] *) - | Osubf (*r [rd = r1 - r2] *) - | Omulf -> 6 (*r [rd = r1 * r2] *) - | Onegfs -> 1 (*r [rd = - r1] *) - | Oabsfs (*r [rd = abs(r1)] *) - | Oaddfs (*r [rd = r1 + r2] *) - | Osubfs (*r [rd = r1 - r2] *) - | Omulfs -> 4 (*r [rd = r1 * r2] *) - | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle -> 4 (*r [rd] is [r1] extended to double-precision float *) - (*c Conversions between int and float: *) - | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) - | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) - | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) - | Ofloatofintu -> 6 (*r [rd = float64_of_unsigned_int(r1)] *) - | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) - | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) - | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) - | Osingleofintu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) - | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) - | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) - | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) - | Ofloatoflongu -> 6 (*r [rd = float64_of_unsigned_long(r1)] *) - | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) - | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) - | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) - | Osingleoflongu -> 4 (*r [rd = float32_of_unsigned_int(r1)] *) - - | Odiv | Odivu | Odivl | Odivlu -> 16 - | Odivfs -> 35 - | Odivf -> 50 - - | Ocmp cond -> - (match cond with - | Ccomp _ - | Ccompu _ - | Ccompimm _ - | Ccompuimm _ - | Ccompl _ - | Ccomplu _ - | Ccomplimm _ - | Ccompluimm _ -> 1 - | Ccompf _ - | Cnotcompf _ -> 6 - | Ccompfs _ - | Cnotcompfs _ -> 4) - | _ -> 1;; - - let resources_of_op (op : operation) (nargs : int) = resource_bounds;; - - let non_pipelined_resources_of_op (op : operation) (nargs : int) = - match op with - | Odiv | Odivu -> [| 29 |] - | Odivfs -> [| 20 |] - | Odivl | Odivlu | Odivf -> [| 50 |] - | _ -> [| -1 |];; - - let resources_of_cond (cond : condition) (nargs : int) = resource_bounds;; - - let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; - let latency_of_call _ _ = 6;; - - let resources_of_load trap chunk addressing nargs = resource_bounds;; - - let resources_of_store chunk addressing nargs = resource_bounds;; - - let resources_of_call _ _ = resource_bounds;; - let resources_of_builtin _ = resource_bounds;; - end;; - -module SweRV_EH1 = - struct - (* Attempt at modeling SweRV EH1 - [| issues ; LSU ; multiplier |] *) - let resource_bounds = [| 2 ; 1; 1 |];; - let nr_non_pipelined_units = 1;; (* divider *) - - let latency_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> 3 - | Odiv | Odivu | Odivl | Odivlu -> 16 - | _ -> 1;; - - let resources_of_op (op : operation) (nargs : int) = - match op with - | Omul | Omulhs | Omulhu - | Omull | Omullhs | Omullhu -> [| 1 ; 0 ; 1 |] - | Odiv | Odivu | Odivl | Odivlu -> [| 0 ; 0; 0 |] - | _ -> [| 1; 0; 0; 0 |];; - - let non_pipelined_resources_of_op (op : operation) (nargs : int) = - match op with - | Odiv | Odivu -> [| 29 |] - | Odivfs -> [| 20 |] - | Odivl | Odivlu | Odivf -> [| 50 |] - | _ -> [| -1 |];; - - let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |];; - - let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3;; - let latency_of_call _ _ = 6;; - - let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |];; - - let resources_of_store chunk addressing nargs = [| 1; 1; 0 |];; - - let resources_of_call _ _ = resource_bounds;; - let resources_of_builtin _ = resource_bounds;; - end;; +open Op +open PrepassSchedulingOracleDeps + +module Rocket = struct + (* Attempt at modeling the Rocket core *) + + let resource_bounds = [| 1 |] + + let nr_non_pipelined_units = 1 + + (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> 4 + | Onegf -> 1 (*r [rd = - r1] *) + | Oabsf (*r [rd = abs(r1)] *) + | Oaddf (*r [rd = r1 + r2] *) + | Osubf (*r [rd = r1 - r2] *) + | Omulf -> + 6 (*r [rd = r1 * r2] *) + | Onegfs -> 1 (*r [rd = - r1] *) + | Oabsfs (*r [rd = abs(r1)] *) + | Oaddfs (*r [rd = r1 + r2] *) + | Osubfs (*r [rd = r1 - r2] *) + | Omulfs -> + 4 (*r [rd = r1 * r2] *) + | Osingleoffloat (*r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (*r [rd] is [r1] extended to double-precision float *) + (*c Conversions between int and float: *) + | Ofloatconst _ | Osingleconst _ + | Ointoffloat (*r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (*r [rd = unsigned_int_of_float64(r1)] *) + | Ofloatofint (*r [rd = float64_of_signed_int(r1)] *) + | Ofloatofintu (*r [rd = float64_of_unsigned_int(r1)] *) + | Ointofsingle (*r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (*r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (*r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (*r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (*r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (*r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (*r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (*r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (*r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (*r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (*r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu -> + 2 (*r [rd = float32_of_unsigned_int(r1)] *) + | OEfeqd | OEfltd | OEfeqs | OEflts | OEfles | OEfled | Obits_of_single + | Obits_of_float | Osingle_of_bits | Ofloat_of_bits -> + 2 + | OEloadli _ -> 2 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | Odivfs -> 35 + | Odivf -> 50 + | Ocmp cond -> ( + match cond with + | Ccomp _ | Ccompu _ | Ccompimm _ | Ccompuimm _ | Ccompl _ | Ccomplu _ + | Ccomplimm _ | Ccompluimm _ | CEbeqw _ | CEbnew _ | CEbequw _ + | CEbneuw _ | CEbltw _ | CEbltuw _ | CEbgew _ | CEbgeuw _ | CEbeql _ + | CEbnel _ | CEbequl _ | CEbneul _ | CEbltl _ | CEbltul _ | CEbgel _ + | CEbgeul _ -> + 1 + | Ccompf _ | Cnotcompf _ -> 2 + | Ccompfs _ | Cnotcompfs _ -> 2) + | OEmayundef _ -> 0 + | _ -> 1 + + let resources_of_op (op : operation) (nargs : int) = resource_bounds + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |] + + let resources_of_cond (cond : condition) (nargs : int) = resource_bounds + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3 + + let latency_of_call _ _ = 6 + + let resources_of_load trap chunk addressing nargs = resource_bounds + + let resources_of_store chunk addressing nargs = resource_bounds + + let resources_of_call _ _ = resource_bounds + + let resources_of_builtin _ = resource_bounds +end + +module SweRV_EH1 = struct + (* Attempt at modeling SweRV EH1 + [| issues ; LSU ; multiplier |] *) + let resource_bounds = [| 2; 1; 1 |] + + let nr_non_pipelined_units = 1 + + (* divider *) + + let latency_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> 3 + | Odiv | Odivu | Odivl | Odivlu -> 16 + | _ -> 1 + + let resources_of_op (op : operation) (nargs : int) = + match op with + | Omul | Omulhs | Omulhu | Omull | Omullhs | Omullhu -> [| 1; 0; 1 |] + | Odiv | Odivu | Odivl | Odivlu -> [| 0; 0; 0 |] + | _ -> [| 1; 0; 0 |] + + let non_pipelined_resources_of_op (op : operation) (nargs : int) = + match op with + | Odiv | Odivu -> [| 29 |] + | Odivfs -> [| 20 |] + | Odivl | Odivlu | Odivf -> [| 50 |] + | _ -> [| -1 |] + + let resources_of_cond (cond : condition) (nargs : int) = [| 1; 0; 0 |] + + let latency_of_load trap chunk (addr : addressing) (nargs : int) = 3 + + let latency_of_call _ _ = 6 + + let resources_of_load trap chunk addressing nargs = [| 1; 1; 0 |] + + let resources_of_store chunk addressing nargs = [| 1; 1; 0 |] + + let resources_of_call _ _ = resource_bounds + + let resources_of_builtin _ = resource_bounds +end let get_opweights () : opweights = match !Clflags.option_mtune with | "rocket" | "" -> - { - pipelined_resource_bounds = Rocket.resource_bounds; - nr_non_pipelined_units = Rocket.nr_non_pipelined_units; - latency_of_op = Rocket.latency_of_op; - resources_of_op = Rocket.resources_of_op; - non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; - latency_of_load = Rocket.latency_of_load; - resources_of_load = Rocket.resources_of_load; - resources_of_store = Rocket.resources_of_store; - resources_of_cond = Rocket.resources_of_cond; - latency_of_call = Rocket.latency_of_call; - resources_of_call = Rocket.resources_of_call; - resources_of_builtin = Rocket.resources_of_builtin - } + { + pipelined_resource_bounds = Rocket.resource_bounds; + nr_non_pipelined_units = Rocket.nr_non_pipelined_units; + latency_of_op = Rocket.latency_of_op; + resources_of_op = Rocket.resources_of_op; + non_pipelined_resources_of_op = Rocket.non_pipelined_resources_of_op; + latency_of_load = Rocket.latency_of_load; + resources_of_load = Rocket.resources_of_load; + resources_of_store = Rocket.resources_of_store; + resources_of_cond = Rocket.resources_of_cond; + latency_of_call = Rocket.latency_of_call; + resources_of_call = Rocket.resources_of_call; + resources_of_builtin = Rocket.resources_of_builtin; + } | "SweRV_EH1" | "EH1" -> - { - pipelined_resource_bounds = SweRV_EH1.resource_bounds; - nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; - latency_of_op = SweRV_EH1.latency_of_op; - resources_of_op = SweRV_EH1.resources_of_op; - non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; - latency_of_load = SweRV_EH1.latency_of_load; - resources_of_load = SweRV_EH1.resources_of_load; - resources_of_store = SweRV_EH1.resources_of_store; - resources_of_cond = SweRV_EH1.resources_of_cond; - latency_of_call = SweRV_EH1.latency_of_call; - resources_of_call = SweRV_EH1.resources_of_call; - resources_of_builtin = SweRV_EH1.resources_of_builtin - } - | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx);; + { + pipelined_resource_bounds = SweRV_EH1.resource_bounds; + nr_non_pipelined_units = SweRV_EH1.nr_non_pipelined_units; + latency_of_op = SweRV_EH1.latency_of_op; + resources_of_op = SweRV_EH1.resources_of_op; + non_pipelined_resources_of_op = SweRV_EH1.non_pipelined_resources_of_op; + latency_of_load = SweRV_EH1.latency_of_load; + resources_of_load = SweRV_EH1.resources_of_load; + resources_of_store = SweRV_EH1.resources_of_store; + resources_of_cond = SweRV_EH1.resources_of_cond; + latency_of_call = SweRV_EH1.latency_of_call; + resources_of_call = SweRV_EH1.resources_of_call; + resources_of_builtin = SweRV_EH1.resources_of_builtin; + } + | xxx -> failwith (Printf.sprintf "unknown -mtune: %s" xxx) diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 9ec474b3..0d47192a 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -30,6 +30,21 @@ let comparison_name = function | Cgt -> ">" | Cge -> ">=" +let mu_name pp = function + | MUint -> fprintf pp "MUint" + | MUlong -> fprintf pp "MUlong" + | MUshrx i -> fprintf pp "MUshrx(%ld)" (camlint_of_coqint i) + | MUshrxl i -> fprintf pp "MUshrxl(%ld)" (camlint_of_coqint i) + +let get_optR_s c reg pp r1 r2 = function + | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 + | Some X0_L -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 + | Some X0_R -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) + +let get_optR_a pp = function + | None -> failwith "PrintOp: None in get_optR_a instruction (problem with RTL expansions?)" + | Some X0_L | Some X0_R -> fprintf pp "X0" + let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 @@ -55,15 +70,47 @@ let print_condition reg pp = function fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 | (Cnotcompfs c, [r1;r2]) -> fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 + | (CEbeqw optR, [r1;r2]) -> + fprintf pp "CEbeqw"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbnew optR, [r1;r2]) -> + fprintf pp "CEbnew"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbequw optR, [r1;r2]) -> + fprintf pp "CEbequw"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbneuw optR, [r1;r2]) -> + fprintf pp "CEbneuw"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbltw optR, [r1;r2]) -> + fprintf pp "CEbltw"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbltuw optR, [r1;r2]) -> + fprintf pp "CEbltuw"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbgew optR, [r1;r2]) -> + fprintf pp "CEbgew"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbgeuw optR, [r1;r2]) -> + fprintf pp "CEbgeuw"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbeql optR, [r1;r2]) -> + fprintf pp "CEbeql"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbnel optR, [r1;r2]) -> + fprintf pp "CEbnel"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbequl optR, [r1;r2]) -> + fprintf pp "CEbequl"; (get_optR_s Ceq reg pp r1 r2 optR) + | (CEbneul optR, [r1;r2]) -> + fprintf pp "CEbneul"; (get_optR_s Cne reg pp r1 r2 optR) + | (CEbltl optR, [r1;r2]) -> + fprintf pp "CEbltl"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbltul optR, [r1;r2]) -> + fprintf pp "CEbltul"; (get_optR_s Clt reg pp r1 r2 optR) + | (CEbgel optR, [r1;r2]) -> + fprintf pp "CEbgel"; (get_optR_s Cge reg pp r1 r2 optR) + | (CEbgeul optR, [r1;r2]) -> + fprintf pp "CEbgeul"; (get_optR_s Cge reg pp r1 r2 optR) | _ -> fprintf pp "<bad condition>" let print_operation reg pp = function | Omove, [r1] -> reg pp r1 - | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) - | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) - | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) - | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) + | Ointconst n, [] -> fprintf pp "Ointconst(%ld)" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "Olongconst(%LdL)" (camlint64_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "Ofloatconst(%F)" (camlfloat_of_coqfloat n) + | Osingleconst n, [] -> fprintf pp "Osingleconst(%Ff)" (camlfloat_of_coqfloat32 n) | Oaddrsymbol(id, ofs), [] -> fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) | Oaddrstack ofs, [] -> @@ -156,6 +203,47 @@ let print_operation reg pp = function | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | OEseqw optR, [r1;r2] -> fprintf pp "OEseqw"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsnew optR, [r1;r2] -> fprintf pp "OEsnew"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsequw optR, [r1;r2] -> fprintf pp "OEsequw"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsneuw optR, [r1;r2] -> fprintf pp "OEsneuw"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsltw optR, [r1;r2] -> fprintf pp "OEsltw"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltuw optR, [r1;r2] -> fprintf pp "OEsltuw"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltiw n, [r1] -> fprintf pp "OEsltiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEluiw n, _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) + | OEaddiw (optR, n), [] -> fprintf pp "OEaddiw(%a,%ld)" get_optR_a optR (camlint_of_coqint n) + | OEaddiw (optR, n), [r1] -> fprintf pp "OEaddiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEandiw n, [r1] -> fprintf pp "OEandiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEoriw n, [r1] -> fprintf pp "OEoriw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEseql optR, [r1;r2] -> fprintf pp "OEseql"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsnel optR, [r1;r2] -> fprintf pp "OEsnel"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsequl optR, [r1;r2] -> fprintf pp "OEsequl"; (get_optR_s Ceq reg pp r1 r2 optR) + | OEsneul optR, [r1;r2] -> fprintf pp "OEsneul"; (get_optR_s Cne reg pp r1 r2 optR) + | OEsltl optR, [r1;r2] -> fprintf pp "OEsltl"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltul optR, [r1;r2] -> fprintf pp "OEsltul"; (get_optR_s Clt reg pp r1 r2 optR) + | OEsltil n, [r1] -> fprintf pp "OEsltil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEsltiul n, [r1] -> fprintf pp "OEsltiul(%a,%ld)" reg r1 (camlint_of_coqint n) + | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) + | OEaddil (optR, n), [] -> fprintf pp "OEaddil(%a,%ld)" get_optR_a optR (camlint_of_coqint n) + | OEaddil (optR, n), [r1] -> fprintf pp "OEaddil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEandil n, [r1] -> fprintf pp "OEandil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEoril n, [r1] -> fprintf pp "OEoril(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) + | OEmayundef mu, [r1;r2] -> fprintf pp "OEmayundef (%a,%a,%a)" mu_name mu reg r1 reg r2 + | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 + | OEfltd, [r1;r2] -> fprintf pp "OEfltd(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 + | OEfled, [r1;r2] -> fprintf pp "OEfled(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 + | OEfeqs, [r1;r2] -> fprintf pp "OEfeqs(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 + | OEflts, [r1;r2] -> fprintf pp "OEflts(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 + | OEfles, [r1;r2] -> fprintf pp "OEfles(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 + | Obits_of_single, [r1] -> fprintf pp "bits_of_single(%a)" reg r1 + | Obits_of_float, [r1] -> fprintf pp "bits_of_float(%a)" reg r1 + | Osingle_of_bits, [r1] -> fprintf pp "single_of_bits(%a)" reg r1 + | Ofloat_of_bits, [r1] -> fprintf pp "float_of_bits(%a)" reg r1 + | Oselectl, [rb;rt;rf] -> fprintf pp "selectl(b:%a, t:%a, f:%a)" reg rb reg rt reg rf | _ -> fprintf pp "<bad operator>" let print_addressing reg pp = function diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v new file mode 100644 index 00000000..7aca1772 --- /dev/null +++ b/riscV/RTLpathSE_simplify.v @@ -0,0 +1,2102 @@ +Require Import Coqlib Floats Values Memory. +Require Import Integers. +Require Import Op Registers. +Require Import RTLpathSE_theory. +Require Import RTLpathSE_simu_specs. +Require Import Asmgen Asmgenproof1. +Require Import Lia. + +(** Useful functions for conditions/branches expansion *) + +Definition is_inv_cmp_int (cmp: comparison) : bool := + match cmp with | Cle | Cgt => true | _ => false end. + +Definition is_inv_cmp_float (cmp: comparison) : bool := + match cmp with | Cge | Cgt => true | _ => false end. + +Definition make_optR (is_x0 is_inv: bool) : option oreg := + if is_x0 then + (if is_inv then Some (X0_L) + else Some (X0_R)) + else None. + +(** Functions to manage lists of "fake" values *) + +Definition make_lhsv_cmp (is_inv: bool) (hv1 hv2: hsval) : list_hsval := + let (hvfirst, hvsec) := if is_inv then (hv1, hv2) else (hv2, hv1) in + let lhsv := fScons hvfirst fSnil in + fScons hvsec lhsv. + +Definition make_lhsv_single (hvs: hsval) : list_hsval := + fScons hvs fSnil. + +(** * Expansion functions *) + +(** ** Immediate loads *) + +Definition load_hilo32 (hi lo: int) := + if Int.eq lo Int.zero then + fSop (OEluiw hi) fSnil + else + let hvs := fSop (OEluiw hi) fSnil in + let hl := make_lhsv_single hvs in + fSop (OEaddiw None lo) hl. + +Definition load_hilo64 (hi lo: int64) := + if Int64.eq lo Int64.zero then + fSop (OEluil hi) fSnil + else + let hvs := fSop (OEluil hi) fSnil in + let hl := make_lhsv_single hvs in + fSop (OEaddil None lo) hl. + +Definition loadimm32 (n: int) := + match make_immed32 n with + | Imm32_single imm => + fSop (OEaddiw (Some X0_R) imm) fSnil + | Imm32_pair hi lo => load_hilo32 hi lo + end. + +Definition loadimm64 (n: int64) := + match make_immed64 n with + | Imm64_single imm => + fSop (OEaddil (Some X0_R) imm) fSnil + | Imm64_pair hi lo => load_hilo64 hi lo + | Imm64_large imm => fSop (OEloadli imm) fSnil + end. + +Definition opimm32 (hv1: hsval) (n: int) (op: operation) (opimm: int -> operation) := + match make_immed32 n with + | Imm32_single imm => + let hl := make_lhsv_single hv1 in + fSop (opimm imm) hl + | Imm32_pair hi lo => + let hvs := load_hilo32 hi lo in + let hl := make_lhsv_cmp false hv1 hvs in + fSop op hl + end. + +Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> operation) := + match make_immed64 n with + | Imm64_single imm => + let hl := make_lhsv_single hv1 in + fSop (opimm imm) hl + | Imm64_pair hi lo => + let hvs := load_hilo64 hi lo in + let hl := make_lhsv_cmp false hv1 hvs in + fSop op hl + | Imm64_large imm => + let hvs := fSop (OEloadli imm) fSnil in + let hl := make_lhsv_cmp false hv1 hvs in + fSop op hl + end. + +Definition addimm32 (hv1: hsval) (n: int) (or: option oreg) := opimm32 hv1 n Oadd (OEaddiw or). +Definition andimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oand OEandiw. +Definition orimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oor OEoriw. +Definition xorimm32 (hv1: hsval) (n: int) := opimm32 hv1 n Oxor OExoriw. +Definition sltimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltw None) OEsltiw. +Definition sltuimm32 (hv1: hsval) (n: int) := opimm32 hv1 n (OEsltuw None) OEsltiuw. +Definition addimm64 (hv1: hsval) (n: int64) (or: option oreg) := opimm64 hv1 n Oaddl (OEaddil or). +Definition andimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oandl OEandil. +Definition orimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oorl OEoril. +Definition xorimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oxorl OExoril. +Definition sltimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltl None) OEsltil. +Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEsltiul. + +(** ** Comparisons intructions *) + +Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := + match cmp with + | Ceq => fSop (OEseqw optR) lhsv + | Cne => fSop (OEsnew optR) lhsv + | Clt | Cgt => fSop (OEsltw optR) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltw optR) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition cond_int32u (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := + match cmp with + | Ceq => fSop (OEsequw optR) lhsv + | Cne => fSop (OEsneuw optR) lhsv + | Clt | Cgt => fSop (OEsltuw optR) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltuw optR) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition cond_int64s (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := + match cmp with + | Ceq => fSop (OEseql optR) lhsv + | Cne => fSop (OEsnel optR) lhsv + | Clt | Cgt => fSop (OEsltl optR) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltl optR) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR: option oreg) := + match cmp with + | Ceq => fSop (OEsequl optR) lhsv + | Cne => fSop (OEsneul optR) lhsv + | Clt | Cgt => fSop (OEsltul optR) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltul optR) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := + let is_inv := is_inv_cmp_int cmp in + if Int.eq n Int.zero then + let optR := make_optR true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int32s cmp hl optR + else + match cmp with + | Ceq | Cne => + let optR := make_optR true is_inv in + let hvs := xorimm32 hv1 n in + let hl := make_lhsv_cmp false hvs hvs in + cond_int32s cmp hl optR + | Clt => sltimm32 hv1 n + | Cle => + if Int.eq n (Int.repr Int.max_signed) then + let hvs := loadimm32 Int.one in + let hl := make_lhsv_cmp false hv1 hvs in + fSop (OEmayundef MUint) hl + else sltimm32 hv1 (Int.add n Int.one) + | _ => + let optR := make_optR false is_inv in + let hvs := loadimm32 n in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int32s cmp hl optR + end. + +Definition expanse_condimm_int32u (cmp: comparison) (hv1: hsval) (n: int) := + let is_inv := is_inv_cmp_int cmp in + if Int.eq n Int.zero then + let optR := make_optR true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int32u cmp hl optR + else + match cmp with + | Clt => sltuimm32 hv1 n + | _ => + let optR := make_optR false is_inv in + let hvs := loadimm32 n in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int32u cmp hl optR + end. + +Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := + let is_inv := is_inv_cmp_int cmp in + if Int64.eq n Int64.zero then + let optR := make_optR true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int64s cmp hl optR + else + match cmp with + | Ceq | Cne => + let optR := make_optR true is_inv in + let hvs := xorimm64 hv1 n in + let hl := make_lhsv_cmp false hvs hvs in + cond_int64s cmp hl optR + | Clt => sltimm64 hv1 n + | Cle => + if Int64.eq n (Int64.repr Int64.max_signed) then + let hvs := loadimm32 Int.one in + let hl := make_lhsv_cmp false hv1 hvs in + fSop (OEmayundef MUlong) hl + else sltimm64 hv1 (Int64.add n Int64.one) + | _ => + let optR := make_optR false is_inv in + let hvs := loadimm64 n in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int64s cmp hl optR + end. + +Definition expanse_condimm_int64u (cmp: comparison) (hv1: hsval) (n: int64) := + let is_inv := is_inv_cmp_int cmp in + if Int64.eq n Int64.zero then + let optR := make_optR true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int64u cmp hl optR + else + match cmp with + | Clt => sltuimm64 hv1 n + | _ => + let optR := make_optR false is_inv in + let hvs := loadimm64 n in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int64u cmp hl optR + end. + +Definition cond_float (cmp: comparison) (lhsv: list_hsval) := + match cmp with + | Ceq | Cne => fSop OEfeqd lhsv + | Clt | Cgt => fSop OEfltd lhsv + | Cle | Cge => fSop OEfled lhsv + end. + +Definition cond_single (cmp: comparison) (lhsv: list_hsval) := + match cmp with + | Ceq | Cne => fSop OEfeqs lhsv + | Clt | Cgt => fSop OEflts lhsv + | Cle | Cge => fSop OEfles lhsv + end. + +Definition is_normal_cmp cmp := + match cmp with | Cne => false | _ => true end. + +Definition expanse_cond_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) := + let normal := is_normal_cmp cmp in + let normal' := if cnot then negb normal else normal in + let hvs := fn_cond cmp lhsv in + let hl := make_lhsv_single hvs in + if normal' then hvs else fSop (OExoriw Int.one) hl. + +(** ** Branches instructions *) + +Definition transl_cbranch_int32s (cmp: comparison) (optR: option oreg) := + match cmp with + | Ceq => CEbeqw optR + | Cne => CEbnew optR + | Clt => CEbltw optR + | Cle => CEbgew optR + | Cgt => CEbltw optR + | Cge => CEbgew optR + end. + +Definition transl_cbranch_int32u (cmp: comparison) (optR: option oreg) := + match cmp with + | Ceq => CEbequw optR + | Cne => CEbneuw optR + | Clt => CEbltuw optR + | Cle => CEbgeuw optR + | Cgt => CEbltuw optR + | Cge => CEbgeuw optR + end. + +Definition transl_cbranch_int64s (cmp: comparison) (optR: option oreg) := + match cmp with + | Ceq => CEbeql optR + | Cne => CEbnel optR + | Clt => CEbltl optR + | Cle => CEbgel optR + | Cgt => CEbltl optR + | Cge => CEbgel optR + end. + +Definition transl_cbranch_int64u (cmp: comparison) (optR: option oreg) := + match cmp with + | Ceq => CEbequl optR + | Cne => CEbneul optR + | Clt => CEbltul optR + | Cle => CEbgeul optR + | Cgt => CEbltul optR + | Cge => CEbgeul optR + end. + +Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (condition * list_hsval) := + let normal := is_normal_cmp cmp in + let normal' := if cnot then negb normal else normal in + let hvs := fn_cond cmp lhsv in + let hl := make_lhsv_cmp false hvs hvs in + if normal' then ((CEbnew (Some X0_R)), hl) else ((CEbeqw (Some X0_R)), hl). + +(** * Target simplifications using "fake" values *) + +Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := + match op, lr with + | Ocmp (Ccomp c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR := make_optR false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int32s c lhsv optR) + | Ocmp (Ccompu c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR := make_optR false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int32u c lhsv optR) + | Ocmp (Ccompimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int32s c hv1 imm) + | Ocmp (Ccompuimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int32u c hv1 imm) + | Ocmp (Ccompl c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR := make_optR false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int64s c lhsv optR) + | Ocmp (Ccomplu c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR := make_optR false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int64u c lhsv optR) + | Ocmp (Ccomplimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int64s c hv1 imm) + | Ocmp (Ccompluimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int64u c hv1 imm) + | Ocmp (Ccompf c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp false cond_float c lhsv) + | Ocmp (Cnotcompf c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp true cond_float c lhsv) + | Ocmp (Ccompfs c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp false cond_single c lhsv) + | Ocmp (Cnotcompfs c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp true cond_single c lhsv) + | Ofloatconst f, nil => + let hvs := loadimm64 (Float.to_bits f) in + let hl := make_lhsv_single hvs in + Some (fSop (Ofloat_of_bits) hl) + | Osingleconst f, nil => + let hvs := loadimm32 (Float32.to_bits f) in + let hl := make_lhsv_single hvs in + Some (fSop (Osingle_of_bits) hl) + | Ointconst n, nil => + Some (loadimm32 n) + | Olongconst n, nil => + Some (loadimm64 n) + | Oaddimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (addimm32 hv1 n None) + | Oaddlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (addimm64 hv1 n None) + | Oandimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (andimm32 hv1 n) + | Oandlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (andimm64 hv1 n) + | Oorimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (orimm32 hv1 n) + | Oorlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (orimm64 hv1 n) + | Oxorimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (xorimm32 hv1 n) + | Oxorlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (xorimm64 hv1 n) + | Ocast8signed, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let hvs := fSop (Oshlimm (Int.repr 24)) hl in + let hl' := make_lhsv_single hvs in + Some (fSop (Oshrimm (Int.repr 24)) hl') + | Ocast16signed, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let hvs := fSop (Oshlimm (Int.repr 16)) hl in + let hl' := make_lhsv_single hvs in + Some (fSop (Oshrimm (Int.repr 16)) hl') + | Ocast32unsigned, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + let cast32s_s := fSop Ocast32signed hl in + let cast32s_l := make_lhsv_single cast32s_s in + let sllil_s := fSop (Oshllimm (Int.repr 32)) cast32s_l in + let sllil_l := make_lhsv_single sllil_s in + Some (fSop (Oshrluimm (Int.repr 32)) sllil_l) + | Oshrximm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + if Int.eq n Int.zero then + let lhl := make_lhsv_cmp false hv1 hv1 in + Some (fSop (OEmayundef (MUshrx n)) lhl) + else + if Int.eq n Int.one then + let srliw_s := fSop (Oshruimm (Int.repr 31)) hl in + let srliw_l := make_lhsv_cmp false hv1 srliw_s in + let addw_s := fSop Oadd srliw_l in + let addw_l := make_lhsv_single addw_s in + let sraiw_s := fSop (Oshrimm Int.one) addw_l in + let sraiw_l := make_lhsv_cmp false sraiw_s sraiw_s in + Some (fSop (OEmayundef (MUshrx n)) sraiw_l) + else + let sraiw_s := fSop (Oshrimm (Int.repr 31)) hl in + let sraiw_l := make_lhsv_single sraiw_s in + let srliw_s := fSop (Oshruimm (Int.sub Int.iwordsize n)) sraiw_l in + let srliw_l := make_lhsv_cmp false hv1 srliw_s in + let addw_s := fSop Oadd srliw_l in + let addw_l := make_lhsv_single addw_s in + let sraiw_s' := fSop (Oshrimm n) addw_l in + let sraiw_l' := make_lhsv_cmp false sraiw_s' sraiw_s' in + Some (fSop (OEmayundef (MUshrx n)) sraiw_l') + | Oshrxlimm n, a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hl := make_lhsv_single hv1 in + if Int.eq n Int.zero then + let lhl := make_lhsv_cmp false hv1 hv1 in + Some (fSop (OEmayundef (MUshrxl n)) lhl) + else + if Int.eq n Int.one then + let srlil_s := fSop (Oshrluimm (Int.repr 63)) hl in + let srlil_l := make_lhsv_cmp false hv1 srlil_s in + let addl_s := fSop Oaddl srlil_l in + let addl_l := make_lhsv_single addl_s in + let srail_s := fSop (Oshrlimm Int.one) addl_l in + let srail_l := make_lhsv_cmp false srail_s srail_s in + Some (fSop (OEmayundef (MUshrxl n)) srail_l) + else + let srail_s := fSop (Oshrlimm (Int.repr 63)) hl in + let srail_l := make_lhsv_single srail_s in + let srlil_s := fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) srail_l in + let srlil_l := make_lhsv_cmp false hv1 srlil_s in + let addl_s := fSop Oaddl srlil_l in + let addl_l := make_lhsv_single addl_s in + let srail_s' := fSop (Oshrlimm n) addl_l in + let srail_l' := make_lhsv_cmp false srail_s' srail_s' in + Some (fSop (OEmayundef (MUshrxl n)) srail_l') + | _, _ => None + end. + +Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args: list reg) : option (condition * list_hsval) := + match cond, args with + | (Ccomp c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int32s c (make_optR false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccompu c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int32u c (make_optR false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccompimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int.eq n Int.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int32s c (make_optR true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm32 n in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int32s c (make_optR false is_inv) in + Some (cond, lhsv)) + | (Ccompuimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int.eq n Int.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int32u c (make_optR true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm32 n in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int32u c (make_optR false is_inv) in + Some (cond, lhsv)) + | (Ccompl c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int64s c (make_optR false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccomplu c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int64u c (make_optR false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccomplimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int64.eq n Int64.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int64s c (make_optR true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm64 n in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int64s c (make_optR false is_inv) in + Some (cond, lhsv)) + | (Ccompluimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int64.eq n Int64.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int64u c (make_optR true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm64 n in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int64u c (make_optR false is_inv) in + Some (cond, lhsv)) + | (Ccompf c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp false cond_float c lhsv) + | (Cnotcompf c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp true cond_float c lhsv) + | (Ccompfs c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp false cond_single c lhsv) + | (Cnotcompfs c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp true cond_single c lhsv) + | _, _ => None + end. + +(** * Auxiliary lemmas on comparisons *) + +(** ** Signed ints *) + +Lemma xor_neg_ltle_cmp: forall v1 v2, + Some (Val.xor (Val.cmp Clt v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmp_bool Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + unfold Val.cmp; simpl; + try rewrite Int.eq_sym; + try destruct (Int.eq _ _); try destruct (Int.lt _ _) eqn:ELT ; simpl; + try rewrite Int.xor_one_one; try rewrite Int.xor_zero_one; + auto. +Qed. + +(** ** Unsigned ints *) + +Lemma xor_neg_ltle_cmpu: forall mptr v1 v2, + Some (Val.xor (Val.cmpu (Mem.valid_pointer mptr) Clt v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpu_bool (Mem.valid_pointer mptr) Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + unfold Val.cmpu; simpl; + try rewrite Int.eq_sym; + try destruct (Int.eq _ _); try destruct (Int.ltu _ _) eqn:ELT ; simpl; + try rewrite Int.xor_one_one; try rewrite Int.xor_zero_one; + auto. + 1,2: + unfold Val.cmpu, Val.cmpu_bool; + destruct Archi.ptr64; try destruct (_ && _); try destruct (_ || _); + try destruct (eq_block _ _); auto. + unfold Val.cmpu, Val.cmpu_bool; simpl; + destruct Archi.ptr64; try destruct (_ || _); simpl; auto; + destruct (eq_block b b0); destruct (eq_block b0 b); + try congruence; + try destruct (_ || _); simpl; try destruct (Ptrofs.ltu _ _); + simpl; auto; + repeat destruct (_ && _); simpl; auto. +Qed. + +Remark ltu_12_wordsize: + Int.ltu (Int.repr 12) Int.iwordsize = true. +Proof. + unfold Int.iwordsize, Int.zwordsize. simpl. + unfold Int.ltu. apply zlt_true. + rewrite !Int.unsigned_repr; try cbn; try omega. +Qed. + +(** ** Signed longs *) + +Lemma xor_neg_ltle_cmpl: forall v1 v2, + Some (Val.xor (Val.maketotal (Val.cmpl Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpl_bool Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.lt _ _); auto. +Qed. + +Lemma xor_neg_ltge_cmpl: forall v1 v2, + Some (Val.xor (Val.maketotal (Val.cmpl Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpl_bool Cge v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.lt _ _); auto. +Qed. + +Lemma xorl_zero_eq_cmpl: forall c v1 v2, + c = Ceq \/ c = Cne -> + Some + (Val.maketotal + (option_map Val.of_bool + (Val.cmpl_bool c (Val.xorl v1 v2) (Vlong Int64.zero)))) = + Some (Val.of_optbool (Val.cmpl_bool c v1 v2)). +Proof. + intros. destruct c; inv H; try discriminate; + destruct v1, v2; simpl; auto; + destruct (Int64.eq i i0) eqn:EQ0. + 1,3: + apply Int64.same_if_eq in EQ0; subst; + rewrite Int64.xor_idem; + rewrite Int64.eq_true; trivial. + 1,2: + destruct (Int64.eq (Int64.xor i i0) Int64.zero) eqn:EQ1; simpl; try congruence; + rewrite Int64.xor_is_zero in EQ1; congruence. +Qed. + +Lemma cmp_ltle_add_one: forall v n, + Int.eq n (Int.repr Int.max_signed) = false -> + Some (Val.of_optbool (Val.cmp_bool Clt v (Vint (Int.add n Int.one)))) = + Some (Val.of_optbool (Val.cmp_bool Cle v (Vint n))). +Proof. + intros v n EQMAX. unfold Val.cmp_bool; destruct v; 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. + specialize (Int.eq_spec n (Int.repr Int.max_signed)). + rewrite EQMAX; simpl; intros. + assert (Int.signed n <> Int.max_signed). + { red; intros E. elim H. rewrite <- (Int.repr_signed n). rewrite E. auto. } + generalize (Int.signed_range n); omega. +Qed. + +Lemma cmpl_ltle_add_one: forall v n, + Int64.eq n (Int64.repr Int64.max_signed) = false -> + Some (Val.of_optbool (Val.cmpl_bool Clt v (Vlong (Int64.add n Int64.one)))) = + Some (Val.of_optbool (Val.cmpl_bool Cle v (Vlong n))). +Proof. + intros v n EQMAX. unfold Val.cmpl_bool; destruct v; 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. + specialize (Int64.eq_spec n (Int64.repr Int64.max_signed)). + rewrite EQMAX; simpl; intros. + assert (Int64.signed n <> Int64.max_signed). + { red; intros E. elim H. rewrite <- (Int64.repr_signed n). rewrite E. auto. } + generalize (Int64.signed_range n); omega. +Qed. + +Remark lt_maxsgn_false_int: forall i, + Int.lt (Int.repr Int.max_signed) i = false. +Proof. + intros; unfold Int.lt. + specialize Int.signed_range with i; intros. + rewrite zlt_false; auto. destruct H. + rewrite Int.signed_repr; try (cbn; lia). + apply Z.le_ge. trivial. +Qed. + +Remark lt_maxsgn_false_long: forall i, + Int64.lt (Int64.repr Int64.max_signed) i = false. +Proof. + intros; unfold Int64.lt. + specialize Int64.signed_range with i; intros. + rewrite zlt_false; auto. destruct H. + rewrite Int64.signed_repr; try (cbn; lia). + apply Z.le_ge. trivial. +Qed. + +(** ** Unsigned longs *) + +Lemma xor_neg_ltle_cmplu: forall mptr v1 v2, + Some (Val.xor (Val.maketotal (Val.cmplu (Mem.valid_pointer mptr) Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer mptr) Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.ltu _ _); auto. + 1,2: unfold Val.cmplu; simpl; auto; + destruct (Archi.ptr64); simpl; + try destruct (eq_block _ _); simpl; + try destruct (_ && _); simpl; + try destruct (Ptrofs.cmpu _ _); + try destruct cmp; simpl; auto. + unfold Val.cmplu; simpl; + destruct Archi.ptr64; try destruct (_ || _); simpl; auto; + destruct (eq_block b b0); destruct (eq_block b0 b); + try congruence; + try destruct (_ || _); simpl; try destruct (Ptrofs.ltu _ _); + simpl; auto; + repeat destruct (_ && _); simpl; auto. +Qed. + +Lemma xor_neg_ltge_cmplu: forall mptr v1 v2, + Some (Val.xor (Val.maketotal (Val.cmplu (Mem.valid_pointer mptr) Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer mptr) Cge v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.ltu _ _); auto. + 1,2: unfold Val.cmplu; simpl; auto; + destruct (Archi.ptr64); simpl; + try destruct (eq_block _ _); simpl; + try destruct (_ && _); simpl; + try destruct (Ptrofs.cmpu _ _); + try destruct cmp; simpl; auto. + unfold Val.cmplu; simpl; + destruct Archi.ptr64; try destruct (_ || _); simpl; auto; + destruct (eq_block b b0); destruct (eq_block b0 b); + try congruence; + try destruct (_ || _); simpl; try destruct (Ptrofs.ltu _ _); + simpl; auto; + repeat destruct (_ && _); simpl; auto. +Qed. + +(** ** Floats *) + +Lemma xor_neg_eqne_cmpf: forall v1 v2, + Some (Val.xor (Val.cmpf Ceq v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpf_bool Cne v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence; + unfold Val.cmpf; simpl. + rewrite Float.cmp_ne_eq. + destruct (Float.cmp _ _ _); simpl; auto. +Qed. + +(** ** Singles *) + +Lemma xor_neg_eqne_cmpfs: forall v1 v2, + Some (Val.xor (Val.cmpfs Ceq v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpfs_bool Cne v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence; + unfold Val.cmpfs; simpl. + rewrite Float32.cmp_ne_eq. + destruct (Float32.cmp _ _ _); simpl; auto. +Qed. + +(** ** More useful lemmas *) + +Lemma xor_neg_optb: forall v, + Some (Val.xor (Val.of_optbool (option_map negb v)) + (Vint Int.one)) = Some (Val.of_optbool v). +Proof. + intros. + destruct v; simpl; trivial. + destruct b; simpl; auto. +Qed. + +Lemma xor_neg_optb': forall v, + Some (Val.xor (Val.of_optbool v) (Vint Int.one)) = + Some (Val.of_optbool (option_map negb v)). +Proof. + intros. + destruct v; simpl; trivial. + destruct b; simpl; auto. +Qed. + +Lemma optbool_mktotal: forall v, + Val.maketotal (option_map Val.of_bool v) = + Val.of_optbool v. +Proof. + intros. + destruct v; simpl; auto. +Qed. + +(* TODO gourdinl move to common/Values ? *) +Theorem swap_cmpf_bool: + forall c x y, + Val.cmpf_bool (swap_comparison c) x y = Val.cmpf_bool c y x. +Proof. + destruct x; destruct y; simpl; auto. rewrite Float.cmp_swap. auto. +Qed. + +Theorem swap_cmpfs_bool: + forall c x y, + Val.cmpfs_bool (swap_comparison c) x y = Val.cmpfs_bool c y x. +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 + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (cond_int32s c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmp_bool c v v0)). +Proof. + intros. + unfold cond_int32s in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmp. + - apply xor_neg_ltle_cmp. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmp_bool; trivial. + - replace (Clt) with (negate_comparison Cge) by auto; + rewrite Val.negate_cmp_bool. + rewrite xor_neg_optb; trivial. +Qed. + +Lemma simplify_ccompu_correct ge sp hst st c r r0 rs0 m m0 v v0: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj + (cond_int32u c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmpu_bool (Mem.valid_pointer m) c v v0)). +Proof. + intros. + erewrite (cmpu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)). + 2: eauto. + unfold cond_int32u in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpu. + - apply xor_neg_ltle_cmpu. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmpu_bool; trivial. + - replace (Clt) with (negate_comparison Cge) by auto; + rewrite Val.negate_cmpu_bool. + rewrite xor_neg_optb; trivial. +Qed. + +Lemma simplify_ccompimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int32s c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmp_bool c v (Vint n))). +Proof. + intros. + unfold expanse_condimm_int32s, cond_int32s in *; destruct c; + intros; destruct (Int.eq n Int.zero) eqn:EQIMM; simpl; + try apply Int.same_if_eq in EQIMM; subst; + unfold loadimm32, sltimm32, xorimm32, opimm32, load_hilo32; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + unfold Val.cmp, zero32. + all: + try apply xor_neg_ltle_cmp; + try apply xor_neg_ltge_cmp; trivial. + 4: + try destruct (Int.eq n (Int.repr Int.max_signed)) eqn:EQMAX; subst; + try apply Int.same_if_eq in EQMAX; subst; simpl. + 4: + intros; try (specialize make_immed32_sound with (Int.one); + destruct (make_immed32 Int.one) eqn:EQMKI_A1); intros; simpl. + 6: + intros; try (specialize make_immed32_sound with (Int.add n Int.one); + destruct (make_immed32 (Int.add n Int.one)) eqn:EQMKI_A2); intros; simpl. + 1,2,3,8,9: + intros; try (specialize make_immed32_sound with (n); + destruct (make_immed32 n) eqn:EQMKI); intros; simpl. + all: + try destruct (Int.eq lo Int.zero) eqn:EQLO32; + try apply Int.same_if_eq in EQLO32; subst; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + try rewrite (Int.add_commut _ Int.zero), Int.add_zero_l in H; subst; + unfold Val.cmp, eval_may_undef, zero32, Val.add; simpl; + destruct v; auto. + all: + try rewrite ltu_12_wordsize; + try rewrite <- H; + try (apply cmp_ltle_add_one; auto); + try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int.add_commut; + try rewrite <- H; try rewrite cmp_ltle_add_one; + try rewrite Int.add_zero_l; + try ( + simpl; trivial; + try rewrite Int.xor_is_zero; + try destruct (Int.lt _ _) eqn:EQLT; trivial; + try rewrite lt_maxsgn_false_int in EQLT; + simpl; trivial; try discriminate; fail). +Qed. + +Lemma simplify_ccompuimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int32u c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmpu_bool (Mem.valid_pointer m) c v (Vint n))). +Proof. + intros. + assert (HMEM: Val.cmpu_bool (Mem.valid_pointer m) c v (Vint n) = + Val.cmpu_bool (Mem.valid_pointer m0) c v (Vint n)). + erewrite (cmpu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)); eauto. + unfold expanse_condimm_int32u, cond_int32u in *; destruct c; + intros; destruct (Int.eq n Int.zero) eqn:EQIMM; simpl; + try apply Int.same_if_eq in EQIMM; subst; + unfold loadimm32, sltuimm32, opimm32, load_hilo32; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; trivial; + try rewrite xor_neg_ltle_cmpu; + unfold Val.cmpu, zero32. + all: + try (specialize make_immed32_sound with n; + destruct (make_immed32 n) eqn:EQMKI); + try destruct (Int.eq lo Int.zero) eqn:EQLO; + try apply Int.same_if_eq in EQLO; subst; + intros; subst; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + rewrite HMEM; + unfold eval_may_undef, Val.cmpu; + destruct v; simpl; auto; + try rewrite EQIMM; try destruct (Archi.ptr64) eqn:EQARCH; simpl; + try rewrite ltu_12_wordsize; trivial; + try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int.add_zero_l; + try destruct (Int.ltu _ _) eqn:EQLTU; simpl; + try rewrite EQLTU; simpl; try rewrite EQIMM; + try rewrite EQARCH; trivial. +Qed. + +Lemma simplify_ccompl_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (cond_int64s c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmpl_bool c v v0)). +Proof. + intros. + unfold cond_int64s in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpl. + 1,2,3: rewrite optbool_mktotal; trivial. + - apply xor_neg_ltle_cmpl. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmpl_bool; trivial. + rewrite optbool_mktotal; trivial. + - apply xor_neg_ltge_cmpl. +Qed. + +Lemma simplify_ccomplu_correct ge sp hst st c r r0 rs0 m m0 v v0: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj + (cond_int64u c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer m) c v v0)). +Proof. + intros. + erewrite (cmplu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)). + 2: eauto. + unfold cond_int64u in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmplu. + 1,2,3: rewrite optbool_mktotal; trivial. + - apply xor_neg_ltle_cmplu. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmplu_bool; trivial. + rewrite optbool_mktotal; trivial. + - apply xor_neg_ltge_cmplu. +Qed. + +Lemma simplify_ccomplimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int64s c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmpl_bool c v (Vlong n))). +Proof. + intros. + unfold expanse_condimm_int64s, cond_int64s in *; destruct c; + intros; destruct (Int64.eq n Int64.zero) eqn:EQIMM; simpl; + try apply Int64.same_if_eq in EQIMM; subst; + unfold loadimm32, loadimm64, sltimm64, xorimm64, opimm64, load_hilo32, load_hilo64; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + unfold Val.cmpl, zero64. + all: + try apply xor_neg_ltle_cmpl; + try apply xor_neg_ltge_cmpl; + try rewrite optbool_mktotal; trivial. + 4: + try destruct (Int64.eq n (Int64.repr Int64.max_signed)) eqn:EQMAX; subst; + try apply Int64.same_if_eq in EQMAX; subst; simpl. + 4: + intros; try (specialize make_immed32_sound with (Int.one); + destruct (make_immed32 Int.one) eqn:EQMKI_A1); intros; simpl. + 6: + intros; try (specialize make_immed64_sound with (Int64.add n Int64.one); + destruct (make_immed64 (Int64.add n Int64.one)) eqn:EQMKI_A2); intros; simpl. + 1,2,3,9,10: + intros; try (specialize make_immed64_sound with (n); + destruct (make_immed64 n) eqn:EQMKI); intros; simpl. + all: + try destruct (Int.eq lo Int.zero) eqn:EQLO32; + try apply Int.same_if_eq in EQLO32; subst; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO64; + try apply Int64.same_if_eq in EQLO64; subst; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + try rewrite (Int64.add_commut _ Int64.zero), Int64.add_zero_l in H; subst; + try fold (Val.cmpl Clt v (Vlong imm)); + try rewrite xor_neg_ltge_cmpl; trivial; + try rewrite xor_neg_ltle_cmpl; trivial; + unfold Val.cmpl, Val.addl; + try rewrite xorl_zero_eq_cmpl; trivial; + try rewrite optbool_mktotal; trivial; + unfold eval_may_undef, zero32, Val.add; simpl; + destruct v; auto. + 1,2,3,4,5,6,7,8,9,10,11,12: + try rewrite <- optbool_mktotal; trivial; + try rewrite Int64.add_commut, Int64.add_zero_l in *; + try fold (Val.cmpl Clt (Vlong i) (Vlong imm)); + try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))))); + try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo))); + try rewrite xor_neg_ltge_cmpl; trivial; + try rewrite xor_neg_ltle_cmpl; trivial. + 6: + rewrite <- H; + try apply cmpl_ltle_add_one; auto. + all: + try rewrite <- H; + try apply cmpl_ltle_add_one; auto; + try rewrite <- cmpl_ltle_add_one; auto; + try rewrite ltu_12_wordsize; + try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int64.add_commut, Int64.add_zero_l in *; + try rewrite Int64.add_zero_l; + simpl; try rewrite lt_maxsgn_false_long; + try (rewrite <- H; trivial; fail); + simpl; trivial. +Qed. + +Lemma simplify_ccompluimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int64u c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong n))). +Proof. + intros. + assert (HMEM: Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong n) = + Val.cmplu_bool (Mem.valid_pointer m0) c v (Vlong n)). + erewrite (cmplu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)); eauto. + unfold expanse_condimm_int64u, cond_int64u in *; destruct c; + intros; destruct (Int64.eq n Int64.zero) eqn:EQIMM; simpl; + unfold loadimm64, sltuimm64, opimm64, load_hilo64; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + unfold Val.cmplu, zero64. + (* Simplify make immediate and decompose subcases *) + all: + try (specialize make_immed64_sound with n; + destruct (make_immed64 n) eqn:EQMKI); + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + rewrite HMEM. + (* Ceq, Cne, Clt = itself *) + all: intros; try apply Int64.same_if_eq in EQIMM; subst; trivial. + (* Cle = xor (Clt) *) + all: try apply xor_neg_ltle_cmplu; trivial. + (* Others subcases with swap/negation *) + all: + unfold Val.cmplu, eval_may_undef, zero64, Val.addl; + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l in *; trivial; + try rewrite Int64.add_zero_l; + try (rewrite <- xor_neg_ltle_cmplu; unfold Val.cmplu; + trivial; fail); + try (replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmplu_bool; trivial; fail); + try (replace (Clt) with (negate_comparison Cge) by auto; + rewrite Val.negate_cmplu_bool; rewrite xor_neg_optb; trivial; fail); + try rewrite optbool_mktotal; trivial. + all: + try destruct v; simpl; auto; + try destruct (Archi.ptr64); simpl; + try rewrite EQIMM; + try rewrite HMEM; trivial; + try destruct (Int64.ltu _ _); + try rewrite <- xor_neg_ltge_cmplu; unfold Val.cmplu; + try rewrite <- optbool_mktotal; trivial. +Qed. + +Lemma simplify_ccompf_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp false cond_float c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (Val.cmpf_bool c v v0)). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpf. + - apply xor_neg_eqne_cmpf. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite swap_cmpf_bool; trivial. + - replace (Cle) with (swap_comparison Cge) by auto; + rewrite swap_cmpf_bool; trivial. +Qed. + +Lemma simplify_cnotcompf_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp true cond_float c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (option_map negb (Val.cmpf_bool c v v0))). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpf. + 1,3,4: apply xor_neg_optb'. + all: destruct v, v0; simpl; trivial. + rewrite Float.cmp_ne_eq; rewrite negb_involutive; trivial. + 1: replace (Clt) with (swap_comparison Cgt) by auto; rewrite <- Float.cmp_swap; simpl. + 2: replace (Cle) with (swap_comparison Cge) by auto; rewrite <- Float.cmp_swap; simpl. + all: destruct (Float.cmp _ _ _); trivial. +Qed. + +Lemma simplify_ccompfs_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp false cond_single c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (Val.cmpfs_bool c v v0)). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpfs. + - apply xor_neg_eqne_cmpfs. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite swap_cmpfs_bool; trivial. + - replace (Cle) with (swap_comparison Cge) by auto; + rewrite swap_cmpfs_bool; trivial. +Qed. + +Lemma simplify_cnotcompfs_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp true cond_single c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (option_map negb (Val.cmpfs_bool c v v0))). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpfs. + 1,3,4: apply xor_neg_optb'. + all: destruct v, v0; simpl; trivial. + rewrite Float32.cmp_ne_eq; rewrite negb_involutive; trivial. + 1: replace (Clt) with (swap_comparison Cgt) by auto; rewrite <- Float32.cmp_swap; simpl. + 2: replace (Cle) with (swap_comparison Cge) by auto; rewrite <- Float32.cmp_swap; simpl. + all: destruct (Float32.cmp _ _ _); trivial. +Qed. + +Lemma simplify_floatconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => + Some + (fSop Ofloat_of_bits + (make_lhsv_single (loadimm64 (Float.to_bits n)))) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Ofloatconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm64, load_hilo64; simpl; + specialize make_immed64_sound with (Float.to_bits n); + destruct (make_immed64 (Float.to_bits n)) eqn:EQMKI; intros; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + simpl. + - try rewrite Int64.add_commut, Int64.add_zero_l; inv H; + try rewrite Float.of_to_bits; trivial. + - apply Int64.same_if_eq in EQLO; subst. + try rewrite Int64.add_commut, Int64.add_zero_l in H. + rewrite <- H; try rewrite Float.of_to_bits; trivial. + - rewrite <- H; try rewrite Float.of_to_bits; trivial. + - rewrite <- H; try rewrite Float.of_to_bits; trivial. +Qed. + +Lemma simplify_singleconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => + Some + (fSop Osingle_of_bits + (make_lhsv_single (loadimm32 (Float32.to_bits n)))) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Osingleconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm32, load_hilo32; simpl; + specialize make_immed32_sound with (Float32.to_bits n); + destruct (make_immed32 (Float32.to_bits n)) eqn:EQMKI; intros; + try destruct (Int.eq lo Int.zero) eqn:EQLO; + simpl. + { try rewrite Int.add_commut, Int.add_zero_l; inv H; + try rewrite Float32.of_to_bits; trivial. } + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l in H; simpl; + rewrite ltu_12_wordsize; simpl; try rewrite <- H; + try rewrite Float32.of_to_bits; trivial. +Qed. + +Lemma simplify_addimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (addimm32 (fsi_sreg_get hst a1) n None) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oaddimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold addimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.add (Vint imm) v); rewrite Val.add_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_addlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (addimm64 (fsi_sreg_get hst a1) n None) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oaddlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold addimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.addl (Vlong imm) v); rewrite Val.addl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_andimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (andimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oandimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold andimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.and (Vint imm) v); rewrite Val.and_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_andlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (andimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oandlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold andimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.andl (Vlong imm) v); rewrite Val.andl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_orimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (orimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oorimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold orimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.or (Vint imm) v); rewrite Val.or_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_orlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (orimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oorlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold orimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.orl (Vlong imm) v); rewrite Val.orl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_xorimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (xorimm32 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oxorimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold xorimm32, opimm32, load_hilo32, make_lhsv_cmp; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.xor (Vint imm) v); rewrite Val.xor_commut; trivial. + all: + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_xorlimm_correct ge sp rs0 m0 lr n hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => Some (xorimm64 (fsi_sreg_get hst a1) n) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oxorlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold xorimm64, opimm64, load_hilo64, make_lhsv_cmp; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + fold (Val.xorl (Vlong imm) v); rewrite Val.xorl_commut; trivial. + all: + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; trivial. +Qed. + +Lemma simplify_intconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => Some (loadimm32 n) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Ointconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm32, load_hilo32, make_lhsv_single; simpl; + specialize make_immed32_sound with (n); + destruct (make_immed32 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; simpl; + try apply Int.same_if_eq in EQLO; subst; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite ltu_12_wordsize; try rewrite H; trivial. +Qed. + +Lemma simplify_longconst_correct ge sp rs0 m0 args m n fsv lr st: forall + (H : match lr with + | nil => Some (loadimm64 n) + | _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Olongconst n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + unfold loadimm64, load_hilo64, make_lhsv_single; simpl; + specialize make_immed64_sound with (n); + destruct (make_immed64 (n)) eqn:EQMKI; intros; simpl; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; simpl; + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite ltu_12_wordsize; try rewrite H; trivial. +Qed. + +Lemma simplify_cast8signed_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrimm (Int.repr 24)) + (make_lhsv_single + (fSop (Oshlimm (Int.repr 24)) + (make_lhsv_single (fsi_sreg_get hst a1))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast8signed args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shr, Val.shl, Val.sign_ext; + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + rewrite A. rewrite Int.sign_ext_shr_shl; simpl; trivial. cbn; lia. +Qed. + +Lemma simplify_cast16signed_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrimm (Int.repr 16)) + (make_lhsv_single + (fSop (Oshlimm (Int.repr 16)) + (make_lhsv_single (fsi_sreg_get hst a1))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast16signed args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shr, Val.shl, Val.sign_ext; + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + rewrite A. rewrite Int.sign_ext_shr_shl; simpl; trivial. cbn; lia. +Qed. + +Lemma simplify_shrximm_correct ge sp rs0 m0 lr hst fsv st args m n: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + if Int.eq n Int.zero + then + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fsi_sreg_get hst a1))) + else + if Int.eq n Int.one + then + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))) + (fSop (Oshrimm Int.one) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.repr 31)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEmayundef (MUshrx n)) + (make_lhsv_cmp false + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))) + (fSop (Oshrimm n) + (make_lhsv_single + (fSop Oadd + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshruimm (Int.sub Int.iwordsize n)) + (make_lhsv_single + (fSop (Oshrimm (Int.repr 31)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oshrximm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence). + assert (A: Int.ltu Int.zero (Int.repr 31) = true) by auto. + assert (B: Int.ltu (Int.repr 31) Int.iwordsize = true) by auto. + assert (C: Int.ltu Int.one Int.iwordsize = true) by auto. + destruct (Int.eq n Int.zero) eqn:EQ0; + destruct (Int.eq n Int.one) eqn:EQ1. + { apply Int.same_if_eq in EQ0. + apply Int.same_if_eq in EQ1; subst. discriminate. } + all: + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; + destruct (Val.shrx v (Vint n)) eqn:TOTAL; cbn; + unfold eval_may_undef. + 2,4,6: + unfold Val.shrx in TOTAL; + destruct v; simpl in TOTAL; simpl; try congruence; + try rewrite B; simpl; try rewrite C; simpl; + try destruct (Val.shr _ _); + destruct (Int.ltu n (Int.repr 31)); try congruence. + - destruct v; simpl in TOTAL; try congruence; + apply Int.same_if_eq in EQ0; subst; + rewrite A, Int.shrx_zero in TOTAL; + [auto | cbn; lia]. + - apply Int.same_if_eq in EQ1; subst; + unfold Val.shr, Val.shru, Val.shrx, Val.add; simpl; + destruct v; simpl in *; try discriminate; trivial. + rewrite B, C. + rewrite Int.shrx1_shr in TOTAL; auto. + - exploit Val.shrx_shr_2; eauto. rewrite EQ0. + intros; subst. + destruct v; simpl in *; try discriminate; trivial. + rewrite B in *. + destruct Int.ltu eqn:EQN0 in TOTAL; try discriminate. + simpl in *. + destruct Int.ltu eqn:EQN1 in TOTAL; try discriminate. + replace Int.iwordsize with (Int.repr 32) in * by auto. + rewrite !EQN1. simpl in *. + destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. + rewrite !EQN2. rewrite EQN0. + reflexivity. +Qed. + +Lemma simplify_shrxlimm_correct ge sp rs0 m0 lr hst fsv st args m n: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + if Int.eq n Int.zero + then + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fsi_sreg_get hst a1))) + else + if Int.eq n Int.one + then + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))) + (fSop (Oshrlimm Int.one) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.repr 63)) + (make_lhsv_single (fsi_sreg_get hst a1))))))))) + else + Some + (fSop (OEmayundef (MUshrxl n)) + (make_lhsv_cmp false + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))) + (fSop (Oshrlimm n) + (make_lhsv_single + (fSop Oaddl + (make_lhsv_cmp false (fsi_sreg_get hst a1) + (fSop (Oshrluimm (Int.sub Int64.iwordsize' n)) + (make_lhsv_single + (fSop (Oshrlimm (Int.repr 63)) + (make_lhsv_single + (fsi_sreg_get hst a1))))))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp (Oshrxlimm n) args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence). + assert (A: Int.ltu Int.zero (Int.repr 63) = true) by auto. + assert (B: Int.ltu (Int.repr 63) Int64.iwordsize' = true) by auto. + assert (C: Int.ltu Int.one Int64.iwordsize' = true) by auto. + destruct (Int.eq n Int.zero) eqn:EQ0; + destruct (Int.eq n Int.one) eqn:EQ1. + { apply Int.same_if_eq in EQ0. + apply Int.same_if_eq in EQ1; subst. discriminate. } + all: + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1; + destruct (Val.shrxl v (Vint n)) eqn:TOTAL; cbn; + unfold eval_may_undef. + 2,4,6: + unfold Val.shrxl in TOTAL; + destruct v; simpl in TOTAL; simpl; try congruence; + try rewrite B; simpl; try rewrite C; simpl; + try destruct (Val.shrl _ _); + destruct (Int.ltu n (Int.repr 63)); try congruence. + - destruct v; simpl in TOTAL; try congruence; + apply Int.same_if_eq in EQ0; subst; + rewrite A, Int64.shrx'_zero in *. + assumption. + - apply Int.same_if_eq in EQ1; subst; + unfold Val.shrl, Val.shrlu, Val.shrxl, Val.addl; simpl; + destruct v; simpl in *; try discriminate; trivial. + rewrite B, C. + rewrite Int64.shrx'1_shr' in TOTAL; auto. + - exploit Val.shrxl_shrl_2; eauto. rewrite EQ0. + intros; subst. + destruct v; simpl in *; try discriminate; trivial. + rewrite B in *. + destruct Int.ltu eqn:EQN0 in TOTAL; try discriminate. + simpl in *. + destruct Int.ltu eqn:EQN1 in TOTAL; try discriminate. + replace Int64.iwordsize' with (Int.repr 64) in * by auto. + rewrite !EQN1. simpl in *. + destruct Int.ltu eqn:EQN2 in TOTAL; try discriminate. + rewrite !EQN2. rewrite EQN0. + reflexivity. +Qed. + +Lemma simplify_cast32unsigned_correct ge sp rs0 m0 lr hst fsv st args m: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (H : match lr with + | nil => None + | a1 :: nil => + Some + (fSop (Oshrluimm (Int.repr 32)) + (make_lhsv_single + (fSop (Oshllimm (Int.repr 32)) + (make_lhsv_single + (fSop Ocast32signed + (make_lhsv_single (fsi_sreg_get hst a1))))))) + | a1 :: _ :: _ => None + end = Some fsv) + (OK1 : seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = + eval_operation ge sp Ocast32unsigned args m. +Proof. + intros. + repeat (destruct lr; simpl; try congruence); + simpl in OK1; inv OK1; inv H; simpl; + erewrite !fsi_sreg_get_correct; eauto; + destruct (seval_sval ge sp (si_sreg st p) rs0 m0) eqn:OKv1; try congruence; inv H1. + unfold Val.shrlu, Val.shll, Val.longofint, Val.longofintu. + destruct v; simpl; auto. + assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. + rewrite A. rewrite Int64.shru'_shl'; auto. + replace (Int.ltu (Int.repr 32) (Int.repr 32)) with (false) by auto. + rewrite cast32unsigned_from_cast32signed. + replace Int64.zwordsize with 64 by auto. + rewrite Int.unsigned_repr; cbn; try lia. + replace (Int.sub (Int.repr 32) (Int.repr 32)) with (Int.zero) by auto. + rewrite Int64.shru'_zero. reflexivity. +Qed. + +(** * Main proof of simplification *) + +Lemma target_op_simplify_correct op lr hst fsv ge sp rs0 m0 st args m: forall + (H: target_op_simplify op lr hst = Some fsv) + (REF: hsilocal_refines ge sp rs0 m0 hst st) + (OK0: hsok_local ge sp rs0 m0 hst) + (OK1: seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args) + (OK2: seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = eval_operation ge sp op args m. +Proof. + unfold target_op_simplify; simpl. + intros H (LREF & SREF & SREG & SMEM) ? ? ?. + destruct op; try congruence. + eapply simplify_intconst_correct; eauto. + eapply simplify_longconst_correct; eauto. + eapply simplify_floatconst_correct; eauto. + eapply simplify_singleconst_correct; eauto. + eapply simplify_cast8signed_correct; eauto. + eapply simplify_cast16signed_correct; eauto. + eapply simplify_addimm_correct; eauto. + eapply simplify_andimm_correct; eauto. + eapply simplify_orimm_correct; eauto. + eapply simplify_xorimm_correct; eauto. + eapply simplify_shrximm_correct; eauto. + eapply simplify_cast32unsigned_correct; eauto. + eapply simplify_addlimm_correct; eauto. + eapply simplify_andlimm_correct; eauto. + eapply simplify_orlimm_correct; eauto. + eapply simplify_xorlimm_correct; eauto. + eapply simplify_shrxlimm_correct; eauto. + (* Ocmp expansions *) + destruct cond; repeat (destruct lr; simpl; try congruence); + simpl in OK1; + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + inv H; inv OK1. + - eapply simplify_ccomp_correct; eauto. + - eapply simplify_ccompu_correct; eauto. + - eapply simplify_ccompimm_correct; eauto. + - eapply simplify_ccompuimm_correct; eauto. + - eapply simplify_ccompl_correct; eauto. + - eapply simplify_ccomplu_correct; eauto. + - eapply simplify_ccomplimm_correct; eauto. + - eapply simplify_ccompluimm_correct; eauto. + - eapply simplify_ccompf_correct; eauto. + - eapply simplify_cnotcompf_correct; eauto. + - eapply simplify_ccompfs_correct; eauto. + - eapply simplify_cnotcompfs_correct; eauto. +Qed. + +Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall + (TARGET: target_cbranch_expanse hst c l = Some (c', l')) + (LREF : hsilocal_refines ge sp rs0 m0 hst st) + (OK: hsok_local ge sp rs0 m0 hst), + seval_condition ge sp c' (hsval_list_proj l') (si_smem st) rs0 m0 = + seval_condition ge sp c (list_sval_inj (map (si_sreg st) l)) (si_smem st) rs0 m0. +Proof. + unfold target_cbranch_expanse, seval_condition; simpl. + intros H (LREF & SREF & SREG & SMEM) ?. + destruct c; try congruence; + repeat (destruct l; simpl in H; try congruence). + 1,2,5,6: + destruct c; inv H; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try (destruct (seval_smem ge sp (si_smem st) rs0 m0) eqn:OKmem; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + try replace (Cle) with (swap_comparison Cge) by auto; + try replace (Clt) with (swap_comparison Cgt) by auto; + try rewrite Val.swap_cmp_bool; trivial; + try rewrite Val.swap_cmpu_bool; trivial; + try rewrite Val.swap_cmpl_bool; trivial; + try rewrite Val.swap_cmplu_bool; trivial. + 1,2,3,4: + try destruct (Int.eq n Int.zero) eqn: EQIMM; + try apply Int.same_if_eq in EQIMM; + try destruct (Int64.eq n Int64.zero) eqn: EQIMM; + try apply Int64.same_if_eq in EQIMM; + destruct c; inv H; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try (destruct (seval_smem ge sp (si_smem st) rs0 m0) eqn:OKmem; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + unfold loadimm32, load_hilo32, Val.cmp, Val.cmpu, zero32; + unfold loadimm64, load_hilo64, Val.cmpl, Val.cmplu, zero64; + intros; try (specialize make_immed32_sound with (n); + destruct (make_immed32 n) eqn:EQMKI); intros; simpl; + intros; try (specialize make_immed64_sound with (n); + destruct (make_immed64 n) eqn:EQMKI); intros; simpl; + try rewrite EQLO; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + try apply Int.same_if_eq in EQLO; simpl; trivial; + try apply Int64.same_if_eq in EQLO; simpl; trivial; + unfold eval_may_undef; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; simpl; trivial; + try destruct v; try rewrite H; + try rewrite ltu_12_wordsize; try rewrite EQLO; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int64.add_commut, Int64.add_zero_l; + try rewrite Int64.add_commut; + try rewrite Int.add_zero_l; try rewrite Int64.add_zero_l; + auto; simpl; + try rewrite H in EQIMM; + try rewrite EQLO in EQIMM; + try rewrite Int.add_commut, Int.add_zero_l in EQIMM; + try rewrite Int64.add_commut, Int64.add_zero_l in EQIMM; + try rewrite EQIMM; simpl; + try destruct (Archi.ptr64); trivial. + + 1,2,3,4: + destruct c; inv H; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try (destruct (seval_smem ge sp (si_smem st) rs0 m0) eqn:OKmem; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + unfold zero32, zero64, Val.cmpf, Val.cmpfs; + destruct v, v0; simpl; trivial; + try rewrite Float.cmp_ne_eq; + try rewrite Float32.cmp_ne_eq; + try rewrite <- Float.cmp_swap; simpl; + try rewrite <- Float32.cmp_swap; simpl; + try destruct (Float.cmp _ _); simpl; + try destruct (Float32.cmp _ _); simpl; + try rewrite Int.eq_true; simpl; + try rewrite Int.eq_false; try apply Int.one_not_zero; + simpl; trivial. +Qed. +Global Opaque target_op_simplify. +Global Opaque target_cbranch_expanse. diff --git a/riscV/SelectOp.vp b/riscV/SelectOp.vp index e9920e46..9932aaf8 100644 --- a/riscV/SelectOp.vp +++ b/riscV/SelectOp.vp @@ -419,9 +419,39 @@ Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). (** ** Selection *) +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) - : option expr - := None. + : option expr := + if same_expr_pure e1 e2 + then Some e1 + else + if Archi.ptr64 then + match ty with + | Tlong => Some (Eop Oselectl + ((Eop (Ocmp cond) args) ::: e1 ::: e2 ::: Enil)) + | Tint => Some (Eop Olowlong ((Eop Oselectl + ((Eop (Ocmp cond) args) ::: + (Eop Ocast32signed (e1 ::: Enil)) ::: + (Eop Ocast32signed (e2 ::: Enil)) ::: Enil)) ::: Enil)) + | Tfloat => Some (Eop Ofloat_of_bits ((Eop Oselectl + ((Eop (Ocmp cond) args) ::: + (Eop Obits_of_float (e1 ::: Enil)) ::: + (Eop Obits_of_float (e2 ::: Enil)) ::: Enil)) ::: Enil)) + | Tsingle => Some + (Eop Osingle_of_bits + ((Eop Olowlong ((Eop Oselectl + ((Eop (Ocmp cond) args) ::: + (Eop Ocast32signed ((Eop Obits_of_single (e1 ::: Enil)) ::: Enil)) ::: + (Eop Ocast32signed ((Eop Obits_of_single (e2 ::: Enil)) ::: Enil)) + ::: Enil)) ::: Enil)) ::: Enil)) + | _ => None + end + else None. (** ** Recognition of addressing modes for load and store operations *) @@ -462,4 +492,9 @@ Definition divfs_base (e1: expr) (e2: expr) := (** Platform-specific known builtins *) Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := - None. + match b with + | BI_bits_of_float => Some (Eop Obits_of_single args) + | BI_bits_of_double => Some (Eop Obits_of_float args) + | BI_float_of_bits => Some (Eop Osingle_of_bits args) + | BI_double_of_bits => Some (Eop Ofloat_of_bits args) + end. diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v index 1d13702a..ce80fc57 100644 --- a/riscV/SelectOpproof.v +++ b/riscV/SelectOpproof.v @@ -24,6 +24,7 @@ Require Import Cminor Op CminorSel. Require Import SelectOp. Require Import OpHelpers. Require Import OpHelpersproof. +Require Import Lia. Local Open Scope cminorsel_scope. @@ -875,6 +876,71 @@ Proof. red; intros. unfold floatofsingle. TrivialExists. Qed. +Lemma mod_small_negative: + forall a modulus, + modulus > 0 -> -modulus < a < 0 -> a mod modulus = a + modulus. +Proof. + intros. + replace (a mod modulus) with ((a + modulus) mod modulus). + apply Z.mod_small. + lia. + rewrite <- Zplus_mod_idemp_r. + rewrite Z.mod_same by lia. + rewrite Z.add_0_r. + reflexivity. +Qed. + +Remark normalize_low_long: forall + (PTR64 : Archi.ptr64 = true) v1, + Val.loword (Val.normalize (Val.longofint v1) Tlong) = Val.normalize v1 Tint. +Proof. + intros. + destruct v1; cbn; try rewrite PTR64; trivial. + f_equal. + unfold Int64.loword. + unfold Int.signed. + destruct zlt. + { rewrite Int64.int_unsigned_repr. + apply Int.repr_unsigned. + } + pose proof (Int.unsigned_range i). + rewrite Int64.unsigned_repr_eq. + replace ((Int.unsigned i - Int.modulus) mod Int64.modulus) + with (Int64.modulus + Int.unsigned i - Int.modulus). + { + rewrite <- (Int.repr_unsigned i) at 2. + apply Int.eqm_samerepr. + unfold Int.eqm, eqmod. + change Int.modulus with 4294967296 in *. + change Int64.modulus with 18446744073709551616 in *. + exists 4294967295. + lia. + } + { rewrite mod_small_negative. + lia. + constructor. + constructor. + change Int.modulus with 4294967296 in *. + change Int.half_modulus with 2147483648 in *. + change Int64.modulus with 18446744073709551616 in *. + lia. + lia. + } +Qed. + +Lemma same_expr_pure_correct: + forall le a1 a2 v1 v2 + (PURE : same_expr_pure a1 a2 = true) + (EVAL1 : eval_expr ge sp e m le a1 v1) + (EVAL2 : eval_expr ge sp e m le a2 v2), + v1 = v2. +Proof. + intros. + destruct a1; destruct a2; cbn in *; try discriminate. + inv EVAL1. inv EVAL2. + destruct (ident_eq i i0); congruence. +Qed. + Theorem eval_select: forall le ty cond al vl a1 v1 a2 v2 a b, select ty cond al a1 a2 = Some a -> @@ -886,7 +952,56 @@ Theorem eval_select: eval_expr ge sp e m le a v /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. Proof. - unfold select; intros; discriminate. + unfold select; intros. + pose proof (same_expr_pure_correct le a1 a2 v1 v2) as PURE. + destruct (same_expr_pure a1 a2). + { rewrite <- PURE by auto. + inv H. + exists v1. split. assumption. + unfold Val.select. + destruct b; apply Val.lessdef_normalize. + } + clear PURE. + destruct Archi.ptr64 eqn:PTR64. + 2: discriminate. + destruct ty; cbn in *; try discriminate. + - (* Tint *) + inv H. TrivialExists. + + cbn. repeat econstructor; eassumption. + + cbn. f_equal. rewrite ExtValues.normalize_select01. + rewrite H3. destruct b. + * rewrite ExtValues.select01_long_true. apply normalize_low_long; assumption. + * rewrite ExtValues.select01_long_false. apply normalize_low_long; assumption. + + - (* Tfloat *) + inv H. TrivialExists. + + cbn. repeat econstructor; eassumption. + + cbn. f_equal. rewrite ExtValues.normalize_select01. + rewrite H3. destruct b. + * rewrite ExtValues.select01_long_true. + apply ExtValues.float_bits_normalize. + * rewrite ExtValues.select01_long_false. + apply ExtValues.float_bits_normalize. + + - (* Tlong *) + inv H. TrivialExists. + + cbn. repeat econstructor; eassumption. + + cbn. f_equal. rewrite ExtValues.normalize_select01. + rewrite H3. destruct b. + * rewrite ExtValues.select01_long_true. reflexivity. + * rewrite ExtValues.select01_long_false. reflexivity. + + - (* Tsingle *) + inv H. TrivialExists. + + cbn. repeat econstructor; eassumption. + + cbn. f_equal. rewrite ExtValues.normalize_select01. + rewrite H3. destruct b. + * rewrite ExtValues.select01_long_true. + rewrite normalize_low_long by assumption. + apply ExtValues.single_bits_normalize. + * rewrite ExtValues.select01_long_false. + rewrite normalize_low_long by assumption. + apply ExtValues.single_bits_normalize. Qed. Theorem eval_addressing: @@ -969,7 +1084,10 @@ Theorem eval_platform_builtin: platform_builtin_sem bf vl = Some v -> exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. Proof. - intros. discriminate. + destruct bf; intros until le; intro Heval. + all: try (inversion Heval; subst a; clear Heval; + exists v; split; trivial; + repeat (try econstructor; try eassumption)). Qed. End CMCONSTR. diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 1f02ca71..1f00c440 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -396,6 +396,10 @@ module Target : TARGET = fprintf oc " fmv.x.s %a, %a\n" ireg rd freg fs | Pfmvxd (rd,fs) -> fprintf oc " fmv.x.d %a, %a\n" ireg rd freg fs + | Pfmvsx (fd,rs) -> + fprintf oc " fmv.s.x %a, %a\n" freg fd ireg rs + | Pfmvdx (fd,rs) -> + fprintf oc " fmv.d.x %a, %a\n" freg fd ireg rs (* 32-bit (single-precision) floating point *) | Pfls (fd, ra, ofs) -> @@ -525,6 +529,8 @@ module Target : TARGET = fprintf oc " fcvt.s.d %a, %a\n" freg fd freg fs (* Pseudo-instructions expanded in Asmexpand *) + | Pselectl(_, _, _, _) -> + assert false | Pallocframe(sz, ofs) -> assert false | Pfreeframe(sz, ofs) -> diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index f4b7b4d6..d29180e4 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -17,6 +17,42 @@ Require Import Zbits. (** Value analysis for RISC V operators *) +Definition zero32 := (I Int.zero). +Definition zero64 := (L Int64.zero). + +(** Functions to select a special register (see Op.v) *) + +Definition apply_bin_oreg {B} (optR: option oreg) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := + match optR with + | None => sem v1 v2 + | Some X0_L => sem vz v1 + | Some X0_R => sem v1 vz + end. + +Definition eval_may_undef (mu: mayundef) (v1 v2: aval): aval := + match mu with + | MUint => match v1, v2 with + | I _, I _ => v2 + | _, _ => Ifptr Ptop + end + | MUlong => match v1, v2 with + | L _, I _ => v2 + | _, _ => Ifptr Ptop + end + | MUshrx i => + match v1, v2 with + | I _, I _ => + if Int.ltu i (Int.repr 31) then v2 else Ifptr Ptop + | _, _ => Ifptr Ptop + end + | MUshrxl i => + match v1, v2 with + | L _, L _ => + if Int.ltu i (Int.repr 63) then v2 else Ifptr Ptop + | _, _ => Ifptr Ptop + end + end. + Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 @@ -31,6 +67,22 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) + | CEbeqw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32 + | CEbequw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32 + | CEbneuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32 + | CEbltw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32 + | CEbgew optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpu_bool Cge) v1 v2 zero32 + | CEbeql optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64 + | CEbneul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64 + | CEbltl optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64 + | CEbgel optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR, v1 :: v2 :: nil => apply_bin_oreg optR (cmplu_bool Cge) v1 v2 zero64 | _, _ => Bnone end. @@ -42,6 +94,39 @@ Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := | _, _ => Vbot end. +Definition bits_of_single (v : aval) : aval := + match v with + | FS f => I (Float32.to_bits f) + | _ => ntop1 v + end. + +Definition bits_of_float (v : aval) : aval := + match v with + | F f => L (Float.to_bits f) + | _ => ntop1 v + end. + +Definition single_of_bits (v : aval) : aval := + match v with + | I f => FS (Float32.of_bits f) + | _ => ntop1 v + end. + +Definition float_of_bits (v : aval) : aval := + match v with + | L f => F (Float.of_bits f) + | _ => ntop1 v + end. + +Definition select01_long (vb : aval) (vt : aval) (vf : aval) := + match vb with + | I b => + if Int.eq b Int.one then add_undef vt + else if Int.eq b Int.zero then add_undef vf + else add_undef (vlub vt vf) + | _ => add_undef (vlub vt vf) + end. + Definition eval_static_operation (op: operation) (vl: list aval): aval := match op, vl with | Omove, v1::nil => v1 @@ -137,6 +222,47 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | OEseqw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Ceq) v1 v2 zero32) + | OEsnew optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Cne) v1 v2 zero32) + | OEsequw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Ceq) v1 v2 zero32) + | OEsneuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Cne) v1 v2 zero32) + | OEsltw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmp_bool Clt) v1 v2 zero32) + | OEsltuw optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpu_bool Clt) v1 v2 zero32) + | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) + | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) + | OExoriw n, v1::nil => xor v1 (I n) + | OEluiw n, nil => shl (I n) (I (Int.repr 12)) + | OEaddiw optR n, nil => apply_bin_oreg optR add (I n) (Ifptr Ptop) zero32 + | OEaddiw optR n, v1::nil => apply_bin_oreg optR add v1 (I n) (Ifptr Ptop) + | OEandiw n, v1::nil => and (I n) v1 + | OEoriw n, v1::nil => or (I n) v1 + | OEseql optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Ceq) v1 v2 zero64) + | OEsnel optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Cne) v1 v2 zero64) + | OEsequl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Ceq) v1 v2 zero64) + | OEsneul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Cne) v1 v2 zero64) + | OEsltl optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmpl_bool Clt) v1 v2 zero64) + | OEsltul optR, v1::v2::nil => of_optbool (apply_bin_oreg optR (cmplu_bool Clt) v1 v2 zero64) + | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) + | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) + | OEandil n, v1::nil => andl (L n) v1 + | OEoril n, v1::nil => orl (L n) v1 + | OExoril n, v1::nil => xorl v1 (L n) + | OEluil n, nil => sign_ext 32 (shll (L n) (L (Int64.repr 12))) + | OEaddil optR n, nil => apply_bin_oreg optR addl (L n) (Ifptr Ptop) zero64 + | OEaddil optR n, v1::nil => apply_bin_oreg optR addl v1 (L n) (Ifptr Ptop) + | OEloadli n, nil => L (n) + | OEmayundef mu, v1 :: v2 :: nil => eval_may_undef mu v1 v2 + | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) + | OEfltd, v1::v2::nil => of_optbool (cmpf_bool Clt v1 v2) + | OEfled, v1::v2::nil => of_optbool (cmpf_bool Cle v1 v2) + | OEfeqs, v1::v2::nil => of_optbool (cmpfs_bool Ceq v1 v2) + | OEflts, v1::v2::nil => of_optbool (cmpfs_bool Clt v1 v2) + | OEfles, v1::v2::nil => of_optbool (cmpfs_bool Cle v1 v2) + | Obits_of_single, v1::nil => bits_of_single v1 + | Obits_of_float, v1::nil => bits_of_float v1 + | Osingle_of_bits, v1::nil => single_of_bits v1 + | Ofloat_of_bits, v1::nil => float_of_bits v1 + | Oselectl, vb::vt::vf::nil => select01_long vb vt vf | _, _ => Vbot end. @@ -148,6 +274,75 @@ Hypothesis GENV: genv_match bc ge. Variable sp: block. Hypothesis STACK: bc sp = BCstack. +Lemma bits_of_single_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.bits_of_single v) (bits_of_single x). +Proof. + unfold ExtValues.bits_of_single; intros. inv H; cbn; constructor. +Qed. + +Lemma bits_of_float_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.bits_of_float v) (bits_of_float x). +Proof. + unfold ExtValues.bits_of_float; intros. inv H; cbn; constructor. +Qed. + +Lemma single_of_bits_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.single_of_bits v) (single_of_bits x). +Proof. + unfold ExtValues.bits_of_single; intros. inv H; cbn; constructor. +Qed. + +Lemma float_of_bits_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.float_of_bits v) (float_of_bits x). +Proof. + unfold ExtValues.bits_of_float; intros. inv H; cbn; constructor. +Qed. + + +Lemma select01_long_sound: + forall vb xb vt xt vf xf + (MATCH_b : vmatch bc vb xb) + (MATCH_t : vmatch bc vt xt) + (MATCH_f : vmatch bc vf xf), + vmatch bc (Val.normalize (ExtValues.select01_long vb vt vf) Tlong) + (select01_long xb xt xf). +Proof. + intros. + inv MATCH_b; cbn; try apply add_undef_undef. + - destruct (Int.eq i Int.one). { apply add_undef_normalize; trivial. } + destruct (Int.eq i Int.zero). { apply add_undef_normalize; trivial. } + cbn. apply add_undef_undef. + - destruct (Int.eq i Int.one). + { apply add_undef_normalize. + apply vmatch_lub_l. + trivial. } + destruct (Int.eq i Int.zero). + { apply add_undef_normalize. + apply vmatch_lub_r. + trivial. } + cbn. apply add_undef_undef. + - destruct (Int.eq i Int.one). + { apply add_undef_normalize. + apply vmatch_lub_l. + trivial. } + destruct (Int.eq i Int.zero). + { apply add_undef_normalize. + apply vmatch_lub_r. + trivial. } + cbn. apply add_undef_undef. + - destruct (Int.eq i Int.one). + { apply add_undef_normalize. + apply vmatch_lub_l. + trivial. } + destruct (Int.eq i Int.zero). + { apply add_undef_normalize. + apply vmatch_lub_r. + trivial. } + cbn. apply add_undef_undef. +Qed. + +Hint Resolve bits_of_single_sound bits_of_float_sound single_of_bits_sound float_of_bits_sound select01_long_sound : va. + Theorem eval_static_condition_sound: forall cond vargs m aargs, list_forall2 (vmatch bc) vargs aargs -> @@ -159,7 +354,9 @@ Proof. destruct cond; simpl; eauto with va. inv H2. destruct cond; simpl; eauto with va. - destruct cond; auto with va. + 17: destruct cond; simpl; eauto with va. + all: destruct optR as [[]|]; unfold apply_bin_oreg, Op.apply_bin_oreg; + unfold zero32, Op.zero32, zero64, Op.zero64; eauto with va. Qed. Lemma symbol_address_sound: @@ -201,6 +398,70 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. +Lemma of_optbool_maketotal_sound: + forall ob ab, cmatch ob ab -> vmatch bc (Val.maketotal (option_map Val.of_bool ob)) (of_optbool ab). +Proof. + intros. + assert (DEFAULT: vmatch bc (Val.maketotal (option_map Val.of_bool ob)) (Uns Pbot 1)). + { + destruct ob; simpl; auto with va. + destruct b; constructor; try omega. + change 1 with (usize Int.one). apply is_uns_usize. + red; intros. apply Int.bits_zero. + } + inv H; auto. simpl. destruct b; constructor. +Qed. + +Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR m, + c = Ceq \/ c = Cne \/ c = Clt-> + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc (Op.apply_bin_oreg optR (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmpu_bool c) b1 b0 zero32)). +Proof. + intros. + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; + apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. +Qed. + +Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR m, + c = Ceq \/ c = Cne \/ c = Clt-> + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc + (Val.maketotal + (Op.apply_bin_oreg optR (Val.cmplu (Mem.valid_pointer m) c) a1 a0 + Op.zero64)) + (of_optbool (apply_bin_oreg optR (cmplu_bool c) b1 b0 zero64)). +Proof. + intros. + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; + apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. +Qed. + +Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR cmp, + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc (Op.apply_bin_oreg optR (Val.cmp cmp) a1 a0 Op.zero32) + (of_optbool (apply_bin_oreg optR (cmp_bool cmp) b1 b0 zero32)). +Proof. + intros. + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; + apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. +Qed. + +Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR cmp, + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc + (Val.maketotal (Op.apply_bin_oreg optR (Val.cmpl cmp) a1 a0 Op.zero64)) + (of_optbool (apply_bin_oreg optR (cmpl_bool cmp) b1 b0 zero64)). +Proof. + intros. + destruct optR as [[]|]; unfold Op.apply_bin_oreg, apply_bin_oreg; + apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. +Qed. + Theorem eval_static_operation_sound: forall op vargs m vres aargs, eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> @@ -213,6 +474,39 @@ Proof. destruct (propagate_float_constants tt); constructor. rewrite Ptrofs.add_zero_l; eauto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + + 3,4,6: apply eval_cmpu_sound; auto. + 1,2,3: apply eval_cmp_sound; auto. + unfold Val.cmp; apply of_optbool_sound; eauto with va. + unfold Val.cmpu; apply of_optbool_sound; eauto with va. + + { destruct optR as [[]|]; simpl; eauto with va. } + { destruct optR as [[]|]; + unfold apply_bin_oreg, Op.apply_bin_oreg; eauto with va. } + { fold (Val.and (Vint n) a1); eauto with va. } + { fold (Val.or (Vint n) a1); eauto with va. } + { simpl; try destruct (Int.ltu _ _); eauto with va; unfold ntop1; + try apply vmatch_ifptr_undef. } + 9: { destruct optR as [[]|]; simpl; eauto with va. } + 9: { destruct optR as [[]|]; + unfold apply_bin_oreg, Op.apply_bin_oreg; eauto with va. } + 9: { fold (Val.andl (Vlong n) a1); eauto with va. } + 9: { fold (Val.orl (Vlong n) a1); eauto with va. } + 9: { simpl; unfold ntop1, sign_ext, Int64.sign_ext, sgn; simpl; + apply vmatch_ifptr_l. } + + 1,10: simpl; eauto with va. + 10: + unfold Op.eval_may_undef, eval_may_undef; destruct mu; + inv H1; inv H0; eauto with va; + try destruct (Int.ltu _ _); simpl; + try eapply vmatch_ifptr_p, pmatch_top'; eauto with va. + + 4,5,7: apply eval_cmplu_sound; auto. + 1,3,4: apply eval_cmpl_sound; auto. + 2: { unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. } + 2: { unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. } + all: unfold Val.cmpf; apply of_optbool_sound; eauto with va. Qed. End SOUNDNESS. diff --git a/scheduling/RTLpath.v b/scheduling/RTLpath.v index cccc8147..5b34dc16 100644 --- a/scheduling/RTLpath.v +++ b/scheduling/RTLpath.v @@ -85,6 +85,7 @@ Record path_info := { psize: nat; (* number minus 1 of instructions in the path *) input_regs: Regset.t; (** Registers that are used (as input_regs) by the "fallthrough successors" of the path *) + pre_output_regs: Regset.t; (** This field is not used by the verificator, but is helpful for the superblock scheduler *) output_regs: Regset.t }. diff --git a/scheduling/RTLpathCommon.ml b/scheduling/RTLpathCommon.ml new file mode 100644 index 00000000..3d123ba8 --- /dev/null +++ b/scheduling/RTLpathCommon.ml @@ -0,0 +1,14 @@ +open Maps +open Registers +open Camlcoq + +type superblock = { + mutable instructions: P.t array; (* pointers to code instructions *) + (* each predicted Pcb has its attached liveins *) + (* This is indexed by the pc value *) + mutable liveins: Regset.t PTree.t; + (* Union of the input_regs of the last successors *) + s_output_regs: Regset.t; + typing: RTLtyping.regenv +} + diff --git a/scheduling/RTLpathLivegen.v b/scheduling/RTLpathLivegen.v index 1f0ebe3c..9f646ad0 100644 --- a/scheduling/RTLpathLivegen.v +++ b/scheduling/RTLpathLivegen.v @@ -46,7 +46,6 @@ Proof. inversion_ASSERT; try_simplify_someHyps. Qed. -(* FIXME - what about trap? *) Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option (Regset.t * node) := match i with | Inop pc' => Some (alive, pc') @@ -63,7 +62,7 @@ Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): opti | Icond cond args ifso ifnot _ => ASSERT list_mem args alive IN exit_checker pm alive ifso (alive, ifnot) - | _ => None (* TODO jumptable ? *) + | _ => None end. @@ -109,6 +108,20 @@ Proof. * intros; eapply iinst_checker_path_entry; eauto. Qed. + +Lemma ipath_checker_default_succ (f: RTLpath.function) path: forall alive pc res, + ipath_checker path f (fn_path f) alive pc = Some res + -> nth_default_succ (fn_code f) path pc = Some (snd res). +Proof. + induction path; simpl. + + try_simplify_someHyps. + + intros alive pc res. + inversion_SOME i; intros INST. + inversion_SOME res0; intros ICHK IPCHK. + rewrite INST. + erewrite iinst_checker_default_succ; eauto. +Qed. + Definition reg_option_mem (or: option reg) (alive: Regset.t) := match or with None => true | Some r => Regset.mem r alive end. @@ -152,47 +165,69 @@ Qed. Local Hint Resolve exit_list_checker_correct: core. -Definition inst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option unit := +Definition final_inst_checker (pm: path_map) (alive por: Regset.t) (i: instruction): option unit := match i with | Icall sig ros args res pc' => ASSERT list_mem args alive IN ASSERT reg_sum_mem ros alive IN - exit_checker pm (Regset.add res alive) pc' tt + exit_checker pm (Regset.add res por) pc' tt | Itailcall sig ros args => ASSERT list_mem args alive IN ASSERT reg_sum_mem ros alive IN Some tt | Ibuiltin ef args res pc' => - ASSERT list_mem (params_of_builtin_args args) alive IN - exit_checker pm (reg_builtin_res res alive) pc' tt + ASSERT list_mem (params_of_builtin_args args) alive IN + exit_checker pm (reg_builtin_res res por) pc' tt | Ijumptable arg tbl => ASSERT Regset.mem arg alive IN - ASSERT exit_list_checker pm alive tbl IN + ASSERT exit_list_checker pm por tbl IN Some tt | Ireturn optarg => - ASSERT (reg_option_mem optarg) alive IN + ASSERT (reg_option_mem optarg) alive IN Some tt - | _ => - SOME res <- iinst_checker pm alive i IN - exit_checker pm (fst res) (snd res) tt + | _ => None end. -Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive: Regset.t) (i: instruction): - inst_checker pm alive i = Some tt -> +Lemma final_inst_checker_wellformed (c:code) pc (pm: path_map) (alive por: Regset.t) (i: instruction): + final_inst_checker pm alive por i = Some tt -> c!pc = Some i -> wellformed_path c pm 0 pc. Proof. intros CHECK PC. eapply wf_last_node; eauto. clear c pc PC. intros pc PC. destruct i; simpl in * |- *; intuition (subst; eauto); try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). - intros X; exploit exit_checker_res; eauto. - clear X. intros; subst; eauto. +Qed. + +Definition inst_checker (pm: path_map) (alive por: Regset.t) (i: instruction): option unit := + match iinst_checker pm alive i with + | Some res => + ASSERT Regset.subset por (fst res) IN + exit_checker pm por (snd res) tt + | _ => + ASSERT Regset.subset por alive IN + final_inst_checker pm alive por i + end. + +Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive por: Regset.t) (i: instruction): + inst_checker pm alive por i = Some tt -> + c!pc = Some i -> wellformed_path c pm 0 pc. +Proof. + unfold inst_checker. + destruct (iinst_checker pm alive i) as [[alive0 pc0]|] eqn: CHECK1; simpl. + - simpl; intros CHECK2 PC. eapply wf_last_node; eauto. + destruct i; simpl in * |- *; intuition (subst; eauto); + try (generalize CHECK2 CHECK1; clear CHECK1 CHECK2; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). + intros PC CHECK1 CHECK2. + intros; exploit exit_checker_res; eauto. + intros X; inversion X. intros; subst; eauto. + - simpl; intros CHECK2 PC. eapply final_inst_checker_wellformed; eauto. + generalize CHECK2. clear CHECK2. inversion_ASSERT. try_simplify_someHyps. Qed. Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := SOME res <- ipath_checker (path.(psize)) f pm (path.(input_regs)) pc IN SOME i <- f.(fn_code)!(snd res) IN - inst_checker pm (fst res) i. + inst_checker pm (fst res) (path.(pre_output_regs)) i. Lemma path_checker_wellformed f pm pc path: path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. diff --git a/scheduling/RTLpathLivegenaux.ml b/scheduling/RTLpathLivegenaux.ml index d415c115..2a20a15d 100644 --- a/scheduling/RTLpathLivegenaux.ml +++ b/scheduling/RTLpathLivegenaux.ml @@ -101,7 +101,7 @@ let get_path_map code entry join_points = dig_path_rec n' end | None -> Some ({ psize = (Camlcoq.Nat.of_int !psize); - input_regs = Regset.empty; output_regs = Regset.empty }, + input_regs = Regset.empty; pre_output_regs = Regset.empty; output_regs = Regset.empty }, !path_successors @ successors_inst inst) end in match dig_path_rec e with @@ -219,41 +219,50 @@ let analyze f = let rec traverse code n size = let inst = get_some @@ PTree.get n code in - if (size == 0) then inst + if (size == 0) then (inst, n) else let n' = get_some @@ predicted_successor inst in traverse code n' (size-1) -let get_outputs liveness code n pi = - let last_instruction = traverse code n (Camlcoq.Nat.to_int pi.psize) in +let get_outputs liveness f n pi = + let (last_instruction, pc_last) = traverse f.fn_code n (Camlcoq.Nat.to_int pi.psize) in let path_last_successors = successors_inst last_instruction in let list_input_regs = List.map ( fun n -> get_some @@ PTree.get n liveness ) path_last_successors in - List.fold_left Regset.union Regset.empty list_input_regs + let outputs = List.fold_left Regset.union Regset.empty list_input_regs in + let por = match last_instruction with (* see RTLpathLivegen.final_inst_checker *) + | Icall (_, _, _, res, _) -> Regset.remove res outputs + | Ibuiltin (_, _, res, _) -> Liveness.reg_list_dead (AST.params_of_builtin_res res) outputs + | Itailcall (_, _, _) | Ireturn _ -> + assert (outputs = Regset.empty); (* defensive check for performance *) + outputs + | _ -> outputs + in (por, outputs) let set_pathmap_liveness f pm = let liveness = analyze f in let new_pm = ref PTree.empty in - let code = f.fn_code in begin debug "Liveness: "; print_ptree_regset liveness; debug "\n"; List.iter (fun (n, pi) -> let inputs = get_some @@ PTree.get n liveness in - let outputs = get_outputs liveness code n pi in + let (por, outputs) = get_outputs liveness f n pi in new_pm := PTree.set n - {psize=pi.psize; input_regs=inputs; output_regs=outputs} !new_pm + {psize=pi.psize; input_regs=inputs; pre_output_regs=por; output_regs=outputs} !new_pm ) (PTree.elements pm); !new_pm end let print_path_info pi = begin debug "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); - debug "input_regs="; + debug "\ninput_regs="; print_regset pi.input_regs; - debug "; output_regs="; + debug "\n; pre_output_regs="; + print_regset pi.pre_output_regs; + debug "\n; output_regs="; print_regset pi.output_regs; - debug ")" + debug ")\n" end let print_path_map path_map = begin diff --git a/scheduling/RTLpathLivegenproof.v b/scheduling/RTLpathLivegenproof.v index c6125985..b02400bf 100644 --- a/scheduling/RTLpathLivegenproof.v +++ b/scheduling/RTLpathLivegenproof.v @@ -280,34 +280,22 @@ Proof. intuition. - (* Iload *) inversion_ASSERT; try_simplify_someHyps. - destruct t. (* TODO - simplify that proof ? *) - + inversion_SOME a0. intros EVAL. - erewrite <- eqlive_reg_listmem; eauto. - try_simplify_someHyps. - inversion_SOME v; try_simplify_someHyps. - repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. + destruct t. + inversion_SOME a0. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + inversion_SOME v; try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + 2: + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto; + destruct (eval_addressing _ _ _ _); + try destruct (Memory.Mem.loadv _ _ _); + try (intros; inv H1; repeat (econstructor; simpl; eauto)). + all: + eapply eqlive_reg_update; + eapply eqlive_reg_monotonic; eauto; + intros r0; rewrite regset_add_spec; intuition. - + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto. - destruct (eval_addressing _ _ _ _). - * destruct (Memory.Mem.loadv _ _ _). - ** intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - ** intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - * intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - (* Istore *) (repeat inversion_ASSERT); try_simplify_someHyps. inversion_SOME a0. intros EVAL. @@ -501,12 +489,23 @@ Proof. intros H; erewrite (EQLIVE r); eauto. Qed. +Lemma final_inst_checker_from_iinst_checker i sp rs m st pm alive por: + istep ge i sp rs m = Some st -> + final_inst_checker pm alive por i = None. +Proof. + destruct i; simpl; try congruence. +Qed. + +(* is it useful ? Lemma inst_checker_from_iinst_checker i sp rs m st pm alive: istep ge i sp rs m = Some st -> inst_checker pm alive i = (SOME res <- iinst_checker pm alive i IN exit_checker pm (fst res) (snd res) tt). Proof. - destruct i; simpl; try congruence. + unfold inst_checker. + destruct (iinst_checker pm alive i); simpl; auto. + destruct i; simpl; try congruence. Qed. +*) Lemma exit_checker_eqlive_ext1 (pm: path_map) (alive: Regset.t) (pc: node) r rs1 rs2: exit_checker pm (Regset.add r alive) pc tt = Some tt -> @@ -586,16 +585,17 @@ Proof. * intuition. eapply IHtbl; eauto. Qed. -Lemma inst_checker_eqlive (f: function) sp alive pc i rs1 rs2 m stk1 stk2 t s1: +Lemma final_inst_checker_eqlive (f: function) sp alive por pc i rs1 rs2 m stk1 stk2 t s1: list_forall2 eqlive_stackframes stk1 stk2 -> eqlive_reg (ext alive) rs1 rs2 -> + Regset.Subset por alive -> liveness_ok_function f -> (fn_code f) ! pc = Some i -> path_last_step ge pge stk1 f sp pc rs1 m t s1 -> - inst_checker (fn_path f) alive i = Some tt -> + final_inst_checker (fn_path f) alive por i = Some tt -> exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. Proof. - intros STACKS EQLIVE LIVENESS PC; + intros STACKS EQLIVE SUB LIVENESS PC; destruct 1 as [i' sp pc rs1 m st1| sp pc rs1 m sig ros args res pc' fd| st1 pc rs1 m sig ros args fd m'| @@ -604,28 +604,12 @@ Proof. st1 pc rs1 m optr m']; try_simplify_someHyps. + (* istate *) - intros PC ISTEP. erewrite inst_checker_from_iinst_checker; eauto. - inversion_SOME res. - intros. - destruct (icontinue st1) eqn: CONT. - - (* CONT => true *) - exploit iinst_checker_eqlive; eauto. - destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - exploit exit_checker_eqlive; eauto. - intros (path & PATH & EQLIVE2). - eapply eqlive_states_intro; eauto. - erewrite <- iinst_checker_istep_continue; eauto. - - (* CONT => false *) - intros; exploit iinst_checker_eqlive_stopped; eauto. - destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - eapply eqlive_states_intro; eauto. + intros PC ISTEP. erewrite final_inst_checker_from_iinst_checker; eauto. + congruence. + (* Icall *) repeat inversion_ASSERT. intros. exploit exit_checker_eqlive_ext1; eauto. + eapply eqlive_reg_monotonic; eauto. intros (path & PATH & EQLIVE2). eexists; split. - eapply exec_Icall; eauto. @@ -645,6 +629,7 @@ Proof. + (* Ibuiltin *) repeat inversion_ASSERT. intros. exploit exit_checker_eqlive_builtin_res; eauto. + eapply eqlive_reg_monotonic; eauto. intros (path & PATH & EQLIVE2). eexists; split. - eapply exec_Ibuiltin; eauto. @@ -654,6 +639,7 @@ Proof. + (* Ijumptable *) repeat inversion_ASSERT. intros. exploit exit_list_checker_eqlive; eauto. + eapply eqlive_reg_monotonic; eauto. intros (path & PATH & EQLIVE2). eexists; split. - eapply exec_Ijumptable; eauto. @@ -669,6 +655,44 @@ Proof. * eapply eqlive_states_return; eauto. Qed. +Lemma inst_checker_eqlive (f: function) sp alive por pc i rs1 rs2 m stk1 stk2 t s1: + list_forall2 eqlive_stackframes stk1 stk2 -> + eqlive_reg (ext alive) rs1 rs2 -> + liveness_ok_function f -> + (fn_code f) ! pc = Some i -> + path_last_step ge pge stk1 f sp pc rs1 m t s1 -> + inst_checker (fn_path f) alive por i = Some tt -> + exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. +Proof. + unfold inst_checker; + intros STACKS EQLIVE LIVENESS PC. + destruct (iinst_checker (fn_path f) alive i) as [res|] eqn: IICHECKER. + + destruct 1 as [i' sp pc rs1 m st1| | | | | ]; + try_simplify_someHyps. + intros IICHECKER PC ISTEP. inversion_ASSERT. + intros. + destruct (icontinue st1) eqn: CONT. + - (* CONT => true *) + exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + apply Regset.subset_2 in H. + exploit exit_checker_eqlive; eauto. + eapply eqlive_reg_monotonic; eauto. + intros (path & PATH & EQLIVE2). + eapply eqlive_states_intro; eauto. + erewrite <- iinst_checker_istep_continue; eauto. + - (* CONT => false *) + intros; exploit iinst_checker_eqlive_stopped; eauto. + destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + eapply eqlive_states_intro; eauto. + + inversion_ASSERT. + intros; exploit final_inst_checker_eqlive; eauto. +Qed. + Lemma path_step_eqlive path stk1 f sp rs1 m pc t s1 stk2 rs2: path_step ge pge (psize path) stk1 f sp rs1 m pc t s1 -> list_forall2 eqlive_stackframes stk1 stk2 -> diff --git a/scheduling/RTLpathSE_impl.v b/scheduling/RTLpathSE_impl.v index 38930a75..e21d7cd1 100644 --- a/scheduling/RTLpathSE_impl.v +++ b/scheduling/RTLpathSE_impl.v @@ -7,6 +7,7 @@ Require Import RTL RTLpath. Require Import Errors. Require Import RTLpathSE_theory RTLpathLivegenproof. Require Import Axioms RTLpathSE_simu_specs. +Require Import RTLpathSE_simplify. Local Open Scope error_monad_scope. Local Open Scope option_monad_scope. @@ -22,7 +23,7 @@ Import ListNotations. Local Open Scope list_scope. Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := RET tt. (* TO REMOVE DEBUG INFO *) -(* Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := DO s <~ k x;; println ("DEBUG simu_check:" +; s). (* TO INSERT DEBUG INFO *) *) +(*Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := DO s <~ k x;; println ("DEBUG simu_check:" +; s). (* TO INSERT DEBUG INFO *)*) Definition DEBUG (s: pstring): ?? unit := XDEBUG tt (fun _ => RET s). @@ -291,6 +292,15 @@ Definition hSop (op:operation) (lhsv: list_hsval): ?? hsval := DO hv <~ hSop_hcodes op lhsv;; hC_hsval {| hdata:=HSop op lhsv unknown_hid; hcodes :=hv |}. +Lemma hSop_fSop_correct op lhsv: + WHEN hSop op lhsv ~> hv THEN forall ge sp rs0 m0, + seval_hsval ge sp hv rs0 m0 = seval_hsval ge sp (fSop op lhsv) rs0 m0. +Proof. + wlp_simplify. +Qed. +Global Opaque hSop. +Local Hint Resolve hSop_fSop_correct: wlp_raw. + Lemma hSop_correct op lhsv: WHEN hSop op lhsv ~> hv THEN forall ge sp rs0 m0 lsv sm m (MEM: seval_smem ge sp sm rs0 m0 = Some m) @@ -298,12 +308,11 @@ Lemma hSop_correct op lhsv: (LR: list_sval_refines ge sp rs0 m0 lhsv lsv), sval_refines ge sp rs0 m0 hv (Sop op lsv sm). Proof. - wlp_simplify. - rewrite <- H, MEM, LR. - destruct (seval_list_sval _ _ lsv _); try congruence. - eapply op_valid_pointer_eq; eauto. + generalize fSop_correct; simpl. + intros X. + wlp_xsimplify ltac:(intuition eauto with wlp wlp_raw). + erewrite H, X; eauto. Qed. -Global Opaque hSop. Local Hint Resolve hSop_correct: wlp. Definition hSload_hcodes (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval):= @@ -430,6 +439,68 @@ Qed. Global Opaque hlist_args. Local Hint Resolve hlist_args_correct: wlp. +(** Convert a "fake" hash-consed term into a "real" hash-consed term *) + +Fixpoint fsval_proj hsv: ?? hsval := + match hsv with + | HSinput r hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then hSinput r (* was not yet really hash-consed *) + else RET hsv (* already hash-consed *) + | HSop op hl hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then (* was not yet really hash-consed *) + DO hl' <~ fsval_list_proj hl;; + hSop op hl' + else RET hsv (* already hash-consed *) + | HSload hm t chk addr hl _ => RET hsv (* FIXME ? *) + end +with fsval_list_proj hsl: ?? list_hsval := + match hsl with + | HSnil hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then hSnil() (* was not yet really hash-consed *) + else RET hsl (* already hash-consed *) + | HScons hv hl hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then (* was not yet really hash-consed *) + DO hv' <~ fsval_proj hv;; + DO hl' <~ fsval_list_proj hl;; + hScons hv' hl' + else RET hsl (* already hash-consed *) + end. + +Lemma fsval_proj_correct hsv: + WHEN fsval_proj hsv ~> hsv' THEN forall ge sp rs0 m0, + seval_hsval ge sp hsv rs0 m0 = seval_hsval ge sp hsv' rs0 m0. +Proof. + induction hsv using hsval_mut + with (P0 := fun lhsv => + WHEN fsval_list_proj lhsv ~> lhsv' THEN forall ge sp rs0 m0, + seval_list_hsval ge sp lhsv rs0 m0 = seval_list_hsval ge sp lhsv' rs0 m0) + (P1 := fun sm => True); try (wlp_simplify; tauto). + - wlp_xsimplify ltac:(intuition eauto with wlp_raw wlp). + rewrite H, H0; auto. + - wlp_simplify; erewrite H0, H1; eauto. +Qed. +Global Opaque fsval_proj. +Local Hint Resolve fsval_proj_correct: wlp. + +Lemma fsval_list_proj_correct lhsv: + WHEN fsval_list_proj lhsv ~> lhsv' THEN forall ge sp rs0 m0, + seval_list_hsval ge sp lhsv rs0 m0 = seval_list_hsval ge sp lhsv' rs0 m0. +Proof. + induction lhsv; wlp_simplify. + erewrite H0, H1; eauto. +Qed. +Global Opaque fsval_list_proj. +Local Hint Resolve fsval_list_proj_correct: wlp. + + (** ** Assignment of memory *) Definition hslocal_set_smem (hst:hsistate_local) hm := {| hsi_smem := hm; @@ -601,10 +672,14 @@ Definition simplify (rsv: root_sval) (lr: list reg) (hst: hsistate_local): ?? hs match rsv with | Rop op => match is_move_operation op lr with - | Some arg => hsi_sreg_get hst arg (** optimization of Omove *) + | Some arg => hsi_sreg_get hst arg (* optimization of Omove *) | None => - DO lhsv <~ hlist_args hst lr;; - hSop op lhsv + match target_op_simplify op lr hst with + | Some fhv => fsval_proj fhv + | None => + DO lhsv <~ hlist_args hst lr;; + hSop op lhsv + end end | Rload _ chunk addr => DO lhsv <~ hlist_args hst lr;; @@ -620,17 +695,21 @@ Lemma simplify_correct rsv lr hst: Proof. destruct rsv; simpl; auto. - (* Rop *) - destruct (is_move_operation _ _) eqn: Hmove; wlp_simplify. - + exploit is_move_operation_correct; eauto. + destruct (is_move_operation _ _) eqn: Hmove. + { wlp_simplify; exploit is_move_operation_correct; eauto. intros (Hop & Hlsv); subst; simpl in *. simplify_SOME z. * erewrite H; eauto. * try_simplify_someHyps; congruence. - * congruence. - + clear Hmove. - generalize (H0 ge sp rs0 m0 (list_sval_inj (map (si_sreg st) lr)) (si_smem st)); clear H0. - destruct (seval_smem ge sp (si_smem st) rs0 m0) as [m|] eqn:X; eauto. - intro H0; clear H0; simplify_SOME z; congruence. (* absurd case *) + * congruence. } + destruct (target_op_simplify _ _ _) eqn: Htarget_op_simp; wlp_simplify. + { destruct (seval_list_sval _ _ _) eqn: OKlist; try congruence. + destruct (seval_smem _ _ _ _ _) eqn: OKmem; try congruence. + rewrite <- H; exploit target_op_simplify_correct; eauto. } + clear Htarget_op_simp. + generalize (H0 ge sp rs0 m0 (list_sval_inj (map (si_sreg st) lr)) (si_smem st)); clear H0. + destruct (seval_smem ge sp (si_smem st) rs0 m0) as [m|] eqn:X; eauto. + intro H0; clear H0; simplify_SOME z; congruence. (* absurd case *) - (* Rload *) destruct trap; wlp_simplify. erewrite H0; eauto. @@ -746,6 +825,46 @@ Local Hint Resolve hslocal_set_sreg_correct: wlp. (** ** Execution of one instruction *) +(* TODO gourdinl + * This is just useful for debugging fake values hashcode projection *) +Fixpoint check_no_uhid lhsv := + match lhsv with + | HSnil hc => + DO b <~ phys_eq hc unknown_hid;; + assert_b (negb b) "fail no uhid";; + RET tt + | HScons hsv lhsv' hc => + DO b <~ phys_eq hc unknown_hid;; + assert_b (negb b) "fail no uhid";; + check_no_uhid lhsv' + end. + +Definition cbranch_expanse (prev: hsistate_local) (cond: condition) (args: list reg): ?? (condition * list_hsval) := + match target_cbranch_expanse prev cond args with + | Some (cond', vargs) => + DO vargs' <~ fsval_list_proj vargs;; + RET (cond', vargs') + | None => + DO vargs <~ hlist_args prev args ;; + RET (cond, vargs) + end. + +Lemma cbranch_expanse_correct hst c l: + WHEN cbranch_expanse hst c l ~> r THEN forall ge sp rs0 m0 st + (LREF : hsilocal_refines ge sp rs0 m0 hst st) + (OK: hsok_local ge sp rs0 m0 hst), + seval_condition ge sp (fst r) (hsval_list_proj (snd r)) (si_smem st) rs0 m0 = + seval_condition ge sp c (list_sval_inj (map (si_sreg st) l)) (si_smem st) rs0 m0. +Proof. + unfold cbranch_expanse. + destruct (target_cbranch_expanse _ _ _) eqn: TARGET; wlp_simplify; + unfold seval_condition; erewrite <- H; eauto. + destruct p as [c' l']; simpl. + exploit target_cbranch_expanse_correct; eauto. +Qed. +Local Hint Resolve cbranch_expanse_correct: wlp. +Global Opaque cbranch_expanse. + Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) := match i with | Inop pc' => @@ -761,13 +880,13 @@ Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) : RET (Some (hsist_set_local hst pc' next)) | Icond cond args ifso ifnot _ => let prev := hst.(hsi_local) in - DO vargs <~ hlist_args prev args ;; + DO res <~ cbranch_expanse prev cond args;; + let (cond, vargs) := res in let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in RET (Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |}) - | _ => RET None (* TODO jumptable ? *) + | _ => RET None end. - Remark hsiexec_inst_None_correct i hst: WHEN hsiexec_inst i hst ~> o THEN forall st, o = None -> siexec_inst i st = None. Proof. @@ -794,6 +913,52 @@ Qed. Local Hint Resolve hsist_set_local_correct_stat: core. +Lemma hsiexec_cond_noexp (hst: hsistate): forall l c0 n n0, + WHEN DO res <~ + (DO vargs <~ hlist_args (hsi_local hst) l;; RET ((c0, vargs)));; + (let (cond, vargs) := res in + RET (Some + {| + hsi_pc := n0; + hsi_exits := {| + hsi_cond := cond; + hsi_scondargs := vargs; + hsi_elocal := hsi_local hst; + hsi_ifso := n |} :: hsi_exits hst; + hsi_local := hsi_local hst |})) ~> o0 + THEN (forall (hst' : hsistate) (st : sistate), + o0 = Some hst' -> + exists st' : sistate, + Some + {| + si_pc := n0; + si_exits := {| + si_cond := c0; + si_scondargs := list_sval_inj + (map (si_sreg (si_local st)) l); + si_elocal := si_local st; + si_ifso := n |} :: si_exits st; + si_local := si_local st |} = Some st' /\ + (hsistate_refines_stat hst st -> hsistate_refines_stat hst' st') /\ + (forall (ge : RTL.genv) (sp : val) (rs0 : regset) (m0 : mem), + hsistate_refines_dyn ge sp rs0 m0 hst st -> + hsistate_refines_dyn ge sp rs0 m0 hst' st')). +Proof. + intros. + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + - unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. + constructor; simpl; eauto. + constructor. + - destruct H0 as (EXREF & LREF & NEST). + split. + + constructor; simpl; auto. + constructor; simpl; auto. + intros; erewrite seval_condition_refines; eauto. + + split; simpl; auto. + destruct NEST as [|st0 se lse TOP NEST]; + econstructor; simpl; auto; constructor; auto. +Qed. + Lemma hsiexec_inst_correct i hst: WHEN hsiexec_inst i hst ~> o THEN forall hst' st, o = Some hst' -> @@ -801,29 +966,33 @@ Lemma hsiexec_inst_correct i hst: /\ (forall (REF:hsistate_refines_stat hst st), hsistate_refines_stat hst' st') /\ (forall ge sp rs0 m0 (REF:hsistate_refines_dyn ge sp rs0 m0 hst st), hsistate_refines_dyn ge sp rs0 m0 hst' st'). Proof. - destruct i; simpl; wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + destruct i; simpl; + try (wlp_simplify; try_simplify_someHyps; eexists; intuition eauto; fail). - (* refines_dyn Iop *) + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. eapply hsist_set_local_correct_dyn; eauto. generalize (sok_local_set_sreg_simp (Rop o)); simpl; eauto. - (* refines_dyn Iload *) + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. eapply hsist_set_local_correct_dyn; eauto. generalize (sok_local_set_sreg_simp (Rload t0 m a)); simpl; eauto. - (* refines_dyn Istore *) + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. eapply hsist_set_local_correct_dyn; eauto. unfold sok_local; simpl; intuition. - (* refines_stat Icond *) - unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. - constructor; simpl; eauto. - constructor. - - (* refines_dyn Icond *) - destruct REF as (EXREF & LREF & NEST). - split. - + constructor; simpl; auto. - constructor; simpl; auto. - intros; erewrite seval_condition_refines; eauto. - + split; simpl; auto. - destruct NEST as [|st0 se lse TOP NEST]; - econstructor; simpl; auto; constructor; auto. + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + + unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. + constructor; simpl; eauto. + constructor. + + destruct REF as (EXREF & LREF & NEST). + split. + * constructor; simpl; auto. + constructor; simpl; auto. + intros; erewrite seval_condition_refines; eauto. + * split; simpl; auto. + destruct NEST as [|st0 se lse TOP NEST]; + econstructor; simpl; auto; constructor; auto. Qed. Global Opaque hsiexec_inst. Local Hint Resolve hsiexec_inst_correct: wlp. @@ -1149,22 +1318,6 @@ Qed. Global Opaque PTree_frame_eq_check. Local Hint Resolve PTree_frame_eq_check_correct: wlp. -Definition hsilocal_simu_check hst1 hst2 : ?? unit := - DEBUG("? last check");; - phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_simu_check: hsi_smem sets aren't equiv";; - PTree_eq_check (hsi_sreg hst1) (hsi_sreg hst2);; - Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; - DEBUG("=> last check: OK"). - -Lemma hsilocal_simu_check_correct hst1 hst2: - WHEN hsilocal_simu_check hst1 hst2 ~> _ THEN - hsilocal_simu_spec None hst1 hst2. -Proof. - unfold hsilocal_simu_spec; wlp_simplify. -Qed. -Hint Resolve hsilocal_simu_check_correct: wlp. -Global Opaque hsilocal_simu_check. - Definition hsilocal_frame_simu_check frame hst1 hst2 : ?? unit := DEBUG("? frame check");; phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_frame_simu_check: hsi_smem sets aren't equiv";; @@ -1192,7 +1345,7 @@ Local Hint Resolve regset_elements_in: core. Lemma hsilocal_frame_simu_check_correct hst1 hst2 alive: WHEN hsilocal_frame_simu_check (Regset.elements alive) hst1 hst2 ~> _ THEN - hsilocal_simu_spec (Some alive) hst1 hst2. + hsilocal_simu_spec alive hst1 hst2. Proof. unfold hsilocal_simu_spec; wlp_simplify. symmetry; eauto. Qed. @@ -1246,13 +1399,13 @@ Qed. Hint Resolve hsiexits_simu_check_correct: wlp. Global Opaque hsiexits_simu_check. -Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsistate) := +Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) outframe (hst1 hst2: hsistate) := hsiexits_simu_check dm f (hsi_exits hst1) (hsi_exits hst2);; - hsilocal_simu_check (hsi_local hst1) (hsi_local hst2). + hsilocal_frame_simu_check (Regset.elements outframe) (hsi_local hst1) (hsi_local hst2). -Lemma hsistate_simu_check_correct dm f hst1 hst2: - WHEN hsistate_simu_check dm f hst1 hst2 ~> _ THEN - hsistate_simu_spec dm f hst1 hst2. +Lemma hsistate_simu_check_correct dm f outframe hst1 hst2: + WHEN hsistate_simu_check dm f outframe hst1 hst2 ~> _ THEN + hsistate_simu_spec dm f outframe hst1 hst2. Proof. unfold hsistate_simu_spec; wlp_simplify. Qed. @@ -1386,18 +1539,18 @@ Qed. Hint Resolve sfval_simu_check_correct: wlp. Global Opaque sfval_simu_check. -Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := - hsistate_simu_check dm f (hinternal hst1) (hinternal hst2);; +Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) outframe (hst1 hst2: hsstate) := + hsistate_simu_check dm f outframe (hinternal hst1) (hinternal hst2);; sfval_simu_check dm f (hsi_pc hst1) (hsi_pc hst2) (hfinal hst1) (hfinal hst2). -Lemma hsstate_simu_check_correct dm f hst1 hst2: - WHEN hsstate_simu_check dm f hst1 hst2 ~> _ THEN - hsstate_simu_spec dm f hst1 hst2. +Lemma hsstate_simu_check_correct dm f outframe hst1 hst2: + WHEN hsstate_simu_check dm f outframe hst1 hst2 ~> _ THEN + hsstate_simu_spec dm f outframe hst1 hst2. Proof. unfold hsstate_simu_spec; wlp_simplify. Qed. Hint Resolve hsstate_simu_check_correct: wlp. -Global Opaque hsstate_simu_check. +Global Opaque hsstate_simu_check. Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node): ?? unit := let (pc2, pc1) := m in @@ -1411,8 +1564,10 @@ Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpa DO hst1 <~ hsexec f pc1;; XDEBUG pc2 (fun pc => DO name_pc <~ string_of_Z (Zpos pc);; RET ("entry-point of output superblock: " +; name_pc)%string);; DO hst2 <~ hsexec tf pc2;; + DO path <~ some_or_fail ((fn_path f)!pc1) "simu_check_single.internal_error.1";; + let outframe := path.(pre_output_regs) in (* comparing the executions *) - hsstate_simu_check dm f hst1 hst2. + hsstate_simu_check dm f outframe hst1 hst2. Lemma simu_check_single_correct dm tf f pc1 pc2: WHEN simu_check_single dm f tf (pc2, pc1) ~> _ THEN @@ -1423,7 +1578,7 @@ Proof. intros (st2 & SEXEC2 & REF2). try_simplify_someHyps. exploit H3; clear H3. 1-3: wlp_simplify. intros (st3 & SEXEC3 & REF3). try_simplify_someHyps. - eexists. split; eauto. + eexists. eexists. split; eauto. split; eauto. intros ctx. eapply hsstate_simu_spec_correct; eauto. Qed. @@ -1506,4 +1661,4 @@ Proof. destruct (unsafe_coerce (aux_simu_check dm f tf)) as [[|]|] eqn:Hres; simpl; try discriminate. intros; eapply aux_simu_check_correct; eauto. eapply unsafe_coerce_not_really_correct; eauto. -Qed.
\ No newline at end of file +Qed. diff --git a/scheduling/RTLpathSE_simu_specs.v b/scheduling/RTLpathSE_simu_specs.v index c9e272c0..c3266db9 100644 --- a/scheduling/RTLpathSE_simu_specs.v +++ b/scheduling/RTLpathSE_simu_specs.v @@ -12,16 +12,17 @@ Local Open Scope error_monad_scope. Local Open Scope option_monad_scope. Require Export Impure.ImpHCons. +Import HConsing. Import ListNotations. Local Open Scope list_scope. (** * Auxilary notions on simulation tests *) -Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := +Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) outframe (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := forall is1, ssem_local (the_ge1 ctx) (the_sp ctx) sl1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) -> exists is2, ssem_local (the_ge2 ctx) (the_sp ctx) sl2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) - /\ istate_simu f dm is1 is2. + /\ istate_simu f dm outframe is1 is2. (* a kind of negation of sabort_local *) Definition sok_local (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) (st: sistate_local): Prop := @@ -36,7 +37,7 @@ Proof. intuition congruence. Qed. -Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof_context f) (se1 se2: sistate_exit) := +Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) outframe (ctx: simu_proof_context f) (se1 se2: sistate_exit) := (sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1) -> (seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond se1) (si_scondargs se1) (si_smem (si_elocal se1)) (the_rs0 ctx) (the_m0 ctx)) = @@ -47,10 +48,10 @@ Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof ssem_exit (the_ge1 ctx) (the_sp ctx) se1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) (ipc is1) -> exists is2, ssem_exit (the_ge2 ctx) (the_sp ctx) se2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) (ipc is2) - /\ istate_simu f dm is1 is2. + /\ istate_simu f dm outframe is1 is2. -Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := - list_forall2 (siexit_simu dm f ctx) lse1 lse2. +Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) outframe (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := + list_forall2 (siexit_simu dm f outframe ctx) lse1 lse2. (** * Implementation of Data-structure use in Hash-consing *) @@ -304,6 +305,65 @@ Inductive hfinal_refines: hsfval -> sfval -> Prop := End HFINAL_REFINES. +(* TODO gourdinl Leave this here ? *) +Section FAKE_HSVAL. +(* BEGIN "fake" hsval without real hash-consing *) +(* TODO: + 2) reuse these definitions in hSinput, hSop, etc + in order to factorize proofs ? +*) + +Definition fSinput (r: reg): hsval := + HSinput r unknown_hid. + +Lemma fSinput_correct r ge sp rs0 m0: (* useless trivial lemma ? *) + sval_refines ge sp rs0 m0 (fSinput r) (Sinput r). +Proof. + auto. +Qed. + +Definition fSop (op:operation) (lhsv: list_hsval): hsval := + HSop op lhsv unknown_hid. + +Lemma fSop_correct op lhsv ge sp rs0 m0 lsv sm m: forall + (MEM: seval_smem ge sp sm rs0 m0 = Some m) + (MVALID: forall b ofs, Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (LR: list_sval_refines ge sp rs0 m0 lhsv lsv), + sval_refines ge sp rs0 m0 (fSop op lhsv) (Sop op lsv sm). +Proof. + intros; simpl. rewrite <- LR, MEM. + destruct (seval_list_sval _ _ _ _); try congruence. + eapply op_valid_pointer_eq; eauto. +Qed. + +Definition fsi_sreg_get (hst: PTree.t hsval) r: hsval := + match PTree.get r hst with + | None => fSinput r + | Some sv => sv + end. + +Lemma fsi_sreg_get_correct hst r ge sp rs0 m0 (f: reg -> sval): forall + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + sval_refines ge sp rs0 m0 (fsi_sreg_get hst r) (f r). +Proof. + unfold hsi_sreg_eval, hsi_sreg_proj, fsi_sreg_get; intros; simpl. + rewrite <- RR. destruct (hst ! r); simpl; auto. +Qed. + +Definition fSnil: list_hsval := + HSnil unknown_hid. + +(* TODO: Lemma fSnil_correct *) + +Definition fScons (hsv: hsval) (lhsv: list_hsval): list_hsval := + HScons hsv lhsv unknown_hid. + +(* TODO: Lemma fScons_correct *) + +(* END "fake" hsval ... *) + +End FAKE_HSVAL. + Record hsstate := { hinternal:> hsistate; hfinal: hsfval }. @@ -318,9 +378,9 @@ Definition hsstate_refines (hst: hsstate) (st:sstate): Prop := (** ** Specification of the simulation test on [hsistate_local]. It is motivated by [hsilocal_simu_spec_correct theorem] below *) -Definition hsilocal_simu_spec (oalive: option Regset.t) (hst1 hst2: hsistate_local) := +Definition hsilocal_simu_spec (alive: Regset.t) (hst1 hst2: hsistate_local) := List.incl (hsi_ok_lsval hst2) (hsi_ok_lsval hst1) - /\ (forall r, (match oalive with Some alive => Regset.In r alive | _ => True end) -> PTree.get r hst2 = PTree.get r hst1) + /\ (forall r, Regset.In r alive -> PTree.get r hst2 = PTree.get r hst1) /\ hsi_smem hst1 = hsi_smem hst2. Definition seval_sval_partial ge sp rs0 m0 hsv := @@ -368,18 +428,14 @@ Proof. - erewrite MEMOK in OKM. erewrite smem_eval_preserved; eauto. Qed. -Theorem hsilocal_simu_spec_correct hst1 hst2 of ge1 ge2 sp rs0 m0 rs m st1 st2: - hsilocal_simu_spec of hst1 hst2 -> +Theorem hsilocal_simu_spec_correct hst1 hst2 alive ge1 ge2 sp rs0 m0 rs m st1 st2: + hsilocal_simu_spec alive hst1 hst2 -> hsilocal_refines ge1 sp rs0 m0 hst1 st1 -> hsilocal_refines ge2 sp rs0 m0 hst2 st2 -> (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> ssem_local ge1 sp st1 rs0 m0 rs m -> - match of with - | None => ssem_local ge2 sp st2 rs0 m0 rs m - | Some alive => - let rs' := seval_partial_regset ge2 sp rs0 m0 (hsi_sreg hst2) - in ssem_local ge2 sp st2 rs0 m0 rs' m /\ eqlive_reg (fun r => Regset.In r alive) rs rs' - end. + let rs' := seval_partial_regset ge2 sp rs0 m0 (hsi_sreg hst2) + in ssem_local ge2 sp st2 rs0 m0 rs' m /\ eqlive_reg (fun r => Regset.In r alive) rs rs'. Proof. intros CORE HREF1 HREF2 GFS SEML. refine (modusponens _ _ (ssem_local_refines_hok _ _ _ _ _ _ _ _ _ _) _); eauto. @@ -394,9 +450,8 @@ Proof. rewrite <- MEMEQ2; auto. rewrite <- MEMEQ3. erewrite smem_eval_preserved; [| eapply GFS]. rewrite MEMEQ1; auto. } - destruct of as [alive |]. - - constructor. - + constructor; [assumption | constructor; [assumption|]]. + constructor. + + constructor; [assumption | constructor; [assumption|]]. destruct HREF2 as (B & _ & A & _). (** B is used for the auto below. *) assert (forall r : positive, hsi_sreg_eval ge2 sp hst2 r rs0 m0 = seval_sval ge2 sp (si_sreg st2 r) rs0 m0) by auto. @@ -420,17 +475,6 @@ Proof. unfold hsi_sreg_eval, hsi_sreg_proj in B; rewrite B; [|assumption]. rewrite RSEQ. reflexivity. ++ rewrite <- RSEQ. rewrite <- B; [|assumption]. unfold hsi_sreg_eval, hsi_sreg_proj. rewrite <- C; [|assumption]. rewrite HST2. reflexivity. - - constructor; [|constructor]. - + destruct HREF2 as (OKEQ & _ & _). rewrite <- OKEQ in HOK2. apply HOK2. - + destruct HREF2 as (_ & MEMEQ2 & _). destruct HREF1 as (_ & MEMEQ1 & _). - destruct CORE as (_ & _ & MEMEQ3). - rewrite <- MEMEQ2; auto. rewrite <- MEMEQ3. - erewrite smem_eval_preserved; [| eapply GFS]. - rewrite MEMEQ1; auto. - + intro r. destruct HREF2 as (_ & _ & A & _). destruct HREF1 as (_ & _ & B & _). - destruct CORE as (_ & C & _). rewrite <- A; auto. unfold hsi_sreg_eval, hsi_sreg_proj. - rewrite C; [|auto]. erewrite seval_preserved; [| eapply GFS]. - unfold hsi_sreg_eval, hsi_sreg_proj in B; rewrite B; auto. Qed. (** ** Specification of the simulation test on [hsistate_exit]. @@ -438,17 +482,17 @@ Qed. *) Definition hsiexit_simu_spec dm f (hse1 hse2: hsistate_exit) := (exists path, (fn_path f) ! (hsi_ifso hse1) = Some path - /\ hsilocal_simu_spec (Some path.(input_regs)) (hsi_elocal hse1) (hsi_elocal hse2)) + /\ hsilocal_simu_spec path.(input_regs) (hsi_elocal hse1) (hsi_elocal hse2)) /\ dm ! (hsi_ifso hse2) = Some (hsi_ifso hse1) /\ hsi_cond hse1 = hsi_cond hse2 /\ hsi_scondargs hse1 = hsi_scondargs hse2. -Definition hsiexit_simu dm f (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, +Definition hsiexit_simu dm f outframe (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, hsiexit_refines_stat hse1 se1 -> hsiexit_refines_stat hse2 se2 -> hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> - siexit_simu dm f ctx se1 se2. + siexit_simu dm f outframe ctx se1 se2. Lemma hsiexit_simu_spec_nofail dm f hse1 hse2 ge1 ge2 sp rs m: hsiexit_simu_spec dm f hse1 hse2 -> @@ -461,9 +505,9 @@ Proof. eapply hsilocal_simu_spec_nofail; eauto. Qed. -Theorem hsiexit_simu_spec_correct dm f hse1 hse2 ctx: +Theorem hsiexit_simu_spec_correct dm f outframe hse1 hse2 ctx: hsiexit_simu_spec dm f hse1 hse2 -> - hsiexit_simu dm f ctx hse1 hse2. + hsiexit_simu dm f outframe ctx hse1 hse2. Proof. intros SIMUC st1 st2 HREF1 HREF2 HDYN1 HDYN2. assert (SEVALC: @@ -498,13 +542,13 @@ Proof. constructor; [|constructor]; simpl; auto. Qed. -Remark hsiexit_simu_siexit dm f ctx hse1 hse2 se1 se2: - hsiexit_simu dm f ctx hse1 hse2 -> +Remark hsiexit_simu_siexit dm f outframe ctx hse1 hse2 se1 se2: + hsiexit_simu dm f outframe ctx hse1 hse2 -> hsiexit_refines_stat hse1 se1 -> hsiexit_refines_stat hse2 se2 -> hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> - siexit_simu dm f ctx se1 se2. + siexit_simu dm f outframe ctx se1 se2. Proof. auto. Qed. @@ -513,15 +557,15 @@ Qed. It is motivated by [hsiexit_simu_spec_correct theorem] below *) -Definition hsiexits_simu dm f (ctx: simu_proof_context f) (lhse1 lhse2: list hsistate_exit): Prop := - list_forall2 (hsiexit_simu dm f ctx) lhse1 lhse2. +Definition hsiexits_simu dm f outframe (ctx: simu_proof_context f) (lhse1 lhse2: list hsistate_exit): Prop := + list_forall2 (hsiexit_simu dm f outframe ctx) lhse1 lhse2. Definition hsiexits_simu_spec dm f lhse1 lhse2: Prop := list_forall2 (hsiexit_simu_spec dm f) lhse1 lhse2. -Theorem hsiexits_simu_spec_correct dm f lhse1 lhse2 ctx: +Theorem hsiexits_simu_spec_correct dm f outframe lhse1 lhse2 ctx: hsiexits_simu_spec dm f lhse1 lhse2 -> - hsiexits_simu dm f ctx lhse1 lhse2. + hsiexits_simu dm f outframe ctx lhse1 lhse2. Proof. induction 1; [constructor|]. constructor; [|apply IHlist_forall2; assumption]. @@ -529,8 +573,8 @@ Proof. Qed. -Lemma siexits_simu_all_fallthrough dm f ctx: forall lse1 lse2, - siexits_simu dm f lse1 lse2 ctx -> +Lemma siexits_simu_all_fallthrough dm f outframe ctx: forall lse1 lse2, + siexits_simu dm f outframe lse1 lse2 ctx -> all_fallthrough (the_ge1 ctx) (the_sp ctx) lse1 (the_rs0 ctx) (the_m0 ctx) -> (forall se1, In se1 lse1 -> sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1)) -> all_fallthrough (the_ge2 ctx) (the_sp ctx) lse2 (the_rs0 ctx) (the_m0 ctx). @@ -545,8 +589,8 @@ Proof. Qed. -Lemma siexits_simu_all_fallthrough_upto dm f ctx lse1 lse2: - siexits_simu dm f lse1 lse2 ctx -> +Lemma siexits_simu_all_fallthrough_upto dm f outframe ctx lse1 lse2: + siexits_simu dm f outframe lse1 lse2 ctx -> forall ext1 lx1, (forall se1, In se1 lx1 -> sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1)) -> all_fallthrough_upto_exit (the_ge1 ctx) (the_sp ctx) ext1 lx1 lse1 (the_rs0 ctx) (the_m0 ctx) -> @@ -570,14 +614,14 @@ Proof. Qed. -Lemma hsiexits_simu_siexits dm f ctx lhse1 lhse2: - hsiexits_simu dm f ctx lhse1 lhse2 -> +Lemma hsiexits_simu_siexits dm f outframe ctx lhse1 lhse2: + hsiexits_simu dm f outframe ctx lhse1 lhse2 -> forall lse1 lse2, hsiexits_refines_stat lhse1 lse1 -> hsiexits_refines_stat lhse2 lse2 -> hsiexits_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse1 lse1 -> hsiexits_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse2 lse2 -> - siexits_simu dm f lse1 lse2 ctx. + siexits_simu dm f outframe lse1 lse2 ctx. Proof. induction 1. - intros. inv H. inv H0. constructor. @@ -591,16 +635,16 @@ Qed. It is motivated by [hsistate_simu_spec_correct theorem] below *) -Definition hsistate_simu_spec dm f (hse1 hse2: hsistate) := +Definition hsistate_simu_spec dm f outframe (hse1 hse2: hsistate) := list_forall2 (hsiexit_simu_spec dm f) (hsi_exits hse1) (hsi_exits hse2) - /\ hsilocal_simu_spec None (hsi_local hse1) (hsi_local hse2). + /\ hsilocal_simu_spec outframe (hsi_local hse1) (hsi_local hse2). -Definition hsistate_simu dm f (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, +Definition hsistate_simu dm f outframe (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, hsistate_refines_stat hst1 st1 -> hsistate_refines_stat hst2 st2 -> hsistate_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst1 st1 -> hsistate_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst2 st2 -> - sistate_simu dm f st1 st2 ctx. + sistate_simu dm f outframe st1 st2 ctx. Lemma list_forall2_nth_error {A} (l1 l2: list A) P: list_forall2 P l1 l2 -> @@ -644,9 +688,9 @@ Proof. rewrite H0; auto. Qed. -Theorem hsistate_simu_spec_correct dm f hst1 hst2 ctx: - hsistate_simu_spec dm f hst1 hst2 -> - hsistate_simu dm f hst1 hst2 ctx. +Theorem hsistate_simu_spec_correct dm f outframe hst1 hst2 ctx: + hsistate_simu_spec dm f outframe hst1 hst2 -> + hsistate_simu dm f outframe hst1 hst2 ctx. Proof. intros (ESIMU & LSIMU) st1 st2 (PCREF1 & EREF1) (PCREF2 & EREF2) DREF1 DREF2 is1 SEMI. destruct DREF1 as (DEREF1 & LREF1 & NESTED). destruct DREF2 as (DEREF2 & LREF2 & _). @@ -654,23 +698,27 @@ Proof. unfold ssem_internal in SEMI. destruct (icontinue _) eqn:ICONT. - destruct SEMI as (SSEML & PCEQ & ALLFU). exploit hsilocal_simu_spec_correct; eauto; [apply ctx|]. simpl. intro SSEML2. - exists (mk_istate (icontinue is1) (si_pc st2) (irs is1) (imem is1)). constructor. - + unfold ssem_internal. simpl. rewrite ICONT. constructor; [assumption | constructor; [reflexivity |]]. + exists (mk_istate (icontinue is1) (si_pc st2) (seval_partial_regset (the_ge2 ctx) (the_sp ctx) + (the_rs0 ctx) (the_m0 ctx) (hsi_local hst2)) (imem is1)). constructor. + + unfold ssem_internal. simpl. rewrite ICONT. + destruct SSEML2 as [SSEMLP EQLIVE]. + constructor; [assumption | constructor; [reflexivity |]]. eapply siexits_simu_all_fallthrough; eauto. * eapply hsiexits_simu_siexits; eauto. * eapply nested_sok_prop; eauto. eapply ssem_local_sok; eauto. - + unfold istate_simu. rewrite ICONT. constructor; [simpl; assumption | constructor; [| reflexivity]]. - constructor. + + unfold istate_simu. rewrite ICONT. + destruct SSEML2 as [SSEMLP EQLIVE]. + constructor; simpl; auto. - destruct SEMI as (ext & lx & SSEME & ALLFU). - assert (SESIMU: siexits_simu dm f (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). + assert (SESIMU: siexits_simu dm f outframe (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). exploit siexits_simu_all_fallthrough_upto; eauto. * destruct ALLFU as (ITAIL & ALLF). exploit nested_sok_tail; eauto. intros NESTED2. inv NESTED2. destruct SSEME as (_ & SSEML & _). eapply ssem_local_sok in SSEML. eapply nested_sok_prop; eauto. * intros (ext2 & lx2 & ALLFU2 & LENEQ). - assert (EXTSIMU: siexit_simu dm f ctx ext ext2). { + assert (EXTSIMU: siexit_simu dm f outframe ctx ext ext2). { eapply list_forall2_nth_error; eauto. - destruct ALLFU as (ITAIL & _). eapply is_tail_nth_error; eauto. - destruct ALLFU2 as (ITAIL & _). eapply is_tail_nth_error in ITAIL. @@ -858,18 +906,18 @@ Qed. It is motivated by [hsstate_simu_spec_correct theorem] below *) -Definition hsstate_simu_spec (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := - hsistate_simu_spec dm f (hinternal hst1) (hinternal hst2) +Definition hsstate_simu_spec (dm: PTree.t node) (f: RTLpath.function) outframe (hst1 hst2: hsstate) := + hsistate_simu_spec dm f outframe (hinternal hst1) (hinternal hst2) /\ hfinal_simu_spec dm f (hsi_pc (hinternal hst1)) (hsi_pc (hinternal hst2)) (hfinal hst1) (hfinal hst2). -Definition hsstate_simu dm f (hst1 hst2: hsstate) ctx: Prop := +Definition hsstate_simu dm f outframe (hst1 hst2: hsstate) ctx: Prop := forall st1 st2, hsstate_refines hst1 st1 -> - hsstate_refines hst2 st2 -> sstate_simu dm f st1 st2 ctx. + hsstate_refines hst2 st2 -> sstate_simu dm f outframe st1 st2 ctx. -Theorem hsstate_simu_spec_correct dm f ctx hst1 hst2: - hsstate_simu_spec dm f hst1 hst2 -> - hsstate_simu dm f hst1 hst2 ctx. +Theorem hsstate_simu_spec_correct dm f outframe ctx hst1 hst2: + hsstate_simu_spec dm f outframe hst1 hst2 -> + hsstate_simu dm f outframe hst1 hst2 ctx. Proof. intros (SCORE & FSIMU) st1 st2 (SREF1 & DREF1 & FREF1) (SREF2 & DREF2 & FREF2). generalize SCORE. intro SIMU; eapply hsistate_simu_spec_correct in SIMU; eauto. diff --git a/scheduling/RTLpathSE_theory.v b/scheduling/RTLpathSE_theory.v index 4c492ecd..aa8db342 100644 --- a/scheduling/RTLpathSE_theory.v +++ b/scheduling/RTLpathSE_theory.v @@ -345,31 +345,13 @@ Qed. Lemma ssem_local_exclude_sabort_local ge sp loc rs m rs' m': ssem_local ge sp loc rs m rs' m' -> -(* all_fallthrough ge sp (si_exits st) rs m -> *) sabort_local ge sp loc rs m -> False. Proof. - intros SIML (* ALLF *) ABORT. inv SIML. destruct H0 as (H0 & H0'). + intros SIML ABORT. inv SIML. destruct H0 as (H0 & H0'). inversion ABORT as [ABORT1 | [ABORT2 | ABORT3]]; [ | | inv ABORT3]; congruence. Qed. -(* TODO: remove this JUNK ? -Lemma ssem_local_exclude_sabort_exit ge sp st ext lx rs m rs' m': - ssem_local ge sp (si_local st) rs m rs' m' -> - all_fallthrough ge sp (si_exits st) rs m -> - is_tail (ext :: lx) (si_exits st) -> - sabort_exit ge sp ext rs m -> - False. -Proof. - intros SSEML ALLF TAIL ABORT. - inv ABORT. - - exploit ALLF; eauto. congruence. - - (* FIXME Problem : if we have a ssem_local, this means we ONLY evaluated the conditions, - but we NEVER actually evaluated the si_elocal from the sistate_exit ! So we cannot prove - a lack of abort on the si_elocal.. We must change the definitions *) -Abort. -*) - Lemma ssem_local_exclude_sabort ge sp st rs m rs' m': ssem_local ge sp (si_local st) rs m rs' m' -> all_fallthrough ge sp (si_exits st) rs m -> @@ -497,7 +479,7 @@ Definition siexec_inst (i: instruction) (st: sistate): option sistate := let vargs := list_sval_inj (List.map prev.(si_sreg) args) in let ex := {| si_cond:=cond; si_scondargs:=vargs; si_elocal := prev; si_ifso := ifso |} in Some {| si_pc := ifnot; si_exits := ex::st.(si_exits); si_local := prev |} - | _ => None (* TODO jumptable ? *) + | _ => None end. Lemma seval_list_sval_inj ge sp l rs0 m0 (sreg: reg -> sval) rs: @@ -1627,13 +1609,9 @@ Definition istate_simulive alive (srce: PTree.t node) (is1 is2: istate): Prop := /\ eqlive_reg alive is1.(irs) is2.(irs) /\ is1.(imem) = is2.(imem). -Definition istate_simu f (srce: PTree.t node) is1 is2: Prop := +Definition istate_simu f (srce: PTree.t node) outframe is1 is2: Prop := if is1.(icontinue) then - (* TODO: il faudra raffiner le (fun _ => True) si on veut autoriser l'oracle à - ajouter du "code mort" sur des registres non utilisés (loop invariant code motion à la David) - Typiquement, pour connaître la frame des registres vivants, il faudra faire une propagation en arrière - sur la dernière instruction du superblock. *) - istate_simulive (fun _ => True) srce is1 is2 + istate_simulive (fun r => Regset.In r outframe) srce is1 is2 else exists path, f.(fn_path)!(is1.(ipc)) = Some path /\ istate_simulive (fun r => Regset.In r path.(input_regs)) srce is1 is2 @@ -1651,10 +1629,10 @@ Record simu_proof_context {f1: RTLpath.function} := { Arguments simu_proof_context: clear implicits. (* NOTE: a pure semantic definition on [sistate], for a total freedom in refinements *) -Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) (st1 st2: sistate) (ctx: simu_proof_context f): Prop := +Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) outframe (st1 st2: sistate) (ctx: simu_proof_context f): Prop := forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) st1 (the_rs0 ctx) (the_m0 ctx) is1 -> exists is2, ssem_internal (the_ge2 ctx) (the_sp ctx) st2 (the_rs0 ctx) (the_m0 ctx) is2 - /\ istate_simu f dm is1 is2. + /\ istate_simu f dm outframe is1 is2. Inductive svident_simu (f: RTLpath.function) (ctx: simu_proof_context f): (sval + ident) -> (sval + ident) -> Prop := | Sleft_simu sv1 sv2: @@ -1885,13 +1863,14 @@ Inductive sfval_simu (dm: PTree.t node) (f: RTLpath.function) (opc1 opc2: node) = (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) -> sfval_simu dm f opc1 opc2 ctx (Sreturn (Some sv1)) (Sreturn (Some sv2)). -Definition sstate_simu dm f (s1 s2: sstate) (ctx: simu_proof_context f): Prop := - sistate_simu dm f s1.(internal) s2.(internal) ctx - /\ forall is1, +Definition sstate_simu dm f outframe (s1 s2: sstate) (ctx: simu_proof_context f): Prop := + sistate_simu dm f outframe s1.(internal) s2.(internal) ctx + /\ forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) s1 (the_rs0 ctx) (the_m0 ctx) is1 -> is1.(icontinue) = true -> sfval_simu dm f s1.(si_pc) s2.(si_pc) ctx s1.(final) s2.(final). Definition sexec_simu dm (f1 f2: RTLpath.function) pc1 pc2: Prop := forall st1, sexec f1 pc1 = Some st1 -> - exists st2, sexec f2 pc2 = Some st2 /\ forall ctx, sstate_simu dm f1 st1 st2 ctx. + exists path st2, (fn_path f1)!pc1 = Some path /\ sexec f2 pc2 = Some st2 + /\ forall ctx, sstate_simu dm f1 path.(pre_output_regs) st1 st2 ctx. diff --git a/scheduling/RTLpathScheduler.v b/scheduling/RTLpathScheduler.v index beab405f..31680256 100644 --- a/scheduling/RTLpathScheduler.v +++ b/scheduling/RTLpathScheduler.v @@ -7,7 +7,7 @@ This module is inspired from [Duplicate] and [Duplicateproof] Require Import AST Linking Values Maps Globalenvs Smallstep Registers. Require Import Coqlib Maps Events Errors Op. Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory RTLpathSE_impl. - +Require RTLpathWFcheck. Notation "'ASSERT' A 'WITH' MSG 'IN' B" := (if A then B else Error (msg MSG)) (at level 200, A at level 100, B at level 200) @@ -32,14 +32,14 @@ Extract Constant untrusted_scheduler => "RTLpathScheduleraux.scheduler". Program Definition function_builder (tfr: RTL.function) (tpm: path_map) : { r : res RTLpath.function | forall f', r = OK f' -> fn_RTL f' = tfr} := - match RTLpathLivegen.function_checker tfr tpm with + match RTLpathWFcheck.function_checker tfr tpm with | false => Error (msg "In function_builder: (tfr, tpm) is not wellformed") | true => OK {| fn_RTL := tfr; fn_path := tpm |} end. Next Obligation. - apply function_checker_path_entry. auto. + apply RTLpathWFcheck.function_checker_path_entry. auto. Defined. Next Obligation. - apply function_checker_wellformed_path_map. auto. + apply RTLpathWFcheck.function_checker_wellformed_path_map. auto. Defined. Definition entrypoint_check (dm: PTree.t node) (fr tfr: RTL.function) : res unit := @@ -158,7 +158,7 @@ Definition verified_scheduler (f: RTLpath.function) : res (RTLpath.function * (P let (tc, te) := tcte in let tfr := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in do tf <- proj1_sig (function_builder tfr tpm); - do tt <- function_equiv_checker dm f tf; + do tt <- function_equiv_checker dm f tf; OK (tf, dm). Theorem verified_scheduler_correct f tf dm: @@ -179,7 +179,7 @@ Proof. destruct (function_builder _ _) as [res H]; simpl in * |- *; auto. apply H in EQ2. rewrite EQ2. simpl. repeat (constructor; eauto). - - exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. + exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. Qed. Record match_function (dupmap: PTree.t node) (f1 f2: RTLpath.function): Prop := { @@ -327,4 +327,3 @@ Proof. eapply match_Internal; eauto. + eapply match_External. Qed. - diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml index a294d0b5..aeed39df 100644 --- a/scheduling/RTLpathScheduleraux.ml +++ b/scheduling/RTLpathScheduleraux.ml @@ -1,28 +1,19 @@ +open DebugPrint +open Machine +open RTLpathLivegenaux open RTLpath +open RTLpathCommon open RTL open Maps -open RTLpathLivegenaux open Registers -open Camlcoq -open Machine -open DebugPrint +open ExpansionOracle let config = Machine.config -type superblock = { - instructions: P.t array; (* pointers to code instructions *) - (* each predicted Pcb has its attached liveins *) - (* This is indexed by the pc value *) - liveins: Regset.t PTree.t; - (* Union of the input_regs of the last successors *) - output_regs: Regset.t; - typing: RTLtyping.regenv -} - -let print_superblock sb code = +let print_superblock (sb: superblock) code = let insts = sb.instructions in let li = sb.liveins in - let outs = sb.output_regs in + let outs = sb.s_output_regs in begin debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n"; debug " liveins = "; print_ptree_regset li; debug "\n"; @@ -71,7 +62,7 @@ let get_superblocks code entry pm typing = let pi = get_some @@ PTree.get pc pm in let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in let superblock = { instructions = Array.of_list insts; liveins = !liveins; - output_regs = pi.output_regs; typing = typing } in + s_output_regs = pi.output_regs; typing = typing } in superblock :: (List.concat @@ List.map get_superblocks_rec nexts) end in let lsb = get_superblocks_rec entry in begin @@ -289,25 +280,29 @@ let turn_all_loads_nontrap sb code = !code' end -let rec do_schedule code = function - | [] -> code +let rec do_schedule code pm = function + | [] -> (code, pm) | sb :: lsb -> + (*debug_flag := true;*) + let (code_exp, pm) = expanse sb code pm in + (*debug_flag := false;*) (* Trick: instead of turning loads into non trap as needed.. * First, we turn them all into non-trap. * Then, we turn back those who didn't need to be turned, into TRAP again * This is because the scheduler (rightfully) refuses to schedule ahead of a branch * operations that might trap *) - let code' = turn_all_loads_nontrap sb code in + let code' = turn_all_loads_nontrap sb code_exp in let schedule = schedule_superblock sb code' in let new_code = apply_schedule code' sb schedule in begin - (* debug_flag := true; *) + (*debug_flag := true;*) + if code != code_exp then ( debug "Old Code: "; print_code code; + debug "Exp Code: "; print_code code_exp); debug "\nSchedule to apply: "; print_arrayp schedule; debug "\nNew Code: "; print_code new_code; debug "\n"; - (* debug_flag := false; *) - do_schedule new_code lsb + do_schedule new_code pm lsb end let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK" @@ -324,8 +319,10 @@ let scheduler f = debug "Pathmap:\n"; debug "\n"; print_path_map pm; debug "Superblocks:\n"; - print_superblocks lsb code; debug "\n"; - (* debug_flag := false; *) - let tc = do_schedule code lsb in + (*print_code code; flush stdout; flush stderr;*) + (*debug_flag := false;*) + (*print_superblocks lsb code; debug "\n";*) + find_last_node_reg (PTree.elements code); + let (tc, pm) = do_schedule code pm lsb in (((tc, entry), pm), id_ptree) end diff --git a/scheduling/RTLpathSchedulerproof.v b/scheduling/RTLpathSchedulerproof.v index 4ba197b0..a9c2fa76 100644 --- a/scheduling/RTLpathSchedulerproof.v +++ b/scheduling/RTLpathSchedulerproof.v @@ -143,13 +143,25 @@ Obligation 2. erewrite symbols_preserved_RTL. eauto. Qed. +Lemma s_find_function_fundef f sp svos rs0 m0 fd + (LIVE: liveness_ok_function f): + sfind_function pge ge sp svos rs0 m0 = Some fd -> + liveness_ok_fundef fd. +Proof. + unfold sfind_function. destruct svos; simpl. + + destruct (seval_sval _ _ _ _); try congruence. + eapply find_funct_liveness_ok; eauto. + + destruct (Genv.find_symbol _ _); try congruence. + intros. eapply all_fundef_liveness_ok; eauto. +Qed. +Local Hint Resolve s_find_function_fundef: core. + Lemma s_find_function_preserved f sp svos1 svos2 rs0 m0 fd (LIVE: liveness_ok_function f): (svident_simu f (mkctx sp rs0 m0 LIVE) svos1 svos2) -> sfind_function pge ge sp svos1 rs0 m0 = Some fd -> exists fd', sfind_function tpge tge sp svos2 rs0 m0 = Some fd' - /\ transf_fundef fd = OK fd' - /\ liveness_ok_fundef fd. + /\ transf_fundef fd = OK fd'. Proof. Local Hint Resolve symbols_preserved_RTL: core. unfold sfind_function. intros [sv1 sv2 SIMU|]; simpl in *. @@ -159,20 +171,16 @@ Proof. intros; exploit functions_preserved; eauto. intros (fd' & cunit & (X1 & X2 & X3)). eexists. repeat split; eauto. - eapply find_funct_liveness_ok; eauto. -(* intros. eapply all_fundef_liveness_ok; eauto. *) + subst. rewrite symbols_preserved. destruct (Genv.find_symbol _ _); try congruence. intros; exploit function_ptr_preserved; eauto. - intros (fd' & X). eexists. intuition eauto. -(* intros. eapply all_fundef_liveness_ok; eauto. *) Qed. -Lemma sistate_simu f dupmap sp st st' rs m is +Lemma sistate_simu f dupmap outframe sp st st' rs m is (LIVE: liveness_ok_function f): ssem_internal ge sp st rs m is -> - sistate_simu dupmap f st st' (mkctx sp rs m LIVE)-> + sistate_simu dupmap f outframe st st' (mkctx sp rs m LIVE)-> exists is', - ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap is is'. + ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap outframe is is'. Proof. intros SEM X; eapply X; eauto. Qed. @@ -198,13 +206,12 @@ Lemma ssem_final_simu dm f f' stk stk' sp st st' rs0 m0 sv sv' rs m t s (LIVE: liveness_ok_function f): match_function dm f f' -> list_forall2 match_stackframes stk stk' -> - (* s_istate_simu f dupmap st st' -> *) sfval_simu dm f st.(si_pc) st'.(si_pc) (mkctx sp rs0 m0 LIVE) sv sv' -> ssem_final pge ge sp st.(si_pc) stk f rs0 m0 sv rs m t s -> exists s', ssem_final tpge tge sp st'.(si_pc) stk' f' rs0 m0 sv' rs m t s' /\ match_states s s'. Proof. Local Hint Resolve transf_fundef_correct: core. - intros FUN STK (* SIS *) SFV. destruct SFV; intros SEM; inv SEM; simpl in *. + intros FUN STK SFV. destruct SFV; intros SEM; inv SEM; simpl in *. - (* Snone *) exploit initialize_path. { eapply dupmap_path_entry1; eauto. } intros (path & PATH). @@ -212,7 +219,7 @@ Proof. eapply eqlive_reg_refl. - (* Scall *) exploit s_find_function_preserved; eauto. - intros (fd' & FIND & TRANSF & LIVE'). + intros (fd' & FIND & TRANSF). erewrite <- function_sig_preserved; eauto. exploit initialize_path. { eapply dupmap_path_entry1; eauto. } intros (path & PATH). @@ -221,7 +228,7 @@ Proof. + simpl. repeat (econstructor; eauto). - (* Stailcall *) exploit s_find_function_preserved; eauto. - intros (fd' & FIND & TRANSF & LIVE'). + intros (fd' & FIND & TRANSF). erewrite <- function_sig_preserved; eauto. eexists; split; econstructor; eauto. + erewrite <- preserv_fnstacksize; eauto. @@ -253,18 +260,154 @@ Proof. + rewrite <- H. erewrite <- seval_preserved; eauto. Qed. +Lemma siexec_snone_por_correct rs' is t s alive path0 i sp s0 st0 stk stk' f rs0 m0: forall + (SSEM2 : ssem_final pge ge sp (si_pc s0) stk f rs0 m0 Snone + (irs is) (imem is) t s) + (SIEXEC : siexec_inst i st0 = Some s0) + (ICHK : inst_checker (fn_path f) alive (pre_output_regs path0) i = Some tt), + (liveness_ok_function f) -> + list_forall2 match_stackframes stk stk' -> + eqlive_reg (fun r : Regset.elt => Regset.In r (pre_output_regs path0)) (irs is) rs' -> + exists s' : state, + ssem_final pge ge sp (si_pc s0) stk f rs0 m0 Snone rs' (imem is) t s' /\ + eqlive_states s s'. +Proof. + Local Hint Resolve eqlive_stacks_refl: core. + intros ? ? ? LIVE STK EQLIVE. + inversion SSEM2; subst; clear SSEM2. + eexists; split. + * econstructor. + * generalize ICHK. + unfold inst_checker. destruct i; simpl in *; + unfold exit_checker; try discriminate. + all: + try destruct (list_mem _ _); simpl; + try (destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence; fail). + 4,5: + destruct (Regset.mem _ _); destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + 1,2,3,4: assert (NPC: n=(si_pc s0)). + all: try (inv SIEXEC; simpl; auto; fail). + 1,2,3,4: + try (destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence); + simpl; inversion_SOME p; + destruct (Regset.subset (input_regs p) (pre_output_regs path0)) eqn:SUB_PATH; try congruence; + intros NPATH _; econstructor; eauto; + try (instantiate (1:=p); rewrite <- NPC; auto; fail). + 1,2,3,4: + eapply eqlive_reg_monotonic; eauto; simpl; + intros; apply Regset.subset_2 in SUB_PATH; + unfold Regset.Subset in SUB_PATH; + apply SUB_PATH in H; auto. + assert (NPC: n0=(si_pc s0)). { inv SIEXEC; simpl; auto. } + inversion_SOME p. + 2: { destruct (Regset.subset _ _) eqn:?; try congruence. } + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + 2: { destruct (Regset.subset (pre_output_regs path0) alive) eqn:?; try congruence. } + simpl. + destruct (Regset.subset (pre_output_regs path0) alive) eqn:SUB_ALIVE'; try congruence. + inversion_SOME p'. + destruct (Regset.subset (input_regs p') (pre_output_regs path0)) eqn:SUB_PATH; try congruence. + intros NPATH NPATH' _. econstructor; eauto. + instantiate (1:=p'). rewrite <- NPC; auto. + eapply eqlive_reg_monotonic; eauto; simpl. + intros. apply Regset.subset_2 in SUB_PATH. + unfold Regset.Subset in SUB_PATH. + apply SUB_PATH in H; auto. +Qed. + +Lemma pre_output_regs_correct f pc0 path0 stk stk' sp (st:sstate) rs0 m0 t s is rs': + (liveness_ok_function f) -> + (fn_path f) ! pc0 = Some path0 -> + sexec f pc0 = Some st -> + list_forall2 match_stackframes stk stk' -> + ssem_final pge ge sp (si_pc st) stk f rs0 m0 (final st) (irs is) (imem is) t s -> + eqlive_reg (fun r : Regset.elt => Regset.In r (pre_output_regs path0)) (irs is) rs' -> + exists s', ssem_final pge ge sp (si_pc st) stk f rs0 m0 (final st) rs' (imem is) t s' /\ eqlive_states s s'. +Proof. + Local Hint Resolve eqlive_stacks_refl: core. + intros LIVE PATH0 SEXEC STK SSEM2 EQLIVE. + (* start decomposing path_checker *) + generalize (LIVE pc0 path0 PATH0). + unfold path_checker. + inversion_SOME res; intros IPCHK. + inversion_SOME i; intros INST ICHK. + exploit ipath_checker_default_succ; eauto. intros DEFSUCC. + (* start decomposing SEXEC *) + generalize SEXEC; clear SEXEC. + unfold sexec; rewrite PATH0. + inversion_SOME st0; intros SEXEC_PATH. + exploit siexec_path_default_succ; eauto. + simpl. rewrite DEFSUCC. + clear DEFSUCC. destruct res as [alive pc1]. simpl in *. + try_simplify_someHyps. + destruct (siexec_inst i st0) eqn: SIEXEC; try_simplify_someHyps; intros. + (* Snone *) + eapply siexec_snone_por_correct; eauto. + destruct i; try_simplify_someHyps; try congruence; + inversion SSEM2; subst; clear SSEM2; simpl in *. + + (* Scall *) + eexists; split. + * econstructor; eauto. + * econstructor; eauto. + econstructor; eauto. + (* wf *) + generalize ICHK. + unfold inst_checker; simpl in *. + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + destruct (list_mem _ _); try congruence. + destruct (reg_sum_mem _ _); try congruence. + intros EXIT. + exploit exit_checker_eqlive_ext1; eauto. + intros. destruct H as [p [PATH EQLIVE']]. + econstructor; eauto. + + (* Stailcall *) + eexists; split. + * econstructor; eauto. + * econstructor; eauto. + + (* Sbuiltin *) + eexists; split. + * econstructor; eauto. + * (* wf *) + generalize ICHK. + unfold inst_checker; simpl in *. + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + destruct (list_mem _ _); try congruence. + intros EXIT. + exploit exit_checker_eqlive_builtin_res; eauto. + intros. destruct H as [p [PATH EQLIVE']]. + econstructor; eauto. + + (* Sjumptable *) + eexists; split. + * econstructor; eauto. + * (* wf *) + generalize ICHK. + unfold inst_checker; simpl in *. + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + destruct (Regset.mem _ _); try congruence. + destruct (exit_list_checker _ _ _) eqn:EQL; try congruence. + exploit exit_list_checker_eqlive; eauto. + intros. destruct H as [p [PATH EQLIVE']]. + econstructor; eauto. + + (* Sreturn *) + eexists; split. + * econstructor; eauto. + * econstructor; eauto. +Qed. + (* The main theorem on simulation of symbolic states ! *) -Theorem ssem_sstate_simu dm f f' stk stk' sp st st' rs m t s: +Theorem ssem_sstate_simu dm f f' pc0 path0 stk stk' sp st st' rs m t s: + (fn_path f) ! pc0 = Some path0 -> + sexec f pc0 = Some st -> match_function dm f f' -> liveness_ok_function f -> list_forall2 match_stackframes stk stk' -> ssem pge ge sp st stk f rs m t s -> - (forall ctx: simu_proof_context f, sstate_simu dm f st st' ctx) -> + (forall ctx: simu_proof_context f, sstate_simu dm f (pre_output_regs path0) st st' ctx) -> exists s', ssem tpge tge sp st' stk' f' rs m t s' /\ match_states s s'. Proof. - intros MFUNC LIVE STACKS SEM SIMU. + intros PATH0 SEXEC MFUNC LIVE STACKS SEM SIMU. destruct (SIMU (mkctx sp rs m LIVE)) as (SIMU1 & SIMU2); clear SIMU. - destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl. + destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl in *. - (* sem_early *) exploit sistate_simu; eauto. unfold istate_simu; rewrite CONT. @@ -276,15 +419,17 @@ Proof. - (* sem_normal *) exploit sistate_simu; eauto. unfold istate_simu; rewrite CONT. - intros (is' & SEM' & (CONT' & RS' & M')(* & DMEQ *)). - rewrite <- eqlive_reg_triv in RS'. + intros (is' & SEM' & (CONT' & RS' & M')). + exploit pre_output_regs_correct; eauto. + clear SEM2; intros (s0 & SEM2 & EQLIVE). exploit ssem_final_simu; eauto. - clear SEM2; intros (s0 & SEM2 & MATCH0). + clear SEM2; intros (s1 & SEM2 & MATCH0). exploit ssem_final_equiv; eauto. - clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s1 & EQ & SEM2). - exists s1; split. + clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s2 & EQ & SEM2). + exists s2; split. + eapply ssem_normal; eauto. - + eapply match_states_equiv; eauto. + + eapply eqlive_match_states; eauto. + eapply match_states_equiv; eauto. Qed. Lemma exec_path_simulation dupmap path stk stk' f f' sp rs m pc pc' t s: @@ -301,12 +446,13 @@ Proof. intros (path' & PATH'). exists path'. exploit (sexec_correct f pc pge ge sp path stk rs m t s); eauto. - intros (st & SYMB & SEM); clear STEP. + intros (st & SYMB & SEM). exploit dupmap_correct; eauto. - clear SYMB; intros (st' & SYMB & SIMU). + intros (path0 & st' & PATH0 & SYMB' & SIMU). + rewrite PATH0 in PATH; inversion PATH; subst. exploit ssem_sstate_simu; eauto. intros (s0 & SEM0 & MATCH). - exploit sexec_exact; eauto. + exploit (sexec_exact f'); eauto. intros (s' & STEP' & EQ). exists s'; intuition. eapply match_states_equiv; eauto. diff --git a/scheduling/RTLpathWFcheck.v b/scheduling/RTLpathWFcheck.v new file mode 100644 index 00000000..63b914ec --- /dev/null +++ b/scheduling/RTLpathWFcheck.v @@ -0,0 +1,187 @@ +Require Import Coqlib. +Require Import Maps. +Require Import Lattice. +Require Import AST. +Require Import Op. +Require Import Registers. +Require Import Globalenvs Smallstep RTL RTLpath. +Require Import Bool Errors. +Require Import Program. +Require RTLpathLivegen. + +Local Open Scope lazy_bool_scope. + +Local Open Scope option_monad_scope. + +Definition exit_checker {A} (pm: path_map) (pc: node) (v:A): option A := + SOME path <- pm!pc IN + Some v. + +Lemma exit_checker_path_entry A (pm: path_map) (pc: node) (v:A) res: + exit_checker pm pc v = Some res -> path_entry pm pc. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; simpl; congruence. +Qed. + +Lemma exit_checker_res A (pm: path_map) (pc: node) (v:A) res: + exit_checker pm pc v = Some res -> v=res. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; try_simplify_someHyps. +Qed. + +Definition iinst_checker (pm: path_map) (i: instruction): option (node) := + match i with + | Inop pc' | Iop _ _ _ pc' | Iload _ _ _ _ _ pc' + | Istore _ _ _ _ pc' => Some (pc') + | Icond cond args ifso ifnot _ => + exit_checker pm ifso ifnot + | _ => None + end. + +Local Hint Resolve exit_checker_path_entry: core. + +Lemma iinst_checker_path_entry (pm: path_map) (i: instruction) res pc: + iinst_checker pm i = Some res -> + early_exit i = Some pc -> path_entry pm pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst. +Qed. + +Lemma iinst_checker_default_succ (pm: path_map) (i: instruction) res pc: + iinst_checker pm i = Some res -> + pc = res -> + default_succ i = Some pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst; + repeat (inversion_ASSERT); try_simplify_someHyps. + intros; exploit exit_checker_res; eauto. + intros; subst. simpl; auto. +Qed. + +Fixpoint ipath_checker (ps:nat) (f: RTL.function) (pm: path_map) (pc:node): option (node) := + match ps with + | O => Some (pc) + | S p => + SOME i <- f.(fn_code)!pc IN + SOME res <- iinst_checker pm i IN + ipath_checker p f pm res + end. + +Lemma ipath_checker_wellformed f pm ps: forall pc res, + ipath_checker ps f pm pc = Some res -> + wellformed_path f.(fn_code) pm 0 res -> + wellformed_path f.(fn_code) pm ps pc. +Proof. + induction ps; simpl; try_simplify_someHyps. + inversion_SOME i; inversion_SOME res'. + intros. eapply wf_internal_node; eauto. + * eapply iinst_checker_default_succ; eauto. + * intros; eapply iinst_checker_path_entry; eauto. +Qed. + +Fixpoint exit_list_checker (pm: path_map) (l: list node): bool := + match l with + | nil => true + | pc::l' => exit_checker pm pc tt &&& exit_list_checker pm l' + end. + +Lemma exit_list_checker_correct pm l pc: + exit_list_checker pm l = true -> List.In pc l -> exit_checker pm pc tt = Some tt. +Proof. + intros EXIT PC; induction l; intuition. + simpl in * |-. rewrite RTLpathLivegen.lazy_and_Some_tt_true in EXIT. + firstorder (subst; eauto). +Qed. + +Local Hint Resolve exit_list_checker_correct: core. + +Definition inst_checker (pm: path_map) (i: instruction): option unit := + match i with + | Icall sig ros args res pc' => + exit_checker pm pc' tt + | Itailcall sig ros args => + Some tt + | Ibuiltin ef args res pc' => + exit_checker pm pc' tt + | Ijumptable arg tbl => + ASSERT exit_list_checker pm tbl IN + Some tt + | Ireturn optarg => + Some tt + | _ => + SOME res <- iinst_checker pm i IN + exit_checker pm res tt + end. + +Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (i: instruction): + inst_checker pm i = Some tt -> + c!pc = Some i -> wellformed_path c pm 0 pc. +Proof. + intros CHECK PC. eapply wf_last_node; eauto. + clear c pc PC. intros pc PC. + destruct i; simpl in * |- *; intuition (subst; eauto); + try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). + intros X; exploit exit_checker_res; eauto. + clear X. intros; subst; eauto. +Qed. + +Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := + SOME res <- ipath_checker (path.(psize)) f pm pc IN + SOME i <- f.(fn_code)!res IN + inst_checker pm i. + +Lemma path_checker_wellformed f pm pc path: + path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. +Proof. + unfold path_checker. + inversion_SOME res. + inversion_SOME i. + intros; eapply ipath_checker_wellformed; eauto. + eapply inst_checker_wellformed; eauto. +Qed. + +Fixpoint list_path_checker f pm (l:list (node*path_info)): bool := + match l with + | nil => true + | (pc, path)::l' => + path_checker f pm pc path &&& list_path_checker f pm l' + end. + +Lemma list_path_checker_correct f pm l: + list_path_checker f pm l = true -> forall e, List.In e l -> path_checker f pm (fst e) (snd e) = Some tt. +Proof. + intros CHECKER e H; induction l as [|(pc & path) l]; intuition. + simpl in * |- *. rewrite RTLpathLivegen.lazy_and_Some_tt_true in CHECKER. intuition (subst; auto). +Qed. + +Definition function_checker (f: RTL.function) (pm: path_map): bool := + pm!(f.(fn_entrypoint)) &&& list_path_checker f pm (PTree.elements pm). + +Lemma function_checker_correct f pm pc path: + function_checker f pm = true -> + pm!pc = Some path -> + path_checker f pm pc path = Some tt. +Proof. + unfold function_checker; rewrite RTLpathLivegen.lazy_and_Some_true. + intros (ENTRY & PATH) PC. + exploit list_path_checker_correct; eauto. + - eapply PTree.elements_correct; eauto. + - simpl; auto. +Qed. + +Lemma function_checker_wellformed_path_map f pm: + function_checker f pm = true -> wellformed_path_map f.(fn_code) pm. +Proof. + unfold wellformed_path_map. + intros; eapply path_checker_wellformed; eauto. + intros; eapply function_checker_correct; eauto. +Qed. + +Lemma function_checker_path_entry f pm: + function_checker f pm = true -> path_entry pm (f.(fn_entrypoint)). +Proof. + unfold function_checker; rewrite RTLpathLivegen.lazy_and_Some_true; + unfold path_entry. firstorder congruence. +Qed. diff --git a/test/gourdinl/clause.h b/test/gourdinl/clause.h new file mode 100644 index 00000000..3eb44402 --- /dev/null +++ b/test/gourdinl/clause.h @@ -0,0 +1,12 @@ +typedef struct { + int b; + int a; +} * CLAUSE; +__inline__ int g(CLAUSE c) { return c->b; } +__inline__ int d(CLAUSE c) { return c->a; } +__inline__ void clause_SetNumOfConsLits(CLAUSE c, int e) { + c->b = e; + c->a = e; +} +__inline__ int f(CLAUSE c) { return g(c) + d(c); } +__inline__ int clause_LastLitIndex(c) { return f(c); } diff --git a/test/gourdinl/clause2.c b/test/gourdinl/clause2.c new file mode 100644 index 00000000..42cd0fa6 --- /dev/null +++ b/test/gourdinl/clause2.c @@ -0,0 +1,23 @@ +#include "clause.h" +int a, b; +void c(); +void h() { + int f = clause_LastLitIndex(d); + a = clause_LastLitIndex(0); + if (f) + if (a) + 1; +} +void i() { + CLAUSE e = 0; + int *g[] = {h, c}; + for (; b;) + l(e); +} +void m() { + int k, j; + for (; k <= 0;) + ; + clause_SetNumOfConsLits(0, j); + n(0 - j); +} diff --git a/test/gourdinl/cond_exp_mini_cse.c b/test/gourdinl/cond_exp_mini_cse.c new file mode 100644 index 00000000..3a2ce9c3 --- /dev/null +++ b/test/gourdinl/cond_exp_mini_cse.c @@ -0,0 +1,6 @@ +int main(int x, int y, int* t) { + if (x + *t < 7) + if (y < 7) + return 421; + return 0; +} diff --git a/test/gourdinl/cscript.sh b/test/gourdinl/cscript.sh new file mode 100755 index 00000000..8bf3a613 --- /dev/null +++ b/test/gourdinl/cscript.sh @@ -0,0 +1,20 @@ +#!/bin/bash + +/home/yuki/Work/VERIMAG/Compcert_neutral/ccomp -stdlib ../../runtime -dparse -dclight -S -fstruct-return -c clause2.c > log 2>&1 + +b1=$(cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr64") +sb1=$? +b2=$(cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32") +sb2=$? +b3=$(cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str32") +sb3=$? +b4=$(cat log | ack "STP_CONSEC_PEEP_IMM_INC_str64") +sb4=$? + +#if [ "$sb1" == 0 ] && [ "$sb2" == 0 ] && [ "$sb3" == 0 ] && [ "$sb4" == 0 ] +if [ "$sb1" == 0 ] && [ "$sb2" == 0 ] && [ "$sb3" == 0 ] && [ "$sb4" == 0 ] +then + exit 0 +else + exit 1 +fi diff --git a/test/gourdinl/fp_init.c b/test/gourdinl/fp_init.c new file mode 100644 index 00000000..1d835994 --- /dev/null +++ b/test/gourdinl/fp_init.c @@ -0,0 +1,7 @@ +int main (float *x) { + double a = 1.0; + float b = 1.0f; + printf("%f", a); + *x = b; + return b; +} diff --git a/test/gourdinl/gen_asm_files.sh b/test/gourdinl/gen_asm_files.sh new file mode 100755 index 00000000..08cd4b3d --- /dev/null +++ b/test/gourdinl/gen_asm_files.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +../../ccomp -S clause2.c -o clause2.nopostpass.noph.s -fno-coalesce-mem -fno-postpass +../../ccomp -S clause2.c -o clause2.nopostpass.ph.s -fcoalesce-mem -fno-postpass +../../ccomp -S clause2.c -o clause2.noph.s -fno-coalesce-mem +../../ccomp -S clause2.c -o clause2.ph.s -fcoalesce-mem diff --git a/test/monniaux/cmov/cmov.c b/test/monniaux/cmov/cmov.c new file mode 100644 index 00000000..2e388834 --- /dev/null +++ b/test/monniaux/cmov/cmov.c @@ -0,0 +1,22 @@ +#include <stdio.h> + +long cmovl(int x, long y, long z) { + return __builtin_sel(x, y, z); +} + +int cmovi(int x, int y, int z) { + return __builtin_sel(x, y, z); +} + +double cmovd(int x, double y, double z) { + return __builtin_sel(x, y, z); +} + +int main() { + printf("%ld\n", cmovl(1, 42, 65)); + printf("%ld\n", cmovl(0, 42, 65)); + printf("%d\n", cmovi(1, 42, 65)); + printf("%d\n", cmovi(0, 42, 65)); + printf("%f\n", cmovd(1, 42., 65.)); + printf("%f\n", cmovd(0, 42., 65.)); +} diff --git a/test/monniaux/cmov/cmov2.c b/test/monniaux/cmov/cmov2.c new file mode 100644 index 00000000..6ecab61b --- /dev/null +++ b/test/monniaux/cmov/cmov2.c @@ -0,0 +1,28 @@ +#include <stdio.h> + +long cmovl(int x, long y, long z) { + return x ? y : z; +} + +int cmovi(int x, int y, int z) { + return x ? y : z; +} + +double cmovd(int x, double y, double z) { + return x ? y : z; +} + +float cmovf(int x, float y, float z) { + return x ? y : z; +} + +int main() { + printf("%ld\n", cmovl(1, 42, 65)); + printf("%ld\n", cmovl(0, 42, 65)); + printf("%d\n", cmovi(1, 42, 65)); + printf("%d\n", cmovi(0, 42, 65)); + printf("%f\n", cmovd(1, 42., 65.)); + printf("%f\n", cmovd(0, 42., 65.)); + printf("%f\n", cmovf(1, 42.f, 65.f)); + printf("%f\n", cmovf(0, 42.f, 65.f)); +} diff --git a/test/monniaux/profiling/compcert_profiling.dat b/test/monniaux/profiling/compcert_profiling.dat Binary files differnew file mode 100644 index 00000000..fa57a995 --- /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..b530aae2 --- /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; +} diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 8d4f4f0b..ddb3c21a 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -32,6 +32,7 @@ PARTIAL, Always, NoRequire, (Some "Unrolling the body of innermost loops"), "Unr TOTAL, Always, NoRequire, (Some "Renumbering pre constprop"), "Renumber"; TOTAL, (Option "optim_constprop"), Require, (Some "Constant propagation"), "Constprop"; TOTAL, Always, NoRequire, (Some "Renumbering pre CSE"), "Renumber"; +PARTIAL, (Option "optim_CSE"), Require, (Some "CSE"), "CSE"; TOTAL, (Option "optim_CSE2"), Require, (Some "CSE2"), "CSE2"; PARTIAL, (Option "optim_CSE3"), Require, (Some "CSE3"), "CSE3"; TOTAL, (Option "optim_CSE3"), Require, (Some "Kill useless moves after CSE3"), "KillUselessMoves"; diff --git a/x86/ExpansionOracle.ml b/x86/ExpansionOracle.ml new file mode 120000 index 00000000..ee2674bf --- /dev/null +++ b/x86/ExpansionOracle.ml @@ -0,0 +1 @@ +../aarch64/ExpansionOracle.ml
\ No newline at end of file diff --git a/x86/RTLpathSE_simplify.v b/x86/RTLpathSE_simplify.v new file mode 120000 index 00000000..55bf0e52 --- /dev/null +++ b/x86/RTLpathSE_simplify.v @@ -0,0 +1 @@ +../aarch64/RTLpathSE_simplify.v
\ No newline at end of file |