diff options
156 files changed, 23531 insertions, 12 deletions
@@ -1,4 +1,9 @@ # Object files, in general +**#*# +**.swp +**.bin +**.out +**.tok *.vo *.glob *.o @@ -66,5 +71,10 @@ /doc/html/ # MacOS metadata .DS_Store +runtime/mppa_k1c/i64_sdiv.s +runtime/mppa_k1c/i64_smod.s +runtime/mppa_k1c/i64_udiv.s +runtime/mppa_k1c/i64_udivmod.s +runtime/mppa_k1c/i64_umod.s # Test generated data -/test/clightgen/*.v
\ No newline at end of file +/test/clightgen/*.v diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..955c7fc2 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "test/mppa/asm_coverage"] + path = test/mppa/asm_coverage + url = git@gricad-gitlab.univ-grenoble-alpes.fr:sixcy/asm-scanner.git @@ -95,7 +95,9 @@ BACKEND=\ Debugvar.v Debugvarproof.v \ Mach.v \ Bounds.v Stacklayout.v Stacking.v Stackingproof.v \ - Asm.v Asmgen.v Asmgenproof0.v Asmgenproof1.v Asmgenproof.v + Machblock.v Machblockgen.v Machblockgenproof.v \ + Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v \ + Asm.v Asmgen.v Asmgenproof.v # C front-end modules (in cfrontend/) @@ -118,7 +120,7 @@ PARSER=Cabs.v Parser.v # Putting everything together (in driver/) -DRIVER=Compopts.v Compiler.v Complements.v +DRIVER=Compopts.v Compiler.v Complements.v ForwardSimulationBlock.v # All source files diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml index f5c76925..0f666a65 100644 --- a/backend/Asmexpandaux.ml +++ b/backend/Asmexpandaux.ml @@ -26,7 +26,9 @@ let emit i = current_code := i :: !current_code (* Generation of fresh labels *) -let dummy_function = { fn_code = []; fn_sig = signature_main } +(** dummy_funtion is now defined in Asm.v *) +(* let dummy_function = { fn_code = []; fn_sig = signature_main } *) + let current_function = ref dummy_function let next_label = ref (None: label option) @@ -120,7 +122,7 @@ let expand_debug id sp preg simple l = begin match kind with | 1-> - emit i;aux lbl scopes rest + emit i; aux lbl scopes rest | 2 -> aux lbl scopes rest | 3 -> @@ -161,7 +163,7 @@ let expand_debug id sp preg simple l = | i::rest -> simple i; aux None scopes rest in (* We need to move all closing debug annotations before the last real statement *) let rec move_debug acc bcc = function - | (Pbuiltin(EF_debug (kind,_,_),_,_) as i)::rest -> + | (Pbuiltin(EF_debug (kind,_,_),_,_)) as i::rest -> let kind = (P.to_int kind) in if kind = 1 then move_debug acc (i::bcc) rest (* Do not move debug line *) diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v index 70c4323c..3e25c79b 100644 --- a/backend/Asmgenproof0.v +++ b/backend/Asmgenproof0.v @@ -39,12 +39,14 @@ Proof. unfold ireg_of; intros. destruct (preg_of r); inv H; auto. Qed. +(* FIXME - Replaced FR by IR for MPPA *) Lemma freg_of_eq: - forall r r', freg_of r = OK r' -> preg_of r = FR r'. + forall r r', freg_of r = OK r' -> preg_of r = IR r'. Proof. unfold freg_of; intros. destruct (preg_of r); inv H; auto. Qed. + Lemma preg_of_injective: forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. Proof. @@ -754,7 +756,7 @@ Lemma tail_nolabel_cons: Proof. intros. destruct H0. split. constructor; auto. - intros. simpl. rewrite <- H1. destruct i; reflexivity || contradiction. + intros. simpl. rewrite <- H1. destruct i; destruct i; reflexivity || contradiction. Qed. Hint Resolve tail_nolabel_refl: labels. diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index fc163719..55d86448 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -324,7 +324,7 @@ Local Opaque mreg_type. apply wt_setreg; auto. eapply Val.has_subtype; eauto. change ty_res with (snd (ty_args, ty_res)). rewrite <- TYOP. eapply type_of_operation_sound; eauto. red; intros; subst op. simpl in ISMOVE. - destruct args; try discriminate. destruct args; discriminate. + destruct args; try discriminate. destruct args; discriminate; apply wt_undef_regs; auto. - (* load *) simpl in *; InvBooleans. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index ffd9b227..c9b07427 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -1893,10 +1893,15 @@ Proof. exact symbols_preserved. eauto. econstructor; eauto with coqlib. apply agree_regs_set_reg; auto. + (* FIXME - MPPA specific *) + replace (destroyed_by_op op) with (@nil mreg). + replace (LTL.undef_regs nil rs) with rs. + apply agree_locs_set_reg; auto. auto. auto. +(* (* The generic proof is there *) rewrite transl_destroyed_by_op. apply agree_regs_undef_regs; auto. apply agree_locs_set_reg; auto. apply agree_locs_undef_locs. auto. apply destroyed_by_op_caller_save. apply frame_set_reg. apply frame_undef_regs. exact SEP. - +*) - (* Lload *) assert (exists a', eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a' @@ -55,6 +55,7 @@ Supported targets: x86_64-macosx (x86 64 bits, MacOS X) rv32-linux (RISC-V 32 bits, Linux) rv64-linux (RISC-V 64 bits, Linux) + k1c-linux (Kalray K1c, Linux) manual (edit configuration file by hand) For x86 targets, the "x86_32-" prefix can also be written "ia32-" or "i386-". @@ -175,6 +176,8 @@ case "$target" in arch="riscV"; model="32"; endianness="little"; bitsize=32;; rv64-*) arch="riscV"; model="64"; endianness="little"; bitsize=64;; + k1c-*) + arch="mppa_k1c"; model="64"; endianness="little"; bitsize=64;; manual) ;; "") @@ -428,6 +431,28 @@ if test "$arch" = "riscV"; then system="linux" fi +# +# K1c Target Configuration +# +if test "$arch" = "mppa_k1c"; then + #model_options="-march=rv64imafd -mabi=lp64d" + # FIXME - maybe later add it for NodeOS & cie + #model_options=-m64 + model_options= + abi="standard" + casm="k1-mbr-gcc" + casm_options="$model_options -c" + cc="k1-mbr-gcc $model_options" + clinker="k1-mbr-gcc" + bindir="$HOME/.usr/bin" + libdir="$HOME/.usr/lib" + clinker_options="$model_options -L$libdir -Wl,-rpath=$libdir" + cprepro="k1-mbr-gcc" + cprepro_options="$model_options -std=c99 -U__GNUC__ -E" + libmath="-lm" + system="linux" +fi + # # Finalize Target Configuration diff --git a/cparser/Machine.ml b/cparser/Machine.ml index 089f2483..28c6f8a6 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -237,6 +237,12 @@ let rv64 = struct_passing_style = SP_ref_callee; (* Wrong *) struct_return_style = SR_ref } (* to check *) +let mppa_k1c = + { ilp32ll64 with sizeof_ptr = 8; + name = "k1c"; + char_signed = true; + supports_unaligned_accesses = true } + (* Add GCC extensions re: sizeof and alignof *) let gcc_extensions c = diff --git a/cparser/Machine.mli b/cparser/Machine.mli index 8971e2a3..56d8d0b9 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -86,6 +86,7 @@ val arm_littleendian : t val arm_bigendian : t val rv32 : t val rv64 : t +val mppa_k1c : t val gcc_extensions : t -> t val compcert_interpreter : t -> t diff --git a/driver/Compiler.v b/driver/Compiler.v index 75247f71..1cb5bd36 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -404,7 +404,7 @@ Ltac DestructM := eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Debugvarproof.transf_program_correct. eapply compose_forward_simulations. - eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof0.return_address_offset). + eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof.return_address_offset). exact Asmgenproof.return_address_exists. eassumption. eapply Asmgenproof.transf_program_correct; eassumption. diff --git a/driver/Configuration.ml b/driver/Configuration.ml index 972fd295..eae3aaab 100644 --- a/driver/Configuration.ml +++ b/driver/Configuration.ml @@ -123,7 +123,7 @@ let get_bool_config key = let arch = match get_config_string "arch" with - | "powerpc"|"arm"|"x86"|"riscV" as a -> a + | "powerpc"|"arm"|"x86"|"riscV"|"mppa_k1c" as a -> a | v -> bad_config "arch" [v] let model = get_config_string "model" let abi = get_config_string "abi" diff --git a/driver/ForwardSimulationBlock.v b/driver/ForwardSimulationBlock.v new file mode 100644 index 00000000..dc8beb29 --- /dev/null +++ b/driver/ForwardSimulationBlock.v @@ -0,0 +1,322 @@ +(*** + +Auxiliary lemmas on starN and forward_simulation +in order to prove the forward simulation of Mach -> Machblock. + +***) + +Require Import Relations. +Require Import Wellfounded. +Require Import Coqlib. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. + + +Local Open Scope nat_scope. + + +(** Auxiliary lemma on starN *) +Section starN_lemma. + +Variable L: semantics. + +Local Hint Resolve starN_refl starN_step Eapp_assoc. + +Lemma starN_split n s t s': + starN (step L) (globalenv L) n s t s' -> + forall m k, n=m+k -> + exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. +Proof. + induction 1; simpl. + + intros m k H; assert (X: m=0); try omega. + assert (X0: k=0); try omega. + subst; repeat (eapply ex_intro); intuition eauto. + + intros m; destruct m as [| m']; simpl. + - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. + - intros k H2. inversion H2. + exploit (IHstarN m' k); eauto. intro. + destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7). + repeat (eapply ex_intro). + instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0). + intuition eauto. subst. auto. +Qed. + +Lemma starN_tailstep n s t1 s': + starN (step L) (globalenv L) n s t1 s' -> + forall (t t2:trace) s'', + Step L s' t2 s'' -> t = t1 ** t2 -> starN (step L) (globalenv L) (S n) s t s''. +Proof. + induction 1; simpl. + + intros t t1 s0; autorewrite with trace_rewrite. + intros; subst; eapply starN_step; eauto. + autorewrite with trace_rewrite; auto. + + intros. eapply starN_step; eauto. + intros; subst; autorewrite with trace_rewrite; auto. +Qed. + +End starN_lemma. + + + +(** General scheme from a "match_states" relation *) + +Section ForwardSimuBlock_REL. + +Variable L1 L2: semantics. + + +(** Hypothèses de la preuve *) + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Variable match_states: state L1 -> state L2 -> Prop. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 s2 r, final_state L1 s1 r -> match_states s1 s2 -> final_state L2 s2 r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> match_states s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states s1' s2'. + + +(** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) + +Local Hint Resolve starN_refl starN_step. + +Definition follows_in_block (head current: state L1): Prop := + dist_end_block head >= dist_end_block current + /\ starN (step L1) (globalenv L1) (minus (dist_end_block head) (dist_end_block current)) head E0 current. + +Lemma follows_in_block_step (head previous next: state L1): + forall t, follows_in_block head previous -> Step L1 previous t next -> (dist_end_block previous)<>0 -> follows_in_block head next. +Proof. + intros t [H1 H2] H3 H4. + destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. + constructor 1. + + omega. + + cutrewrite (dist_end_block head - dist_end_block next = S (dist_end_block head - dist_end_block previous)). + - eapply starN_tailstep; eauto. + - omega. +Qed. + +Lemma follows_in_block_init (head current: state L1): + forall t, Step L1 head t current -> (dist_end_block head)<>0 -> follows_in_block head current. +Proof. + intros t H3 H4. + destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. + constructor 1. + + omega. + + cutrewrite (dist_end_block head - dist_end_block current = 1). + - eapply starN_tailstep; eauto. + - omega. +Qed. + + +Record memostate := { + real: state L1; + memorized: option (state L1); + memo_star: forall head, memorized = Some head -> follows_in_block head real; + memo_final: forall r, final_state L1 real r -> memorized = None +}. + +Definition head (s: memostate): state L1 := + match memorized s with + | None => real s + | Some s' => s' + end. + +Lemma head_followed (s: memostate): follows_in_block (head s) (real s). +Proof. + destruct s as [rs ms Hs]. simpl. + destruct ms as [ms|]; unfold head; simpl; auto. + constructor 1. + omega. + cutrewrite ((dist_end_block rs - dist_end_block rs)%nat=O). + + apply starN_refl; auto. + + omega. +Qed. + +Inductive is_well_memorized (s s': memostate): Prop := + | StartBloc: + dist_end_block (real s) <> O -> + memorized s = None -> + memorized s' = Some (real s) -> + is_well_memorized s s' + | MidBloc: + dist_end_block (real s) <> O -> + memorized s <> None -> + memorized s' = memorized s -> + is_well_memorized s s' + | ExitBloc: + dist_end_block (real s) = O -> + memorized s' = None -> + is_well_memorized s s'. + +Local Hint Resolve StartBloc MidBloc ExitBloc. + +Definition memoL1 := {| + state := memostate; + genvtype := genvtype L1; + step := fun ge s t s' => + step L1 ge (real s) t (real s') + /\ is_well_memorized s s' ; + initial_state := fun s => initial_state L1 (real s) /\ memorized s = None; + final_state := fun s r => final_state L1 (real s) r; + globalenv:= globalenv L1; + symbolenv:= symbolenv L1 +|}. + + +(** Preuve des 2 forward simulations: L1 -> memoL1 et memoL1 -> L2 *) + +Lemma discr_dist_end s: + {dist_end_block s = O} + {dist_end_block s <> O}. +Proof. + destruct (dist_end_block s); simpl; intuition. +Qed. + +Lemma memo_simulation_step: + forall s1 t s1', Step L1 s1 t s1' -> + forall s2, s1 = (real s2) -> exists s2', Step memoL1 s2 t s2' /\ s1' = (real s2'). +Proof. + intros s1 t s1' H1 [rs2 ms2 Hmoi] H2. simpl in H2; subst. + destruct (discr_dist_end rs2) as [H3 | H3]. + + refine (ex_intro _ {|real:=s1'; memorized:=None |} _); simpl. + intuition. + + destruct ms2 as [s|]. + - refine (ex_intro _ {|real:=s1'; memorized:=Some s |} _); simpl. + intuition. + - refine (ex_intro _ {|real:=s1'; memorized:=Some rs2 |} _); simpl. + intuition. + Unshelve. + * intros; discriminate. + * intros; auto. + * intros head X; injection X; clear X; intros; subst. + eapply follows_in_block_step; eauto. + * intros r X; erewrite final_states_end_block in H3; intuition eauto. + * intros head X; injection X; clear X; intros; subst. + eapply follows_in_block_init; eauto. + * intros r X; erewrite final_states_end_block in H3; intuition eauto. +Qed. + +Lemma forward_memo_simulation_1: forward_simulation L1 memoL1. +Proof. + apply forward_simulation_step with (match_states:=fun s1 s2 => s1 = (real s2)); auto. + + intros s1 H; eapply ex_intro with (x:={|real:=s1; memorized:=None |}); simpl. + intuition. + + intros; subst; auto. + + intros; exploit memo_simulation_step; eauto. + Unshelve. + * intros; discriminate. + * auto. +Qed. + +Lemma forward_memo_simulation_2: forward_simulation memoL1 L2. +Proof. + unfold memoL1; simpl. + apply forward_simulation_opt with (measure:=fun s => dist_end_block (real s)) (match_states:=fun s1 s2 => match_states (head s1) s2); simpl; auto. + + intros s1 [H0 H1]; destruct (match_initial_states (real s1) H0). + unfold head; rewrite H1. + intuition eauto. + + intros s1 s2 r X H0; unfold head in X. + erewrite memo_final in X; eauto. + + intros s1 t s1' [H1 H2] s2 H; subst. + destruct H2 as [ H0 H2 H3 | H0 H2 H3 | H0 H2]. + - (* StartBloc *) + constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. + unfold head in * |- *. rewrite H2 in H. rewrite H3. rewrite H4. intuition. + - (* MidBloc *) + constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. + unfold head in * |- *. rewrite H3. rewrite H4. intuition. + destruct (memorized s1); simpl; auto. tauto. + - (* EndBloc *) + constructor 1. + destruct (simu_end_block (head s1) t (real s1') s2) as (s2' & H3 & H4); auto. + * destruct (head_followed s1) as [H4 H3]. + cutrewrite (dist_end_block (head s1) - dist_end_block (real s1) = dist_end_block (head s1)) in H3; try omega. + eapply starN_tailstep; eauto. + * unfold head; rewrite H2; simpl. intuition eauto. +Qed. + +Lemma forward_simulation_block_rel: forward_simulation L1 L2. +Proof. + eapply compose_forward_simulations. + eapply forward_memo_simulation_1. + apply forward_memo_simulation_2. +Qed. + + +End ForwardSimuBlock_REL. + + + +(* An instance of the previous scheme, when there is a translation from L1 states to L2 states + +Here, we do not require that the sequence of S2 states does exactly match the sequence of L1 states by trans_state. +This is because the exact matching is broken in Machblock on "goto" instruction (due to the find_label). + +However, the Machblock state after a goto remains "equivalent" to the trans_state of the Mach state in the sense of "equiv_on_next_step" below... + +*) + +Section ForwardSimuBlock_TRANS. + +Variable L1 L2: semantics. + +Variable trans_state: state L1 -> state L2. + +Definition equiv_on_next_step (P Q: Prop) s2_a s2_b: Prop := + (P -> (forall t s', Step L2 s2_a t s' <-> Step L2 s2_b t s')) /\ (Q -> (forall r, (final_state L2 s2_a r) <-> (final_state L2 s2_b r))). + +Definition match_states s1 s2: Prop := + equiv_on_next_step (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 (trans_state s1). + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + unfold match_states, equiv_on_next_step. intuition. +Qed. + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 r, final_state L1 s1 r -> final_state L2 (trans_state s1) r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1', starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> exists s2', Step L2 (trans_state s1) t s2' /\ match_states s1' s2'. + +Lemma forward_simulation_block_trans: forward_simulation L1 L2. +Proof. + eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states); try tauto. + + (* final_states *) intros s1 s2 r H1 [H2 H3]. rewrite H3; eauto. + + (* simu_end_block *) + intros s1 t s1' s2 H1 [H2a H2b]. exploit simu_end_block; eauto. + intros (s2' & H3 & H4); econstructor 1; intuition eauto. + rewrite H2a; auto. + inversion_clear H1. eauto. +Qed. + +End ForwardSimuBlock_TRANS. diff --git a/driver/Frontend.ml b/driver/Frontend.ml index 88b47854..b29bb7f3 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -94,6 +94,7 @@ let init () = | "riscV" -> if Configuration.model = "64" then Machine.rv64 else Machine.rv32 + | "mppa_k1c" -> Machine.mppa_k1c | _ -> assert false end; Builtins.set C2C.builtins; diff --git a/extraction/debug/Asmgen.ml b/extraction/debug/Asmgen.ml new file mode 100644 index 00000000..e8dfde13 --- /dev/null +++ b/extraction/debug/Asmgen.ml @@ -0,0 +1,126 @@ +(* Replace transl_op by this wrapper to print the op *) + +let transl_op op args res0 k = + match op with + | Omove -> (Printf.eprintf "Omove\n"; thereal_transl_op op args res0 k) + | Ointconst _ -> (Printf.eprintf "Ointconst _\n"; thereal_transl_op op args res0 k) + | Olongconst _ -> (Printf.eprintf "Olongconst _\n"; thereal_transl_op op args res0 k) + | Ofloatconst _ -> (Printf.eprintf "Ofloatconst _\n"; thereal_transl_op op args res0 k) + | Osingleconst _ -> (Printf.eprintf "Osingleconst _\n"; thereal_transl_op op args res0 k) + | Oaddrsymbol _ -> (Printf.eprintf "Oaddrsymbol _ _\n"; thereal_transl_op op args res0 k) + | Oaddrstack _ -> (Printf.eprintf "Oaddrstack _\n"; thereal_transl_op op args res0 k) + | Ocast8signed -> (Printf.eprintf "Ocast8signed\n"; thereal_transl_op op args res0 k) + | Ocast16signed -> (Printf.eprintf "Ocast16signed\n"; thereal_transl_op op args res0 k) + | Oadd -> (Printf.eprintf "Oadd\n"; thereal_transl_op op args res0 k) + | Oaddimm _ -> (Printf.eprintf "Oaddimm _\n"; thereal_transl_op op args res0 k) + | Oneg -> (Printf.eprintf "Oneg\n"; thereal_transl_op op args res0 k) + | Osub -> (Printf.eprintf "Osub\n"; thereal_transl_op op args res0 k) + | Omul -> (Printf.eprintf "Omul\n"; thereal_transl_op op args res0 k) + | Omulhs -> (Printf.eprintf "Omulhs\n"; thereal_transl_op op args res0 k) + | Omulhu -> (Printf.eprintf "Omulhu\n"; thereal_transl_op op args res0 k) + | Odiv -> (Printf.eprintf "Odiv\n"; thereal_transl_op op args res0 k) + | Odivu -> (Printf.eprintf "Odivu\n"; thereal_transl_op op args res0 k) + | Omod -> (Printf.eprintf "Omod\n"; thereal_transl_op op args res0 k) + | Omodu -> (Printf.eprintf "Omodu\n"; thereal_transl_op op args res0 k) + | Oand -> (Printf.eprintf "Oand\n"; thereal_transl_op op args res0 k) + | Oandimm _ -> (Printf.eprintf "Oandimm _\n"; thereal_transl_op op args res0 k) + | Oor -> (Printf.eprintf "Oor\n"; thereal_transl_op op args res0 k) + | Oorimm _ -> (Printf.eprintf "Oorimm _\n"; thereal_transl_op op args res0 k) + | Oxor -> (Printf.eprintf "Oxor\n"; thereal_transl_op op args res0 k) + | Oxorimm _ -> (Printf.eprintf "Oxorimm _\n"; thereal_transl_op op args res0 k) + | Oshl -> (Printf.eprintf "Oshl\n"; thereal_transl_op op args res0 k) + | Oshlimm _ -> (Printf.eprintf "Oshlimm _\n"; thereal_transl_op op args res0 k) + | Oshr -> (Printf.eprintf "Oshr\n"; thereal_transl_op op args res0 k) + | Oshrimm _ -> (Printf.eprintf "Oshrimm _\n"; thereal_transl_op op args res0 k) + | Oshruimm _ -> (Printf.eprintf "Oshruimm _\n"; thereal_transl_op op args res0 k) + | Oshrximm _ -> (Printf.eprintf "Oshrximm _\n"; thereal_transl_op op args res0 k) + | Olowlong -> (Printf.eprintf "Olowlong\n"; thereal_transl_op op args res0 k) + | Ocast32signed -> (Printf.eprintf "Ocast32signed\n"; thereal_transl_op op args res0 k) + | Ocast32unsigned -> (Printf.eprintf "Ocast32unsigned\n"; thereal_transl_op op args res0 k) + | Oaddl -> (Printf.eprintf "Oaddl\n"; thereal_transl_op op args res0 k) + | Oaddlimm _ -> (Printf.eprintf "Oaddlimm _\n"; thereal_transl_op op args res0 k) + | Onegl -> (Printf.eprintf "Onegl\n"; thereal_transl_op op args res0 k) + | Osubl -> (Printf.eprintf "Osubl\n"; thereal_transl_op op args res0 k) + | Omull -> (Printf.eprintf "Omull\n"; thereal_transl_op op args res0 k) + | Omullhs -> (Printf.eprintf "Omullhs\n"; thereal_transl_op op args res0 k) + | Omullhu -> (Printf.eprintf "Omullhu\n"; thereal_transl_op op args res0 k) + | Odivl -> (Printf.eprintf "Odivl\n"; thereal_transl_op op args res0 k) + | Odivlu -> (Printf.eprintf "Odivlu\n"; thereal_transl_op op args res0 k) + | Omodl -> (Printf.eprintf "Omodl\n"; thereal_transl_op op args res0 k) + | Omodlu -> (Printf.eprintf "Omodlu\n"; thereal_transl_op op args res0 k) + | Oandl -> (Printf.eprintf "Oandl\n"; thereal_transl_op op args res0 k) + | Oandlimm _ -> (Printf.eprintf "Oandlimm _\n"; thereal_transl_op op args res0 k) + | Oorl -> (Printf.eprintf "Oorl\n"; thereal_transl_op op args res0 k) + | Oorlimm _ -> (Printf.eprintf "Oorlimm _\n"; thereal_transl_op op args res0 k) + | Oxorl -> (Printf.eprintf "Oxorl\n"; thereal_transl_op op args res0 k) + | Oxorlimm _ -> (Printf.eprintf "Oxorlimm _\n"; thereal_transl_op op args res0 k) + | Oshll -> (Printf.eprintf "Oshll\n"; thereal_transl_op op args res0 k) + | Oshllimm _ -> (Printf.eprintf "Oshllimm _\n"; thereal_transl_op op args res0 k) + | Oshrlu -> (Printf.eprintf "Oshrlu\n"; thereal_transl_op op args res0 k) + | Oshrluimm _ -> (Printf.eprintf "Oshrluimm\n"; thereal_transl_op op args res0 k) + | Oshrxlimm _ -> (Printf.eprintf "Oshrxlimm\n"; thereal_transl_op op args res0 k) + | Onegf -> (Printf.eprintf "Onegf\n"; thereal_transl_op op args res0 k) + | Oabsf -> (Printf.eprintf "Oabsf\n"; thereal_transl_op op args res0 k) + | Oaddf -> (Printf.eprintf "Oaddf\n"; thereal_transl_op op args res0 k) + | Osubf -> (Printf.eprintf "Osubf\n"; thereal_transl_op op args res0 k) + | Omulf -> (Printf.eprintf "Omulf\n"; thereal_transl_op op args res0 k) + | Odivf -> (Printf.eprintf "Odivf\n"; thereal_transl_op op args res0 k) + | Onegfs -> (Printf.eprintf "Onegfs\n"; thereal_transl_op op args res0 k) + | Oabsfs -> (Printf.eprintf "Oabsfs\n"; thereal_transl_op op args res0 k) + | Oaddfs -> (Printf.eprintf "Oaddfs\n"; thereal_transl_op op args res0 k) + | Osubfs -> (Printf.eprintf "Osubfs\n"; thereal_transl_op op args res0 k) + | Omulfs -> (Printf.eprintf "Omulfs\n"; thereal_transl_op op args res0 k) + | Odivfs -> (Printf.eprintf "Odivfs\n"; thereal_transl_op op args res0 k) + | Osingleoffloat -> (Printf.eprintf "Osingleoffloat\n"; thereal_transl_op op args res0 k) + | Ofloatofsingle -> (Printf.eprintf "Ofloatofsingle\n"; thereal_transl_op op args res0 k) + | Ointoffloat -> (Printf.eprintf "Ointoffloat\n"; thereal_transl_op op args res0 k) + | Ointuoffloat -> (Printf.eprintf "Ointuoffloat\n"; thereal_transl_op op args res0 k) + | Ofloatofint -> (Printf.eprintf "Ofloatofint\n"; thereal_transl_op op args res0 k) + | Ofloatofintu -> (Printf.eprintf "Ofloatofintu\n"; thereal_transl_op op args res0 k) + | Ointofsingle -> (Printf.eprintf "Ointofsingle\n"; thereal_transl_op op args res0 k) + | Ointuofsingle -> (Printf.eprintf "Ointuofsingle\n"; thereal_transl_op op args res0 k) + | Osingleofint -> (Printf.eprintf "Osingleofint\n"; thereal_transl_op op args res0 k) + | Osingleofintu -> (Printf.eprintf "Osingleofintu\n"; thereal_transl_op op args res0 k) + | Olongoffloat -> (Printf.eprintf "Olongoffloat\n"; thereal_transl_op op args res0 k) + | Olonguoffloat -> (Printf.eprintf "Olonguoffloat\n"; thereal_transl_op op args res0 k) + | Ofloatoflong -> (Printf.eprintf "Ofloatoflong\n"; thereal_transl_op op args res0 k) + | Ofloatoflongu -> (Printf.eprintf "Ofloatoflongu\n"; thereal_transl_op op args res0 k) + | Olongofsingle -> (Printf.eprintf "Olongofsingle\n"; thereal_transl_op op args res0 k) + | Olonguofsingle -> (Printf.eprintf "Olonguofsingle\n"; thereal_transl_op op args res0 k) + | Osingleoflong -> (Printf.eprintf "Osingleoflong\n"; thereal_transl_op op args res0 k) + | Osingleoflongu -> (Printf.eprintf "Osingleoflongu\n"; thereal_transl_op op args res0 k) + | Ocmp _ -> (Printf.eprintf "Ocmp _\n"; thereal_transl_op op args res0 k) + | _ -> (Printf.eprintf "_\n"; thereal_transl_op op args res0 k) + +let transl_instr f i x k = + match i with + | Mgetstack _ -> (Printf.eprintf "Mgetstack\n"; thereal_transl_instr f i x k) + | Msetstack _ -> (Printf.eprintf "Msetstack\n"; thereal_transl_instr f i x k) + | Mgetparam _ -> (Printf.eprintf "Mgetparam\n"; thereal_transl_instr f i x k) + | Mop _ -> (Printf.eprintf "Mop\n"; thereal_transl_instr f i x k) + | Mload _ -> (Printf.eprintf "Mload\n"; thereal_transl_instr f i x k) + | Mstore _ -> (Printf.eprintf "Mstore\n"; thereal_transl_instr f i x k) + | Mcall _ -> (Printf.eprintf "Mcall\n"; thereal_transl_instr f i x k) + | Mtailcall _ -> (Printf.eprintf "Mtailcall\n"; thereal_transl_instr f i x k) + | Mbuiltin _ -> (Printf.eprintf "Mbuiltin\n"; thereal_transl_instr f i x k) + | Mlabel _ -> (Printf.eprintf "Mlabel\n"; thereal_transl_instr f i x k) + | Mgoto _ -> (Printf.eprintf "Mgoto\n"; thereal_transl_instr f i x k) + | Mcond _ -> (Printf.eprintf "Mcond\n"; thereal_transl_instr f i x k) + | Mjumptable _ -> (Printf.eprintf "Mjumptable\n"; thereal_transl_instr f i x k) + | Mreturn -> (Printf.eprintf "Mreturn\n"; thereal_transl_instr f i x k) + +let transl_cbranch c a l k = + match c, a with + | Ccomp _, _ :: _ :: [] -> (Printf.eprintf "Ccomp\n"; thereal_transl_cbranch c a l k) + | Ccompu _, _ :: _ :: [] -> (Printf.eprintf "Ccompu\n"; thereal_transl_cbranch c a l k) + | Ccompimm (_, _), _ :: [] -> (Printf.eprintf "Ccompimm\n"; thereal_transl_cbranch c a l k) + | Ccompuimm (_, _), _ :: [] -> (Printf.eprintf "Ccompuimm\n"; thereal_transl_cbranch c a l k) + | Ccompl _, _ :: _ :: [] -> (Printf.eprintf "Ccompl\n"; thereal_transl_cbranch c a l k) + | Ccomplu _, _ :: _ :: [] -> (Printf.eprintf "Ccomplu\n"; thereal_transl_cbranch c a l k) + | Ccomplimm (_, _), _ :: [] -> (Printf.eprintf "Ccomplimm\n"; thereal_transl_cbranch c a l k) + | Ccompluimm (_, _), _ :: [] -> (Printf.eprintf "Ccompulimm\n"; thereal_transl_cbranch c a l k) + | Ccompf _, _ :: _ :: [] -> (Printf.eprintf "Ccompf\n"; thereal_transl_cbranch c a l k) + | Cnotcompf _, _ :: _ :: [] -> (Printf.eprintf "Cnotcompf\n"; thereal_transl_cbranch c a l k) + | Ccompfs _, _ :: _ :: [] -> (Printf.eprintf "Ccomps\n"; thereal_transl_cbranch c a l k) + | Cnotcompfs _, _ :: _ :: [] -> (Printf.eprintf "Cnotcomps\n"; thereal_transl_cbranch c a l k) + | _ -> (Printf.eprintf "OOPS\n"; thereal_transl_cbranch c a l k) diff --git a/extraction/extraction.v b/extraction/extraction.v index a47a7237..6ab2ce3a 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -167,6 +167,7 @@ Set Extraction AccessOpaque. Cd "extraction". Separate Extraction + Asm.dummy_function Asmgen.addptrofs Asmgen.storeind_ptr Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v new file mode 100644 index 00000000..bbe66c5b --- /dev/null +++ b/mppa_k1c/Archi.v @@ -0,0 +1,65 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Jacques-Henri Jourdan, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Architecture-dependent parameters for RISC-V *) + +Require Import ZArith. +Require Import Fappli_IEEE. +Require Import Fappli_IEEE_bits. + +Definition ptr64 := true. + +Definition big_endian := false. + +Definition align_int64 := 8%Z. +Definition align_float64 := 8%Z. + +Definition splitlong := negb ptr64. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong. destruct ptr64; simpl; congruence. +Qed. + +(** Section 7.3: "Except when otherwise stated, if the result of a + floating-point operation is NaN, it is the canonical NaN. The + canonical NaN has a positive sign and all significand bits clear + except the MSB, a.k.a. the quiet bit." + We need to extend the [choose_binop_pl] functions to account for + this case. *) + +Program Definition default_pl_64 : bool * nan_pl 53 := + (false, iter_nat 51 _ xO xH). + +Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := + false. (**r always choose first NaN *) + +Program Definition default_pl_32 : bool * nan_pl 24 := + (false, iter_nat 22 _ xO xH). + +Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := + false. (**r always choose first NaN *) + +Definition float_of_single_preserves_sNaN := false. + +Global Opaque ptr64 big_endian splitlong + default_pl_64 choose_binop_pl_64 + default_pl_32 choose_binop_pl_32 + float_of_single_preserves_sNaN. + +(** Whether to generate position-independent code or not *) + +Parameter pic_code: unit -> bool. diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v new file mode 100644 index 00000000..c142185c --- /dev/null +++ b/mppa_k1c/Asm.v @@ -0,0 +1,496 @@ +(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* Prashanth Mundkur, SRI International *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* The contributions by Prashanth Mundkur are reused and adapted *)
+(* under the terms of a Contributor License Agreement between *)
+(* SRI International and INRIA. *)
+(* *)
+(* *********************************************************************)
+
+(** Abstract syntax and semantics for K1c assembly language. *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Locations.
+Require Stacklayout.
+Require Import Conventions.
+Require Import Asmblock.
+Require Import Linking.
+Require Import Errors.
+
+(** Definitions for OCaml code *)
+Definition label := positive.
+Definition preg := preg.
+
+(** Syntax *)
+Inductive instruction : Type :=
+ (** pseudo instructions *)
+ | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *)
+ | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *)
+ | Plabel (lbl: label) (**r define a code label *)
+ | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *)
+ | Pbuiltin: external_function -> list (builtin_arg preg)
+ -> builtin_res preg -> instruction (**r built-in function (pseudo) *)
+ | Pnop (**r instruction that does nothing *)
+
+ (** builtins *)
+ | Pclzll (rd rs: ireg)
+ | Pstsud (rd rs1 rs2: ireg)
+
+ (** Control flow instructions *)
+ | Pget (rd: ireg) (rs: preg) (**r get system register *)
+ | Pset (rd: preg) (rs: ireg) (**r set system register *)
+ | Pret (**r return *)
+ | Pcall (l: label) (**r function call *)
+ (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)
+ | Pgoto (l: label) (**r goto *)
+ | Pj_l (l: label) (**r jump to label *)
+ | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *)
+ | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *)
+
+ (** Loads **)
+ | Plb (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte *)
+ | Plbu (rd: ireg) (ra: ireg) (ofs: offset) (**r load byte unsigned *)
+ | Plh (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word *)
+ | Plhu (rd: ireg) (ra: ireg) (ofs: offset) (**r load half word unsigned *)
+ | Plw (rd: ireg) (ra: ireg) (ofs: offset) (**r load int32 *)
+ | Plw_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any32 *)
+ | Pld (rd: ireg) (ra: ireg) (ofs: offset) (**r load int64 *)
+ | Pld_a (rd: ireg) (ra: ireg) (ofs: offset) (**r load any64 *)
+ | Pfls (rd: freg) (ra: ireg) (ofs: offset) (**r load float *)
+ | Pfld (rd: freg) (ra: ireg) (ofs: offset) (**r load 64-bit float *)
+
+ (** Stores **)
+ | Psb (rs: ireg) (ra: ireg) (ofs: offset) (**r store byte *)
+ | Psh (rs: ireg) (ra: ireg) (ofs: offset) (**r store half byte *)
+ | Psw (rs: ireg) (ra: ireg) (ofs: offset) (**r store int32 *)
+ | Psw_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any32 *)
+ | Psd (rs: ireg) (ra: ireg) (ofs: offset) (**r store int64 *)
+ | Psd_a (rs: ireg) (ra: ireg) (ofs: offset) (**r store any64 *)
+ | Pfss (rs: freg) (ra: ireg) (ofs: offset) (**r store float *)
+ | Pfsd (rd: freg) (ra: ireg) (ofs: offset) (**r store 64-bit float *)
+
+ (** Arith R *)
+ | Pcvtw2l (rd: ireg) (**r Convert Word to Long *)
+
+ (** Arith RR *)
+ | Pmv (rd rs: ireg) (**r register move *)
+ | Pnegw (rd rs: ireg) (**r negate word *)
+ | Pnegl (rd rs: ireg) (**r negate long *)
+ | Pfnegd (rd rs: ireg) (**r float negate double *)
+ | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *)
+ | Pmvw2l (rd rs: ireg) (**r Move Convert Word to Long *)
+
+ (** Arith RI32 *)
+ | Pmake (rd: ireg) (imm: int) (**r load immediate *)
+
+ (** Arith RI64 *)
+ | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *)
+
+ (** Arith RRR *)
+ | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *)
+ | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *)
+
+ | Paddw (rd rs1 rs2: ireg) (**r add word *)
+ | Psubw (rd rs1 rs2: ireg) (**r sub word *)
+ | Pmulw (rd rs1 rs2: ireg) (**r mul word *)
+ | Pandw (rd rs1 rs2: ireg) (**r and word *)
+ | Porw (rd rs1 rs2: ireg) (**r or word *)
+ | Pxorw (rd rs1 rs2: ireg) (**r xor word *)
+ | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *)
+ | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *)
+ | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *)
+
+ | Paddl (rd rs1 rs2: ireg) (**r add long *)
+ | Psubl (rd rs1 rs2: ireg) (**r sub long *)
+ | Pandl (rd rs1 rs2: ireg) (**r and long *)
+ | Porl (rd rs1 rs2: ireg) (**r or long *)
+ | Pxorl (rd rs1 rs2: ireg) (**r xor long *)
+ | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *)
+ | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *)
+ | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *)
+ | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *)
+
+ (** Arith RRI32 *)
+ | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *)
+
+ | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *)
+ | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *)
+ | Poriw (rd rs: ireg) (imm: int) (**r or imm word *)
+ | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *)
+ | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *)
+ | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *)
+ | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *)
+
+ | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *)
+ | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *)
+ | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *)
+
+ (** Arith RRI64 *)
+ | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *)
+ | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *)
+ | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
+ | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *)
+ | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
+ .
+
+(** Correspondance between Asmblock and Asm *)
+
+Definition control_to_instruction (c: control) :=
+ match c with
+ | PExpand (Asmblock.Pbuiltin ef args res) => Pbuiltin ef args res
+ | PCtlFlow Asmblock.Pret => Pret
+ | PCtlFlow (Asmblock.Pcall l) => Pcall l
+ | PCtlFlow (Asmblock.Pgoto l) => Pgoto l
+ | PCtlFlow (Asmblock.Pj_l l) => Pj_l l
+ | PCtlFlow (Asmblock.Pcb bt r l) => Pcb bt r l
+ | PCtlFlow (Asmblock.Pcbu bt r l) => Pcbu bt r l
+ end.
+
+Definition basic_to_instruction (b: basic) :=
+ match b with
+ (** Special basics *)
+ | Asmblock.Pget rd rs => Pget rd rs
+ | Asmblock.Pset rd rs => Pset rd rs
+ | Asmblock.Pnop => Pnop
+ | Asmblock.Pallocframe sz pos => Pallocframe sz pos
+ | Asmblock.Pfreeframe sz pos => Pfreeframe sz pos
+
+ (** PArith basics *)
+ (* R *)
+ | PArithR Asmblock.Pcvtw2l r => Pcvtw2l r
+ | PArithR (Asmblock.Ploadsymbol id ofs) r => Ploadsymbol r id ofs
+
+ (* RR *)
+ | PArithRR Asmblock.Pmv rd rs => Pmv rd rs
+ | PArithRR Asmblock.Pnegw rd rs => Pnegw rd rs
+ | PArithRR Asmblock.Pnegl rd rs => Pfnegd rd rs
+ | PArithRR Asmblock.Pcvtl2w rd rs => Pcvtl2w rd rs
+ | PArithRR Asmblock.Pmvw2l rd rs => Pmvw2l rd rs
+ | PArithRR Asmblock.Pfnegd rd rs => Pfnegd rd rs
+
+ (* RI32 *)
+ | PArithRI32 Asmblock.Pmake rd imm => Pmake rd imm
+
+ (* RI64 *)
+ | PArithRI64 Asmblock.Pmakel rd imm => Pmakel rd imm
+
+ (* RRR *)
+ | PArithRRR (Asmblock.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2
+ | PArithRRR (Asmblock.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2
+ | PArithRRR Asmblock.Paddw rd rs1 rs2 => Paddw rd rs1 rs2
+ | PArithRRR Asmblock.Psubw rd rs1 rs2 => Psubw rd rs1 rs2
+ | PArithRRR Asmblock.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2
+ | PArithRRR Asmblock.Pandw rd rs1 rs2 => Pandw rd rs1 rs2
+ | PArithRRR Asmblock.Porw rd rs1 rs2 => Porw rd rs1 rs2
+ | PArithRRR Asmblock.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2
+ | PArithRRR Asmblock.Psraw rd rs1 rs2 => Psraw rd rs1 rs2
+ | PArithRRR Asmblock.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2
+ | PArithRRR Asmblock.Psllw rd rs1 rs2 => Psllw rd rs1 rs2
+
+ | PArithRRR Asmblock.Paddl rd rs1 rs2 => Paddl rd rs1 rs2
+ | PArithRRR Asmblock.Psubl rd rs1 rs2 => Psubl rd rs1 rs2
+ | PArithRRR Asmblock.Pandl rd rs1 rs2 => Pandl rd rs1 rs2
+ | PArithRRR Asmblock.Porl rd rs1 rs2 => Porl rd rs1 rs2
+ | PArithRRR Asmblock.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2
+ | PArithRRR Asmblock.Pmull rd rs1 rs2 => Pmull rd rs1 rs2
+ | PArithRRR Asmblock.Pslll rd rs1 rs2 => Pslll rd rs1 rs2
+ | PArithRRR Asmblock.Psrll rd rs1 rs2 => Psrll rd rs1 rs2
+ | PArithRRR Asmblock.Psral rd rs1 rs2 => Psral rd rs1 rs2
+
+ (* RRI32 *)
+ | PArithRRI32 (Asmblock.Pcompiw it) rd rs imm => Pcompiw it rd rs imm
+ | PArithRRI32 Asmblock.Paddiw rd rs imm => Paddiw rd rs imm
+ | PArithRRI32 Asmblock.Pandiw rd rs imm => Pandiw rd rs imm
+ | PArithRRI32 Asmblock.Poriw rd rs imm => Poriw rd rs imm
+ | PArithRRI32 Asmblock.Pxoriw rd rs imm => Pxoriw rd rs imm
+ | PArithRRI32 Asmblock.Psraiw rd rs imm => Psraiw rd rs imm
+ | PArithRRI32 Asmblock.Psrliw rd rs imm => Psrliw rd rs imm
+ | PArithRRI32 Asmblock.Pslliw rd rs imm => Pslliw rd rs imm
+ | PArithRRI32 Asmblock.Psllil rd rs imm => Psllil rd rs imm
+ | PArithRRI32 Asmblock.Psrlil rd rs imm => Psrlil rd rs imm
+ | PArithRRI32 Asmblock.Psrail rd rs imm => Psrail rd rs imm
+
+ (* RRI64 *)
+ | PArithRRI64 (Asmblock.Pcompil it) rd rs imm => Pcompil it rd rs imm
+ | PArithRRI64 Asmblock.Paddil rd rs imm => Paddil rd rs imm
+ | PArithRRI64 Asmblock.Pandil rd rs imm => Pandil rd rs imm
+ | PArithRRI64 Asmblock.Poril rd rs imm => Poril rd rs imm
+ | PArithRRI64 Asmblock.Pxoril rd rs imm => Pxoril rd rs imm
+
+ (** Load *)
+ | PLoadRRO Asmblock.Plb rd ra ofs => Plb rd ra ofs
+ | PLoadRRO Asmblock.Plbu rd ra ofs => Plbu rd ra ofs
+ | PLoadRRO Asmblock.Plh rd ra ofs => Plh rd ra ofs
+ | PLoadRRO Asmblock.Plhu rd ra ofs => Plhu rd ra ofs
+ | PLoadRRO Asmblock.Plw rd ra ofs => Plw rd ra ofs
+ | PLoadRRO Asmblock.Plw_a rd ra ofs => Plw_a rd ra ofs
+ | PLoadRRO Asmblock.Pld rd ra ofs => Pld rd ra ofs
+ | PLoadRRO Asmblock.Pld_a rd ra ofs => Pld_a rd ra ofs
+ | PLoadRRO Asmblock.Pfls rd ra ofs => Pfls rd ra ofs
+ | PLoadRRO Asmblock.Pfld rd ra ofs => Pfld rd ra ofs
+
+ (** Store *)
+ | PStoreRRO Asmblock.Psb rd ra ofs => Psb rd ra ofs
+ | PStoreRRO Asmblock.Psh rd ra ofs => Psh rd ra ofs
+ | PStoreRRO Asmblock.Psw rd ra ofs => Psw rd ra ofs
+ | PStoreRRO Asmblock.Psw_a rd ra ofs => Psw_a rd ra ofs
+ | PStoreRRO Asmblock.Psd rd ra ofs => Psd rd ra ofs
+ | PStoreRRO Asmblock.Psd_a rd ra ofs => Psd_a rd ra ofs
+ | PStoreRRO Asmblock.Pfss rd ra ofs => Pfss rd ra ofs
+ | PStoreRRO Asmblock.Pfsd rd ra ofs => Pfss rd ra ofs
+
+ end.
+
+Section RELSEM.
+
+Definition code := list instruction.
+
+Fixpoint unfold_label (ll: list label) :=
+ match ll with
+ | nil => nil
+ | l :: ll => Plabel l :: unfold_label ll
+ end.
+
+Fixpoint unfold_body (lb: list basic) :=
+ match lb with
+ | nil => nil
+ | b :: lb => basic_to_instruction b :: unfold_body lb
+ end.
+
+Definition unfold_exit (oc: option control) :=
+ match oc with
+ | None => nil
+ | Some c => control_to_instruction c :: nil
+ end.
+
+Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ unfold_body (body b) ++ unfold_exit (exit b).
+
+Fixpoint unfold (lb: bblocks) :=
+ match lb with
+ | nil => nil
+ | b :: lb => (unfold_bblock b) ++ unfold lb
+ end.
+
+Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code;
+ correct: unfold fn_blocks = fn_code }.
+
+(* For OCaml code *)
+Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}.
+
+Definition fundef := AST.fundef function.
+Definition program := AST.program fundef unit.
+Definition genv := Genv.t fundef unit.
+
+Definition function_proj (f: function) := Asmblock.mkfunction (fn_sig f) (fn_blocks f).
+
+(*
+Definition fundef_proj (fu: fundef) : Asmblock.fundef := transf_fundef function_proj fu.
+
+Definition program_proj (p: program) : Asmblock.program := transform_program fundef_proj p.
+ *)
+
+Definition fundef_proj (fu: fundef) : Asmblock.fundef :=
+ match fu with
+ | Internal f => Internal (function_proj f)
+ | External ef => External ef
+ end.
+
+Definition globdef_proj (gd: globdef fundef unit) : globdef Asmblock.fundef unit :=
+ match gd with
+ | Gfun f => Gfun (fundef_proj f)
+ | Gvar gu => Gvar gu
+ end.
+
+Program Definition genv_trans (ge: genv) : Asmblock.genv :=
+ {| Genv.genv_public := Genv.genv_public ge;
+ Genv.genv_symb := Genv.genv_symb ge;
+ Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge);
+ Genv.genv_next := Genv.genv_next ge |}.
+Next Obligation.
+ destruct ge. simpl in *. eauto.
+Qed. Next Obligation.
+ destruct ge; simpl in *.
+ rewrite PTree.gmap1 in H.
+ destruct (genv_defs ! b) eqn:GEN.
+ - eauto.
+ - discriminate.
+Qed. Next Obligation.
+ destruct ge; simpl in *.
+ eauto.
+Qed.
+
+Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit))
+ : list (ident * globdef Asmblock.fundef unit) :=
+ match l with
+ | nil => nil
+ | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l
+ end.
+
+Definition program_proj (p: program) : Asmblock.program :=
+ {| prog_defs := prog_defs_proj (prog_defs p);
+ prog_public := prog_public p;
+ prog_main := prog_main p
+ |}.
+
+End RELSEM.
+
+Definition semantics (p: program) := Asmblock.semantics (program_proj p).
+
+(** Determinacy of the [Asm] semantics. *)
+
+Lemma semantics_determinate: forall p, determinate (semantics p).
+Proof.
+ intros. apply semantics_determinate.
+Qed.
+
+(** transf_program *)
+
+Program Definition transf_function (f: Asmblock.function) : function :=
+ {| fn_sig := Asmblock.fn_sig f; fn_blocks := Asmblock.fn_blocks f;
+ fn_code := unfold (Asmblock.fn_blocks f) |}.
+
+Lemma transf_function_proj: forall f, function_proj (transf_function f) = f.
+Proof.
+ intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto.
+Qed.
+
+Definition transf_fundef : Asmblock.fundef -> fundef := AST.transf_fundef transf_function.
+
+Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f.
+Proof.
+ intros f. destruct f as [f|e]; simpl; auto.
+ rewrite transf_function_proj. auto.
+Qed.
+
+(* Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit :=
+ match gd with
+ | Gfun f => Gfun (transf_fundef f)
+ | Gvar gu => Gvar gu
+ end.
+
+Lemma transf_globdef_proj: forall gd, globdef_proj (transf_globdef gd) = gd.
+Proof.
+ intros gd. destruct gd as [f|v]; simpl; auto.
+ rewrite transf_fundef_proj; auto.
+Qed.
+
+Fixpoint transf_prog_defs (l: list (ident * globdef Asmblock.fundef unit))
+ : list (ident * globdef fundef unit) :=
+ match l with
+ | nil => nil
+ | (i, gd) :: l => (i, transf_globdef gd) :: transf_prog_defs l
+ end.
+
+Lemma transf_prog_proj: forall p, prog_defs p = prog_defs_proj (transf_prog_defs (prog_defs p)).
+Proof.
+ intros p. destruct p as [defs pub main]. simpl.
+ induction defs; simpl; auto.
+ destruct a as [i gd]. simpl.
+ rewrite transf_globdef_proj.
+ congruence.
+Qed.
+ *)
+
+Definition transf_program : Asmblock.program -> program := transform_program transf_fundef.
+
+Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B),
+ prog_defs p1 = prog_defs p2 ->
+ prog_public p1 = prog_public p2 ->
+ prog_main p1 = prog_main p2 ->
+ p1 = p2.
+Proof.
+ intros. destruct p1. destruct p2. simpl in *. subst. auto.
+Qed.
+
+Lemma transf_program_proj: forall p, program_proj (transf_program p) = p.
+Proof.
+ intros p. destruct p as [defs pub main]. unfold program_proj. simpl.
+ apply program_equals; simpl; auto.
+ induction defs.
+ - simpl; auto.
+ - simpl. rewrite IHdefs.
+ destruct a as [id gd]; simpl.
+ destruct gd as [f|v]; simpl; auto.
+ rewrite transf_fundef_proj. auto.
+Qed.
+
+Definition match_prog (p: Asmblock.program) (tp: program) :=
+ match_program (fun _ f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match:
+ forall p tp, transf_program p = tp -> match_prog p tp.
+Proof.
+ intros. rewrite <- H. eapply match_transform_program; eauto.
+Qed.
+
+Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l.
+Proof.
+ intros. congruence.
+Qed.
+
+(* I think it is a special case of Asmblock -> Asm. Very handy to have *)
+Lemma match_program_transf:
+ forall p tp, match_prog p tp -> transf_program p = tp.
+Proof.
+ intros p tp H. inversion_clear H. inv H1.
+ destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *.
+ subst. unfold transf_program. unfold transform_program. simpl.
+ apply program_equals; simpl; auto.
+ induction H0; simpl; auto.
+ rewrite IHlist_forall2. apply cons_extract.
+ destruct a1 as [ida gda]. destruct b1 as [idb gdb].
+ simpl in *.
+ inv H. inv H2.
+ - simpl in *. subst. auto.
+ - simpl in *. subst. inv H. auto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: Asmblock.program.
+Variable tprog: program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Definition match_states (s1 s2: state) := s1 = s2.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+
+Theorem transf_program_correct:
+ forward_simulation (Asmblock.semantics prog) (semantics tprog).
+Proof.
+ pose proof (match_program_transf prog tprog TRANSF) as TR.
+ subst. unfold semantics. rewrite transf_program_proj.
+
+ eapply forward_simulation_step with (match_states := match_states); simpl; auto.
+ - intros. exists s1. split; auto. congruence.
+ - intros. inv H. auto.
+ - intros. exists s1'. inv H0. split; auto. congruence.
+Qed.
+
+End PRESERVATION.
diff --git a/mppa_k1c/AsmToJSON.ml b/mppa_k1c/AsmToJSON.ml new file mode 100644 index 00000000..8a6a97a7 --- /dev/null +++ b/mppa_k1c/AsmToJSON.ml @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +(* Simple functions to serialize RISC-V Asm to JSON *) + +(* Dummy function *) +let destination: string option ref = ref None + +let sdump_folder = ref "" + +let print_if prog sourcename = + () + +let pp_mnemonics pp = () diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v new file mode 100644 index 00000000..557ab788 --- /dev/null +++ b/mppa_k1c/Asmblock.v @@ -0,0 +1,1361 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Abstract syntax and semantics for K1c assembly language. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. + +(** * Abstract syntax *) + +(** General Purpose registers. +*) + +Inductive gpreg: Type := + | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg + | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg + | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg + | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg + | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg + | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg + | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg + | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg + | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg + | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg + | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg + | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg + | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. + +Definition ireg := gpreg. +Definition freg := gpreg. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** We model the following registers of the RISC-V architecture. *) + +(** basic register *) +Inductive preg: Type := + | IR: gpreg -> preg (**r integer registers *) + | FR: gpreg -> preg (**r float registers *) + | RA: preg + | PC: preg + . + +Coercion IR: gpreg >-> preg. +Coercion FR: gpreg >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) + +Notation "'SP'" := GPR12 (only parsing) : asm. +Notation "'FP'" := GPR10 (only parsing) : asm. +Notation "'RTMP'" := GPR31 (only parsing) : asm. + +Inductive btest: Type := + | BTdnez (**r Double Not Equal to Zero *) + | BTdeqz (**r Double Equal to Zero *) + | BTdltz (**r Double Less Than Zero *) + | BTdgez (**r Double Greater Than or Equal to Zero *) + | BTdlez (**r Double Less Than or Equal to Zero *) + | BTdgtz (**r Double Greater Than Zero *) +(*| BTodd (**r Odd (LSB Set) *) + | BTeven (**r Even (LSB Clear) *) +*)| BTwnez (**r Word Not Equal to Zero *) + | BTweqz (**r Word Equal to Zero *) + | BTwltz (**r Word Less Than Zero *) + | BTwgez (**r Word Greater Than or Equal to Zero *) + | BTwlez (**r Word Less Than or Equal to Zero *) + | BTwgtz (**r Word Greater Than Zero *) + . + +Inductive itest: Type := + | ITne (**r Not Equal *) + | ITeq (**r Equal *) + | ITlt (**r Less Than *) + | ITge (**r Greater Than or Equal *) + | ITle (**r Less Than or Equal *) + | ITgt (**r Greater Than *) + | ITneu (**r Unsigned Not Equal *) + | ITequ (**r Unsigned Equal *) + | ITltu (**r Less Than Unsigned *) + | ITgeu (**r Greater Than or Equal Unsigned *) + | ITleu (**r Less Than or Equal Unsigned *) + | ITgtu (**r Greater Than Unsigned *) + (* Not used yet *) + | ITall (**r All Bits Set in Mask *) + | ITnall (**r Not All Bits Set in Mask *) + | ITany (**r Any Bits Set in Mask *) + | ITnone (**r Not Any Bits Set in Mask *) + . + +(** Offsets for load and store instructions. An offset is either an + immediate integer or the low part of a symbol. *) + +Inductive offset : Type := + | Ofsimm (ofs: ptrofs) + | Ofslow (id: ident) (ofs: ptrofs). + +(** We model a subset of the K1c instruction set. In particular, we do not + support floats yet. + + Although it is possible to use the 32-bits mode, for now we don't support it. + + We follow a design close to the one used for the Risc-V port: one set of + pseudo-instructions for 32-bit integer arithmetic, with suffix W, another + set for 64-bit integer arithmetic, with suffix L. + + When mapping to actual instructions, the OCaml code in TargetPrinter.ml + throws an error if we are not in 64-bits mode. +*) + +(** * Instructions *) + +Definition label := positive. + +(* FIXME - rewrite the comment *) +(** A note on immediates: there are various constraints on immediate + operands to K1c instructions. We do not attempt to capture these + restrictions in the abstract syntax nor in the semantics. The + assembler will emit an error if immediate operands exceed the + representable range. Of course, our K1c generator (file + [Asmgen]) is careful to respect this range. *) + +(** Instructions to be expanded in control-flow +*) +Inductive ex_instruction : Type := + (* Pseudo-instructions *) +(*| Ploadsymbol_high (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the high part of the address of a symbol *) + | Pbtbl (r: ireg) (tbl: list label) (**r N-way branch through a jump table *) *) + + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) +. + +(** FIXME: comment not up to date ! + + + The pseudo-instructions are the following: + +- [Ploadsymbol]: load the address of a symbol in an integer register. + Expands to the [la] assembler pseudo-instruction, which does the right + thing even if we are in PIC mode. + +- [Pallocframe sz pos]: in the formal semantics, this + pseudo-instruction allocates a memory block with bounds [0] and + [sz], stores the value of the stack pointer at offset [pos] in this + block, and sets the stack pointer to the address of the bottom of + this block. + In the printed ASM assembly code, this allocation is: +<< + mv x30, sp + sub sp, sp, #sz + sw x30, #pos(sp) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. + +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction + reads the word at [pos] of the block pointed by the stack pointer, + frees this block, and sets the stack pointer to the value read. + In the printed ASM assembly code, this freeing is just an increment of [sp]: +<< + add sp, sp, #sz +>> + Again, our memory model cannot comprehend that this operation + frees (logically) the current stack frame. + +- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table + as follows: +<< + la x31, table + add x31, x31, reg + jr x31 +table: .long table[0], table[1], ... +>> + Note that [reg] contains 4 times the index of the desired table entry. +*) + +(** Control Flow instructions *) +Inductive cf_instruction : Type := + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pj_l (l: label) (**r jump to label *) + + (* Conditional branches *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) +. + +(** Loads **) +Inductive load_name_rro : Type := + | Plb (**r load byte *) + | Plbu (**r load byte unsigned *) + | Plh (**r load half word *) + | Plhu (**r load half word unsigned *) + | Plw (**r load int32 *) + | Plw_a (**r load any32 *) + | Pld (**r load int64 *) + | Pld_a (**r load any64 *) + | Pfls (**r load float *) + | Pfld (**r load 64-bit float *) +. + +Inductive ld_instruction : Type := + | PLoadRRO (i: load_name_rro) (rd: ireg) (ra: ireg) (ofs: offset) +. + +Coercion PLoadRRO: load_name_rro >-> Funclass. + +(** Stores **) +Inductive store_name_rro : Type := + | Psb (**r store byte *) + | Psh (**r store half byte *) + | Psw (**r store int32 *) + | Psw_a (**r store any32 *) + | Psd (**r store int64 *) + | Psd_a (**r store any64 *) + | Pfss (**r store float *) + | Pfsd (**r store 64-bit float *) +. + +Inductive st_instruction : Type := + | PStoreRRO (i: store_name_rro) (rs: ireg) (ra: ireg) (ofs: offset) +. + +Coercion PStoreRRO: store_name_rro >-> Funclass. + +(** Arithmetic instructions **) +Inductive arith_name_r : Type := + | Pcvtw2l (**r Convert Word to Long *) + | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) +. + +Inductive arith_name_rr : Type := + | Pmv (**r register move *) + | Pnegw (**r negate word *) + | Pnegl (**r negate long *) + | Pfnegd (**r float negate double *) + | Pcvtl2w (**r Convert Long to Word *) + | Pmvw2l (**r Move Convert Word to Long *) +. + +Inductive arith_name_ri32 : Type := + | Pmake (**r load immediate *) +. + +Inductive arith_name_ri64 : Type := + | Pmakel (**r load immediate long *) +. + +Inductive arith_name_rrr : Type := + | Pcompw (it: itest) (**r comparison word *) + | Pcompl (it: itest) (**r comparison long *) + + | Paddw (**r add word *) + | Psubw (**r sub word *) + | Pmulw (**r mul word *) + | Pandw (**r and word *) + | Porw (**r or word *) + | Pxorw (**r xor word *) + | Psraw (**r shift right arithmetic word *) + | Psrlw (**r shift right logical word *) + | Psllw (**r shift left logical word *) + + | Paddl (**r add long *) + | Psubl (**r sub long *) + | Pandl (**r and long *) + | Porl (**r or long *) + | Pxorl (**r xor long *) + | Pmull (**r mul long (low part) *) + | Pslll (**r shift left logical long *) + | Psrll (**r shift right logical long *) + | Psral (**r shift right arithmetic long *) +. + +Inductive arith_name_rri32 : Type := + | Pcompiw (it: itest) (**r comparison imm word *) + + | Paddiw (**r add imm word *) + | Pandiw (**r and imm word *) + | Poriw (**r or imm word *) + | Pxoriw (**r xor imm word *) + | Psraiw (**r shift right arithmetic imm word *) + | Psrliw (**r shift right logical imm word *) + | Pslliw (**r shift left logical imm word *) + + | Psllil (**r shift left logical immediate long *) + | Psrlil (**r shift right logical immediate long *) + | Psrail (**r shift right arithmetic immediate long *) +. + +Inductive arith_name_rri64 : Type := + | Pcompil (it: itest) (**r comparison imm long *) + | Paddil (**r add immediate long *) + | Pandil (**r and immediate long *) + | Poril (**r or immediate long *) + | Pxoril (**r xor immediate long *) +. + +Inductive ar_instruction : Type := + | PArithR (i: arith_name_r) (rd: ireg) + | PArithRR (i: arith_name_rr) (rd rs: ireg) + | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) + | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) + | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) + | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) + | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) +. + +Coercion PArithR: arith_name_r >-> Funclass. +Coercion PArithRR: arith_name_rr >-> Funclass. +Coercion PArithRI32: arith_name_ri32 >-> Funclass. +Coercion PArithRI64: arith_name_ri64 >-> Funclass. +Coercion PArithRRR: arith_name_rrr >-> Funclass. +Coercion PArithRRI32: arith_name_rri32 >-> Funclass. +Coercion PArithRRI64: arith_name_rri64 >-> Funclass. + +Inductive basic : Type := + | PArith (i: ar_instruction) + | PLoad (i: ld_instruction) + | PStore (i: st_instruction) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pnop (**r virtual instruction that does nothing *) +. + +Coercion PLoad: ld_instruction >-> basic. +Coercion PStore: st_instruction >-> basic. +Coercion PArith: ar_instruction >-> basic. + + +Inductive control : Type := + | PExpand (i: ex_instruction) + | PCtlFlow (i: cf_instruction) +. + +Coercion PExpand: ex_instruction >-> control. +Coercion PCtlFlow: cf_instruction >-> control. + + +(** * Definition of a bblock *) + +Definition non_empty_bblock (body: list basic) (exit: option control): Prop + := body <> nil \/ exit <> None. + +Definition non_empty_body (body: list basic): bool := + match body with + | nil => false + | _ => true + end. + +Definition non_empty_exit (exit: option control): bool := + match exit with + | None => false + | _ => true + end. + +Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. + +Lemma non_empty_bblock_refl: + forall body exit, + non_empty_bblock body exit -> + Is_true (non_empty_bblockb body exit). +Proof. + intros. destruct body; destruct exit. + all: simpl; auto. + inv H; contradiction. +Qed. + +(* Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, + exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. + *) + +(* Definition wf_bblock (header: list label) (body: list basic) (exit: option control) := + non_empty_bblock body exit (* /\ builtin_alone body exit *). *) + +(** A bblock is well-formed if he contains at least one instruction, + and if there is a builtin then it must be alone in this bblock. *) + +Record bblock := mk_bblock { + header: list label; + body: list basic; + exit: option control; + correct: Is_true (non_empty_bblockb body exit) +}. + +Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)). +(* Local Obligation Tactic := bblock_auto_correct. *) + +Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2. +Proof. + destruct b; simpl; auto. + - destruct p1, p2; auto. + - destruct p1. +Qed. + +Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. +Proof. + destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. + intros; subst. + rewrite (Istrue_proof_irrelevant _ c1 c2). + auto. +Qed. + + +(* FIXME: redundant with definition in Machblock *) +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +(* WARNING: the notion of size is not the same than in Machblock ! + We ignore labels here... + The result is in Z to be compatible with operations on PC +*) +Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). +(* match (body b, exit b) with + | (nil, None) => 1 + | _ => + end. + *) + +Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. +Proof. + intros. destruct l; try (contradict H; auto; fail). + simpl. omega. +Qed. + +Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. +Proof. + intros. destruct z; auto. + - contradict H. simpl. apply gt_irrefl. + - apply Zgt_pos_0. + - contradict H. simpl. apply gt_irrefl. +Qed. + +Lemma size_positive (b:bblock): size b > 0. +Proof. + unfold size. destruct b as [hd bdy ex cor]. simpl. + destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). + inversion cor; contradict H; simpl; auto. +(* rewrite eq. (* inversion COR. *) (* inversion H. *) + - assert ((length b > 0)%nat). apply length_nonil. auto. + omega. + - destruct e; simpl; try omega. contradict H; simpl; auto. + *)Qed. + +Definition bblocks := list bblock. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +Inductive instruction : Type := + | PBasic (i: basic) + | PControl (i: control) +. + +Coercion PBasic: basic >-> instruction. +Coercion PControl: control >-> instruction. + +Definition code := list instruction. +Definition bcode := list basic. + +Fixpoint basics_to_code (l: list basic) := + match l with + | nil => nil + | bi::l => (PBasic bi)::(basics_to_code l) + end. + +Fixpoint code_to_basics (c: code) := + match c with + | (PBasic i)::c => + match code_to_basics c with + | None => None + | Some l => Some (i::l) + end + | _::c => None + | nil => Some nil + end. + +Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. +Proof. + intros. induction c as [|i c]; simpl; auto. + rewrite IHc. auto. +Qed. + +Lemma code_to_basics_dist: + forall c c' l l', + code_to_basics c = Some l -> + code_to_basics c' = Some l' -> + code_to_basics (c ++ c') = Some (l ++ l'). +Proof. + induction c as [|i c]; simpl; auto. + - intros. inv H. simpl. auto. + - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. + inv H. erewrite IHc; eauto. auto. +Qed. + +(** + Asmblockgen will have to translate a Mach control into a list of instructions of the form + i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction + These functions provide way to extract the basic / control instructions +*) + +Fixpoint extract_basic (c: code) := + match c with + | nil => nil + | PBasic i :: c => i :: (extract_basic c) + | PControl i :: c => nil + end. + +Fixpoint extract_ctl (c: code) := + match c with + | nil => None + | PBasic i :: c => extract_ctl c + | PControl i :: nil => Some i + | PControl i :: _ => None (* if the first found control instruction isn't the last *) + end. + +(** * Utility for Asmblockgen *) + +Program Definition bblock_single_inst (i: instruction) := + match i with + | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} + | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} + end. + +Program Definition bblock_basic_ctl (c: list basic) (i: option control) := + match i with + | Some i => {| header:=nil; body:=c; exit:=Some i |} + | None => + match c with + | _::_ => {| header:=nil; body:=c; exit:=None |} + | nil => {| header:=nil; body:=Pnop::nil; exit:=None |} + end + end. +Next Obligation. + bblock_auto_correct. +Qed. Next Obligation. + bblock_auto_correct. +Qed. + + +(** * Operational semantics *) + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain + the convention that integer registers are mapped to values of + type [Tint] or [Tlong] (in 64 bit mode), + and float registers to values of type [Tsingle] or [Tfloat]. *) + +Definition regset := Pregmap.t val. + +Definition genv := Genv.t fundef unit. + +Notation "a # b" := (a b) (at level 1, only parsing) : asm. +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. + +Open Scope asm. + +(** Undefining some registers *) + +Fixpoint undef_regs (l: list preg) (rs: regset) : regset := + match l with + | nil => rs + | r :: l' => undef_regs l' (rs#r <- Vundef) + end. + + +(** Assigning a register pair *) +Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := + match p with + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + end. + +(* TODO: Is it still useful ?? *) + + +(** Assigning multiple registers *) + +(* Fixpoint set_regs (rl: list preg) (vl: list val) (rs: regset) : regset := + match rl, vl with + | r1 :: rl', v1 :: vl' => set_regs rl' vl' (rs#r1 <- v1) + | _, _ => rs + end. + *) +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + +Section RELSEM. + + +(** The semantics is purely small-step and defined as a function + from the current state (a register set + a memory state) + to either [Next rs' m'] where [rs'] and [m'] are the updated register + set and memory state after execution of the instruction at [rs#PC], + or [Stuck] if the processor is stuck. *) + +Inductive outcome {rgset}: Type := + | Next (rs:rgset) (m:mem) + | Stuck. +Arguments outcome: clear implicits. + + +(** ** Arithmetic Expressions (including comparisons) *) + +Inductive signedness: Type := Signed | Unsigned. + +Inductive intsize: Type := Int | Long. + +Definition itest_for_cmp (c: comparison) (s: signedness) := + match c, s with + | Cne, Signed => ITne + | Ceq, Signed => ITeq + | Clt, Signed => ITlt + | Cge, Signed => ITge + | Cle, Signed => ITle + | Cgt, Signed => ITgt + | Cne, Unsigned => ITneu + | Ceq, Unsigned => ITequ + | Clt, Unsigned => ITltu + | Cge, Unsigned => ITgeu + | Cle, Unsigned => ITleu + | Cgt, Unsigned => ITgtu + end. + +(* CoMPare Signed Words to Zero *) +Definition btest_for_cmpswz (c: comparison) := + match c with + | Cne => BTwnez + | Ceq => BTweqz + | Clt => BTwltz + | Cge => BTwgez + | Cle => BTwlez + | Cgt => BTwgtz + end. + +(* CoMPare Signed Doubles to Zero *) +Definition btest_for_cmpsdz (c: comparison) := + match c with + | Cne => BTdnez + | Ceq => BTdeqz + | Clt => BTdltz + | Cge => BTdgez + | Cle => BTdlez + | Cgt => BTdgtz + end. + +Definition cmp_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTwltz => (Some Clt, Int) + | BTwgez => (Some Cge, Int) + | BTwlez => (Some Cle, Int) + | BTwgtz => (Some Cgt, Int) + + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | BTdltz => (Some Clt, Long) + | BTdgez => (Some Cge, Long) + | BTdlez => (Some Cle, Long) + | BTdgtz => (Some Cgt, Long) + end. + +Definition cmpu_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | _ => (None, Int) + end. + +(** Comparing integers *) +Definition compare_int (t: itest) (v1 v2: val) (m: mem): val := + match t with + | ITne => Val.cmp Cne v1 v2 + | ITeq => Val.cmp Ceq v1 v2 + | ITlt => Val.cmp Clt v1 v2 + | ITge => Val.cmp Cge v1 v2 + | ITle => Val.cmp Cle v1 v2 + | ITgt => Val.cmp Cgt v1 v2 + | ITneu => Val.cmpu (Mem.valid_pointer m) Cne v1 v2 + | ITequ => Val.cmpu (Mem.valid_pointer m) Ceq v1 v2 + | ITltu => Val.cmpu (Mem.valid_pointer m) Clt v1 v2 + | ITgeu => Val.cmpu (Mem.valid_pointer m) Cge v1 v2 + | ITleu => Val.cmpu (Mem.valid_pointer m) Cle v1 v2 + | ITgtu => Val.cmpu (Mem.valid_pointer m) Cgt v1 v2 + | ITall + | ITnall + | ITany + | ITnone => Vundef + end. + +Definition compare_long (t: itest) (v1 v2: val) (m: mem): val := + let res := match t with + | ITne => Val.cmpl Cne v1 v2 + | ITeq => Val.cmpl Ceq v1 v2 + | ITlt => Val.cmpl Clt v1 v2 + | ITge => Val.cmpl Cge v1 v2 + | ITle => Val.cmpl Cle v1 v2 + | ITgt => Val.cmpl Cgt v1 v2 + | ITneu => Val.cmplu (Mem.valid_pointer m) Cne v1 v2 + | ITequ => Val.cmplu (Mem.valid_pointer m) Ceq v1 v2 + | ITltu => Val.cmplu (Mem.valid_pointer m) Clt v1 v2 + | ITgeu => Val.cmplu (Mem.valid_pointer m) Cge v1 v2 + | ITleu => Val.cmplu (Mem.valid_pointer m) Cle v1 v2 + | ITgtu => Val.cmplu (Mem.valid_pointer m) Cgt v1 v2 + | ITall + | ITnall + | ITany + | ITnone => Some Vundef + end in + match res with + | Some v => v + | None => Vundef + end + . +(** Execution of arith instructions + +TODO: subsplitting by instruction type ? Could be useful for expressing auxiliary lemma... + +FIXME: replace parameter "m" by a function corresponding to the resul of "(Mem.valid_pointer m)" + +*) + +Variable ge: genv. + + +Definition exec_arith_instr (ai: ar_instruction) (rs: regset) (m: mem) : regset := + match ai with + | PArithR n d => + match n with + | Pcvtw2l => rs#d <- (Val.longofint rs#d) + | Ploadsymbol s ofs => rs#d <- (Genv.symbol_address ge s ofs) + end + + | PArithRR n d s => + match n with + | Pmv => rs#d <- (rs#s) + | Pnegw => rs#d <- (Val.neg rs#s) + | Pnegl => rs#d <- (Val.negl rs#s) + | Pfnegd => rs#d <- (Val.negf rs#s) + | Pcvtl2w => rs#d <- (Val.loword rs#s) + | Pmvw2l => rs#d <- (Val.longofint rs#s) + end + + | PArithRI32 n d i => + match n with + | Pmake => rs#d <- (Vint i) + end + + | PArithRI64 n d i => + match n with + | Pmakel => rs#d <- (Vlong i) + end + + | PArithRRR n d s1 s2 => + match n with + | Pcompw c => rs#d <- (compare_int c rs#s1 rs#s2 m) + | Pcompl c => rs#d <- (compare_long c rs#s1 rs#s2 m) + | Paddw => rs#d <- (Val.add rs#s1 rs#s2) + | Psubw => rs#d <- (Val.sub rs#s1 rs#s2) + | Pmulw => rs#d <- (Val.mul rs#s1 rs#s2) + | Pandw => rs#d <- (Val.and rs#s1 rs#s2) + | Porw => rs#d <- (Val.or rs#s1 rs#s2) + | Pxorw => rs#d <- (Val.xor rs#s1 rs#s2) + | Psrlw => rs#d <- (Val.shru rs#s1 rs#s2) + | Psraw => rs#d <- (Val.shr rs#s1 rs#s2) + | Psllw => rs#d <- (Val.shl rs#s1 rs#s2) + + | Paddl => rs#d <- (Val.addl rs#s1 rs#s2) + | Psubl => rs#d <- (Val.subl rs#s1 rs#s2) + | Pandl => rs#d <- (Val.andl rs#s1 rs#s2) + | Porl => rs#d <- (Val.orl rs#s1 rs#s2) + | Pxorl => rs#d <- (Val.xorl rs#s1 rs#s2) + | Pmull => rs#d <- (Val.mull rs#s1 rs#s2) + | Pslll => rs#d <- (Val.shll rs#s1 rs#s2) + | Psrll => rs#d <- (Val.shrlu rs#s1 rs#s2) + | Psral => rs#d <- (Val.shrl rs#s1 rs#s2) + end + + | PArithRRI32 n d s i => + match n with + | Pcompiw c => rs#d <- (compare_int c rs#s (Vint i) m) + | Paddiw => rs#d <- (Val.add rs#s (Vint i)) + | Pandiw => rs#d <- (Val.and rs#s (Vint i)) + | Poriw => rs#d <- (Val.or rs#s (Vint i)) + | Pxoriw => rs#d <- (Val.xor rs#s (Vint i)) + | Psraiw => rs#d <- (Val.shr rs#s (Vint i)) + | Psrliw => rs#d <- (Val.shru rs#s (Vint i)) + | Pslliw => rs#d <- (Val.shl rs#s (Vint i)) + | Psllil => rs#d <- (Val.shll rs#s (Vint i)) + | Psrlil => rs#d <- (Val.shrlu rs#s (Vint i)) + | Psrail => rs#d <- (Val.shrl rs#s (Vint i)) + end + + | PArithRRI64 n d s i => + match n with + | Pcompil c => rs#d <- (compare_long c rs#s (Vlong i) m) + | Paddil => rs#d <- (Val.addl rs#s (Vlong i)) + | Pandil => rs#d <- (Val.andl rs#s (Vlong i)) + | Poril => rs#d <- (Val.orl rs#s (Vlong i)) + | Pxoril => rs#d <- (Val.xorl rs#s (Vlong i)) + end + end. + +(** * load/store *) + +(** The two functions below axiomatize how the linker processes + symbolic references [symbol + offset)] and splits their + actual values into a 20-bit high part [%hi(symbol + offset)] and + a 12-bit low part [%lo(symbol + offset)]. *) + +Parameter low_half: genv -> ident -> ptrofs -> ptrofs. +Parameter high_half: genv -> ident -> ptrofs -> val. + +(** The fundamental property of these operations is that, when applied + to the address of a symbol, their results can be recombined by + addition, rebuilding the original address. *) + +Axiom low_high_half: + forall id ofs, + Val.offset_ptr (high_half ge id ofs) (low_half ge id ofs) = Genv.symbol_address ge id ofs. + +(** Auxiliaries for memory accesses *) + +Definition eval_offset (ofs: offset) : ptrofs := + match ofs with + | Ofsimm n => n + | Ofslow id delta => low_half ge id delta + end. + +Definition exec_load (chunk: memory_chunk) (rs: regset) (m: mem) + (d: preg) (a: ireg) (ofs: offset) := + match Mem.loadv chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) with + | None => Stuck + | Some v => Next (rs#d <- v) m + end. + +Definition exec_store (chunk: memory_chunk) (rs: regset) (m: mem) + (s: preg) (a: ireg) (ofs: offset) := + match Mem.storev chunk m (Val.offset_ptr (rs a) (eval_offset ofs)) (rs s) with + | None => Stuck + | Some m' => Next rs m' + end. + +(** * basic instructions *) + +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome regset := + match bi with + | PArith ai => Next (exec_arith_instr ai rs m) m + + | PLoadRRO n d a ofs => + match n with + | Plb => exec_load Mint8signed rs m d a ofs + | Plbu => exec_load Mint8unsigned rs m d a ofs + | Plh => exec_load Mint16signed rs m d a ofs + | Plhu => exec_load Mint16unsigned rs m d a ofs + | Plw => exec_load Mint32 rs m d a ofs + | Plw_a => exec_load Many32 rs m d a ofs + | Pld => exec_load Mint64 rs m d a ofs + | Pld_a => exec_load Many64 rs m d a ofs + | Pfls => exec_load Mfloat32 rs m d a ofs + | Pfld => exec_load Mfloat64 rs m d a ofs + end + + | PStoreRRO n s a ofs => + match n with + | Psb => exec_store Mint8unsigned rs m s a ofs + | Psh => exec_store Mint16unsigned rs m s a ofs + | Psw => exec_store Mint32 rs m s a ofs + | Psw_a => exec_store Many32 rs m s a ofs + | Psd => exec_store Mint64 rs m s a ofs + | Psd_a => exec_store Many64 rs m s a ofs + | Pfss => exec_store Mfloat32 rs m s a ofs + | Pfsd => exec_store Mfloat64 rs m s a ofs + end + + | Pallocframe sz pos => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) rs#SP with + | None => Stuck + | Some m2 => Next (rs #FP <- (rs SP) #SP <- sp #GPR31 <- Vundef) m2 + end + + | Pfreeframe sz pos => + match Mem.loadv Mptr m (Val.offset_ptr rs#SP pos) with + | None => Stuck + | Some v => + match rs SP with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => Stuck + | Some m' => Next (rs#SP <- v #GPR31 <- Vundef) m' + end + | _ => Stuck + end + end + | Pget rd ra => + match ra with + | RA => Next (rs#rd <- (rs#ra)) m + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (rs#ra <- (rs#rd)) m + | _ => Stuck + end + | Pnop => Next rs m +end. + +Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome regset := + match body with + | nil => Next rs m + | bi::body' => + match exec_basic_instr bi rs m with + | Next rs' m' => exec_body body' rs' m' + | Stuck => Stuck + end + end. + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextblock]) or branching to a label ([goto_label]). *) + +Definition nextblock (b:bblock) (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC (Ptrofs.repr (size b))). + +(** Looking up bblocks in a code sequence by position. *) +Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := + match lb with + | nil => None + | b :: il => + if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) + else if zeq pos 0 then Some b + else find_bblock (pos - (size b)) il + end. + + +(** Position corresponding to a label *) + +(** TODO: redundant w.r.t Machblock *) +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + + +(** Note: copy-paste from Machblock *) +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +(** convert a label into a position in the code *) +Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := + match lb with + | nil => None + | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' + end. + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome regset := + match label_pos lbl 0 (fn_blocks f) with + | None => Stuck + | Some pos => + match rs#PC with + | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m + | _ => Stuck + end + end. + +(** Evaluating a branch + +Warning: in m PC is assumed to be already pointing on the next instruction ! + +*) +Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome regset := + match res with + | Some true => goto_label f l rs m + | Some false => Next rs m + | None => Stuck + end. + + +(** Execution of a single control-flow instruction [i] in initial state [rs] and + [m]. Return updated state. + + As above: PC is assumed to be incremented on the next block before the control-flow instruction + + For instructions that correspond tobuiltin + actual RISC-V instructions, the cases are straightforward + transliterations of the informal descriptions given in the RISC-V + user-mode specification. For pseudo-instructions, refer to the + informal descriptions given above. + + Note that we set to [Vundef] the registers used as temporaries by + the expansions of the pseudo-instructions, so that the RISC-V code + we generate cannot use those registers to hold values that must + survive the execution of the pseudo-instruction. *) + +Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome regset := + match oc with + | Some ic => +(** Get/Set system registers *) + match ic with + + +(** Branch Control Unit instructions *) + | Pret => + Next (rs#PC <- (rs#RA)) m + | Pcall s => + Next (rs#RA <- (rs#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) m + | Pgoto s => + Next (rs#PC <- (Genv.symbol_address ge s Ptrofs.zero)) m + | Pj_l l => + goto_label f l rs m + | Pcb bt r l => + match cmp_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmp_bool c rs#r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmpl_bool c rs#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + | Pcbu bt r l => + match cmpu_for_btest bt with + | (Some c, Int) => eval_branch f l rs m (Val.cmpu_bool (Mem.valid_pointer m) c rs#r (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch f l rs m (Val.cmplu_bool (Mem.valid_pointer m) c rs#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + + +(** Pseudo-instructions *) + | Pbuiltin ef args res => + Stuck (**r treated specially below *) + end + | None => Next rs m +end. + +Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome regset := + match exec_body (body b) rs0 m with + | Next rs' m' => + let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' + | Stuck => Stuck + end. + +(** Translation of the LTL/Linear/Mach view of machine registers to + the RISC-V view. Note that no LTL register maps to [X31]. This + register is reserved as temporary, to be used by the generated RV32G + code. *) + + (* FIXME - R31 is not there *) +Definition preg_of (r: mreg) : preg := + match r with + | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R9 => GPR9 + | R10 => GPR10 (*| R11 => GPR11 | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R15 => GPR15 | R16 => GPR16 | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 + | R30 => GPR30 | R32 => GPR32 | R33 => GPR33 | R34 => GPR34 + | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 + | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 + | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 + | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 + | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 + | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 + end. + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use RISC-V registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (preg_of r)) + | extcall_arg_stack: forall ofs ty bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv (chunk_of_type ty) m + (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> + extcall_arg rs m (S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). + +(** Execution of the instruction at [rs PC]. *) + +Inductive state: Type := + | State: regset -> mem -> state. + + +(** TODO + * For now, we consider a builtin is alone in a basic block. + * Perhaps there is a way to avoid that ? + *) + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f bi rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> + exec_bblock f bi rs m = Next rs' m' -> + step (State rs m) E0 (State rs' m') + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m' bi, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextblock bi + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#GPR31 <- Vundef))) -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res rs)#PC <- (rs RA) -> + step (State rs m) t (State rs' m') + . + + + +End RELSEM. + +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <- Vnullptr + # RA <- Vnullptr in + Genv.init_mem p = Some m0 -> + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs PC = Vnullptr -> + rs GPR0 = Vint r -> + final_state (State rs m) r. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. + intros; constructor; simpl; intros. +- (* determ *) + inv H; inv H0; Equalities. + + split. constructor. auto. + + unfold exec_bblock in H4. destruct (exec_body _ _ _ _); try discriminate. + rewrite H9 in H4. discriminate. + + unfold exec_bblock in H13. destruct (exec_body _ _ _ _); try discriminate. + rewrite H4 in H13. discriminate. + + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H6. eexact H13. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + inv H; inv H0. f_equal. congruence. +- (* final no step *) + assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. unfold Vzero in H0. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + inv H; inv H0. congruence. +Qed. + +Definition data_preg (r: preg) : bool :=
+ match r with
+ | RA => false
+ | IR GPR31 => false
+ | IR GPR8 => false
+ | IR _ => true
+ | FR _ => true
+ | PC => false
+ end.
+
+(** Determinacy of the [Asm] semantics. *)
+
+(* TODO.
+
+Remark extcall_arguments_determ:
+ forall rs m sg args1 args2,
+ extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2.
+Proof.
+ intros until m.
+ assert (A: forall l v1 v2,
+ extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2).
+ { intros. inv H; inv H0; congruence. }
+ assert (B: forall p v1 v2,
+ extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2).
+ { intros. inv H; inv H0.
+ eapply A; eauto.
+ f_equal; eapply A; eauto. }
+ assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 ->
+ forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2).
+ {
+ induction 1; intros vl2 EA; inv EA.
+ auto.
+ f_equal; eauto. }
+ intros. eapply C; eauto.
+Qed.
+
+Lemma semantics_determinate: forall p, determinate (semantics p).
+Proof.
+Ltac Equalities :=
+ match goal with
+ | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] =>
+ rewrite H1 in H2; inv H2; Equalities
+ | _ => idtac
+ end.
+ intros; constructor; simpl; intros.
+- (* determ *)
+ inv H; inv H0; Equalities.
+ split. constructor. auto.
+ discriminate.
+ discriminate.
+ assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.
+ exploit external_call_determ. eexact H5. eexact H11. intros [A B].
+ split. auto. intros. destruct B; auto. subst. auto.
+ assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0.
+ exploit external_call_determ. eexact H3. eexact H8. intros [A B].
+ split. auto. intros. destruct B; auto. subst. auto.
+- (* trace length *)
+ red; intros. inv H; simpl.
+ omega.
+ eapply external_call_trace_length; eauto.
+ eapply external_call_trace_length; eauto.
+- (* initial states *)
+ inv H; inv H0. f_equal. congruence.
+- (* final no step *)
+ assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs).
+ { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. }
+ inv H. unfold Vzero in H0. red; intros; red; intros.
+ inv H; rewrite H0 in *; eelim NOTNULL; eauto.
+- (* final states *)
+ inv H; inv H0. congruence.
+Qed.
+*)
diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v new file mode 100644 index 00000000..2ac5cc16 --- /dev/null +++ b/mppa_k1c/Asmblockgen.v @@ -0,0 +1,943 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Translation from Machblock to K1c assembly language (Asmblock) *) + +Require Archi. +Require Import Coqlib Errors. +Require Import AST Integers Floats Memdata. +Require Import Op Locations Machblock Asmblock. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +(** The code generation functions take advantage of several + characteristics of the [Mach] code generated by earlier passes of the + compiler, mostly that argument and result registers are of the correct + types. These properties are true by construction, but it's easier to + recheck them during code generation and fail if they do not hold. *) + +(** Extracting integer or float registers. *) + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.ireg_of") end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. + +(* +(** Decomposition of 32-bit integer constants. They are split into either + small signed immediates that fit in 12-bits, or, if they do not fit, + into a (20-bit hi, 12-bit lo) pair where lo is sign-extended. *) + +*) +Inductive immed32 : Type := + | Imm32_single (imm: int). + +Definition make_immed32 (val: int) := Imm32_single val. + +(** Likewise, for 64-bit integer constants. *) +Inductive immed64 : Type := + | Imm64_single (imm: int64) +. + +(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) +Definition make_immed64 (val: int64) := Imm64_single val. + +Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). +Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). +Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). +Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity). + +(** Smart constructors for arithmetic operations involving + a 32-bit or 64-bit integer constant. Depending on whether the + constant fits in 12 bits or not, one or several instructions + are generated as required to perform the operation + and prepended to the given instruction sequence [k]. *) + +Definition loadimm32 (r: ireg) (n: int) := + match make_immed32 n with + | Imm32_single imm => Pmake r imm + end. + +Definition opimm32 (op: arith_name_rrr) + (opimm: arith_name_rri32) + (rd rs: ireg) (n: int) := + match make_immed32 n with + | Imm32_single imm => opimm rd rs imm + 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 loadimm64 (r: ireg) (n: int64) := + match make_immed64 n with + | Imm64_single imm => Pmakel r imm + end. + +Definition opimm64 (op: arith_name_rrr) + (opimm: arith_name_rri64) + (rd rs: ireg) (n: int64) := + match make_immed64 n with + | Imm64_single imm => opimm rd rs imm +end. + +Definition addimm64 := opimm64 Paddl Paddil. +Definition orimm64 := opimm64 Porl Poril. +Definition andimm64 := opimm64 Pandl Pandil. +Definition xorimm64 := opimm64 Pxorl Pxoril. + +(* +Definition sltimm64 := opimm64 Psltl Psltil. +Definition sltuimm64 := opimm64 Psltul Psltiul. +*) + +Definition cast32signed (rd rs: ireg) := + if (ireg_eq rd rs) + then Pcvtw2l rd + else Pmvw2l rd rs + . + +Definition addptrofs (rd rs: ireg) (n: ptrofs) := + if Ptrofs.eq_dec n Ptrofs.zero then + Pmv rd rs + else + addimm64 rd rs (Ptrofs.to_int64 n). + +(** Translation of conditional branches. *) + +Definition transl_comp + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompw (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. + +Definition transl_compl + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. + +Definition select_comp (n: int) (c: comparison) : option comparison := + if Int.eq n Int.zero then + match c with + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compuimm + (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + if Int.eq n Int.zero then + match c with + | Ceq => Pcbu BTweqz r1 lbl ::g k + | Cne => Pcbu BTwnez r1 lbl ::g k + | _ => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) + end + else + loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) + . + +(* Definition transl_opt_compuimm + (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k). *) + +(* match select_comp n c with + | Some Ceq => Pcbu BTweqz r1 lbl ::g k + | Some Cne => Pcbu BTwnez r1 lbl ::g k + | Some _ => nil (* Never happens *) + | None => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) + end + . + *) + +Definition select_compl (n: int64) (c: comparison) : option comparison := + if Int64.eq n Int64.zero then + match c with + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compluimm + (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + if Int64.eq n Int64.zero then + match c with + | Ceq => Pcbu BTdeqz r1 lbl ::g k + | Cne => Pcbu BTdnez r1 lbl ::g k + | _ => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + end + else + loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + . + +(* match select_compl n c with + | Some Ceq => Pcbu BTdeqz r1 lbl ::g k + | Some Cne => Pcbu BTdnez r1 lbl ::g k + | Some _ => nil (* Never happens *) + | None => loadimm64 RTMP n ::g (transl_compl c Unsigned r1 RTMP lbl k) + end + . + *) + +Definition transl_cbranch + (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := + match cond, args with + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_opt_compuimm n c r1 lbl k) + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp c Signed r1 r2 lbl k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp c Unsigned r1 r2 lbl k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + Pcb (btest_for_cmpswz c) r1 lbl ::g k + else + loadimm32 RTMP n ::g (transl_comp c Signed r1 RTMP lbl k) + ) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_opt_compluimm n c r1 lbl k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_compl c Signed r1 r2 lbl k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_compl c Unsigned r1 r2 lbl k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + Pcb (btest_for_cmpsdz c) r1 lbl ::g k + else + loadimm64 RTMP n ::g (transl_compl c Signed r1 RTMP lbl k) + ) +(*| Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) +*)| _, _ => + Error(msg "Asmgenblock.transl_cbranch") + 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 r1 r2: ireg) (k: bcode) := + Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. + +Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. + +Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. + +Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. + +Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := + Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. + +Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := + Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + +Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := + Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. + +Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := + Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) +(*| Ccompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompf c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_float c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + | Ccompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then k else Pxoriw rd rd Int.one :: k) + | Cnotcompfs c, f1 :: f2 :: nil => + do r1 <- freg_of f1; do r2 <- freg_of f2; + let (insn, normal) := transl_cond_single c rd r1 r2 in + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) +*)| _, _ => + Error(msg "Asmgenblock.transl_cond_op") +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: bcode) := + match op, args with + | Omove, a1 :: nil => + match preg_of res, preg_of a1 with + | IR r, IR a => OK (Pmv r a ::i k) + | _ , _ => Error(msg "Asmgenblock.Omove") + end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n ::i k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n ::i k) +(*| Ofloatconst f, nil => + do rd <- freg_of res; + OK (if Float.eq_dec f Float.zero + then Pfcvtdw rd GPR0 :: 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 GPR0 :: 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) + then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs ::i k + else Ploadsymbol s ofs rd ::i k) + | Oaddrstack n, nil => + do rd <- ireg_of res; + OK (addptrofs rd SP n ::i k) + + | Ocast8signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k) + | Ocast16signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i 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 ::i k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm32 rd rs n ::i k) + | Oneg, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pnegw rd rs ::i k) + | Osub, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psubw rd rs1 rs2 ::i k) + | Omul, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulw rd rs1 rs2 ::i k) +(*| Omulhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhw rd rs1 rs2 :: k) + | Omulhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhuw rd rs1 rs2 :: k) + | Odiv, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivw rd rs1 rs2 :: k) + | Odivu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivuw rd rs1 rs2 :: k) + | Omod, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premw rd rs1 rs2 :: k) + | Omodu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premuw rd rs1 rs2 :: k) +*)| Oand, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandw rd rs1 rs2 ::i k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm32 rd rs n ::i 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 ::i k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm32 rd rs n ::i 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 ::i k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs n ::i 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 ::i k) + | Oshlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs n ::i k) + | Oshr, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psraw rd rs1 rs2 ::i k) + | Oshrimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psraiw rd rs n ::i k) + | Oshru, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrlw rd rs1 rs2 ::i k) + | Oshruimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrliw rd rs n ::i 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 ::i k else + Psraiw GPR31 rs (Int.repr 31) ::i + Psrliw GPR31 GPR31 (Int.sub Int.iwordsize n) ::i + Paddw GPR31 rs GPR31 ::i + Psraiw rd GPR31 n ::i k) + + (* [Omakelong], [Ohighlong] should not occur *) + | Olowlong, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pcvtl2w rd rs ::i k) + | Ocast32signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (cast32signed rd rs ::i k) + | Ocast32unsigned, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + assertion (ireg_eq rd rs); + OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i 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 ::i k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm64 rd rs n ::i k) + | Onegl, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pnegl rd rs ::i k) + | Osubl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psubl rd rs1 rs2 ::i k) + | Omull, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmull rd rs1 rs2 ::i k) +(*| Omullhs, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhl rd rs1 rs2 :: k) + | Omullhu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulhul rd rs1 rs2 :: k) + | Odivl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivl rd rs1 rs2 :: k) + | Odivlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pdivul rd rs1 rs2 :: k) + | Omodl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Preml rd rs1 rs2 :: k) + | Omodlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Premul rd rs1 rs2 :: k) +*)| Oandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandl rd rs1 rs2 ::i k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm64 rd rs n ::i 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 ::i k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm64 rd rs n ::i 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 ::i k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs n ::i 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 ::i k) + | Oshllimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psllil rd rs n ::i k) + | Oshrl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psral rd rs1 rs2 ::i k) + | Oshrlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrail rd rs n ::i k) + | Oshrlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrll rd rs1 rs2 ::i k) + | Oshrluimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrlil rd rs n ::i 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 + Psrail GPR31 rs (Int.repr 63) :: + Psrlil GPR31 GPR31 (Int.sub Int64.iwordsize' n) :: + Paddl GPR31 rs GPR31 :: + Psrail rd GPR31 n :: k) + +*)| Onegf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegd rd rs ::i k) +(*| Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsd rd rs :: k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddd rd rs1 rs2 :: k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsubd rd rs1 rs2 :: k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuld rd rs1 rs2 :: k) + | Odivf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdivd rd rs1 rs2 :: k) + + | Onegfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegs rd rs :: k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabss rd rs :: k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfadds rd rs1 rs2 :: k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsubs rd rs1 rs2 :: k) + | Omulfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuls rd rs1 rs2 :: k) + | Odivfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfdivs rd rs1 rs2 :: k) + + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtsd rd rs :: k) + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfcvtds rd rs :: k) + + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwd rd rs :: k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwud rd rs :: k) + | Ofloatofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdw rd rs :: k) + | Ofloatofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdwu rd rs :: k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtws rd rs :: k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtwus rd rs :: k) + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtsw rd rs :: k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtswu rd rs :: k) + + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtld rd rs :: k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtlud rd rs :: k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdl rd rs :: k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtdlu rd rs :: k) + | Olongofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtls rd rs :: k) + | Olonguofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfcvtlus rd rs :: k) + | Osingleoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtsl rd rs :: k) + | Osingleoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfcvtslu rd rs :: k) + +*)| Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k + + | _, _ => + Error(msg "Asmgenblock.transl_op") + end. + +(** Accessing data in the stack frame. *) + +Definition indexed_memory_access + (mk_instr: ireg -> offset -> basic) + (base: ireg) (ofs: ptrofs) := + match make_immed64 (Ptrofs.to_int64 ofs) with + | Imm64_single imm => + mk_instr base (Ofsimm (Ptrofs.of_int64 imm)) +(*| Imm64_pair hi lo => + Pluil GPR31 hi :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm (Ptrofs.of_int64 lo)) :: k + | Imm64_large imm => + Pmake GPR31 imm :: Paddl GPR31 base GPR31 :: mk_instr GPR31 (Ofsimm Ptrofs.zero) :: k +*)end. + +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := + match ty, preg_of dst with + | Tint, IR rd => OK (indexed_memory_access (Plw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (Pld rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfls rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfld rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (Plw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (Pld_a rd) base ofs ::i k) + | _, _ => Error (msg "Asmgenblock.loadind") + end. + +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := + match ty, preg_of src with + | Tint, IR rd => OK (indexed_memory_access (Psw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (Psd rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (Pfss rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (Pfsd rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (Psw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (Psd_a rd) base ofs ::i k) + | _, _ => Error (msg "Asmgenblock.storeind") + end. + +Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := + indexed_memory_access (Pld dst) base ofs. + +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := + indexed_memory_access (Psd src) base ofs. + +(** Translation of memory accesses: loads, and stores. *) + +Definition transl_memory_access + (mk_instr: ireg -> offset -> basic) + (addr: addressing) (args: list mreg) (k: bcode) : res bcode := + match addr, args with + | Aindexed ofs, a1 :: nil => + do rs <- ireg_of a1; + OK (indexed_memory_access mk_instr rs ofs ::i k) + | Aglobal id ofs, nil => + OK (Ploadsymbol id ofs GPR31 ::i (mk_instr GPR31 (Ofsimm Ptrofs.zero) ::i k)) + | Ainstack ofs, nil => + OK (indexed_memory_access mk_instr SP ofs ::i k) + | _, _ => + Error(msg "Asmgenblock.transl_memory_access") + end. + +Definition transl_load (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + match chunk with + | Mint8signed => + do r <- ireg_of dst; + transl_memory_access (Plb r) addr args k + | Mint8unsigned => + do r <- ireg_of dst; + transl_memory_access (Plbu r) addr args k + | Mint16signed => + do r <- ireg_of dst; + transl_memory_access (Plh r) addr args k + | Mint16unsigned => + do r <- ireg_of dst; + transl_memory_access (Plhu r) addr args k + | Mint32 => + do r <- ireg_of dst; + transl_memory_access (Plw r) addr args k + | Mint64 => + do r <- ireg_of dst; + transl_memory_access (Pld r) addr args k + | Mfloat32 => + do r <- freg_of dst; + transl_memory_access (Pfls r) addr args k + | Mfloat64 => + do r <- freg_of dst; + transl_memory_access (Pfld r) addr args k + | _ => + Error (msg "Asmgenblock.transl_load") + end. + +Definition transl_store (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + match chunk with + | Mint8signed | Mint8unsigned => + do r <- ireg_of src; + transl_memory_access (Psb r) addr args k + | Mint16signed | Mint16unsigned => + do r <- ireg_of src; + transl_memory_access (Psh r) addr args k + | Mint32 => + do r <- ireg_of src; + transl_memory_access (Psw r) addr args k + | Mint64 => + do r <- ireg_of src; + transl_memory_access (Psd r) addr args k + | Mfloat32 => + do r <- freg_of src; + transl_memory_access (Pfss r) addr args k + | Mfloat64 => + do r <- freg_of src; + transl_memory_access (Pfsd r) addr args k + | _ => + Error (msg "Asmgenblock.transl_store") + end. + +(** Function epilogue *) + +Definition make_epilogue (f: Machblock.function) (k: code) := + (loadind_ptr SP f.(fn_retaddr_ofs) GPR8) + ::g Pset RA GPR8 ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. + +(** Translation of a Mach instruction. *) + +Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) + (ep: bool) (k: bcode) := + match i with + | MBgetstack ofs ty dst => + loadind SP ofs ty dst k + | MBsetstack src ofs ty => + storeind src SP ofs ty k + | MBgetparam ofs ty dst => + (* load via the frame pointer if it is valid *) + do c <- loadind FP ofs ty dst k; + OK (if ep then c + else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c) + | MBop op args res => + transl_op op args res k + | MBload chunk addr args dst => + transl_load chunk addr args dst k + | MBstore chunk addr args src => + transl_store chunk addr args src k + end. + +Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.control_flow_inst) + : res code := + match oi with + | None => OK nil + | Some i => + match i with +(*| Mcall sig (inl r) => + do r1 <- ireg_of r; OK (Pjal_r r1 sig :: k) +*) | MBcall sig (inr symb) => + OK ((Pcall symb) ::g nil) +(*| Mtailcall sig (inl r) => + do r1 <- ireg_of r; + OK (make_epilogue f (Pcall :: k)) +*) | MBtailcall sig (inr symb) => + OK (make_epilogue f ((Pgoto symb) ::g nil)) + | MBbuiltin ef args res => + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil) +(* | Mlabel lbl => + OK (Plabel lbl ::i k) *) + | MBgoto lbl => + OK (Pj_l lbl ::g nil) + | MBcond cond args lbl => + transl_cbranch cond args lbl nil +(*| Mjumptable arg tbl => do r <- ireg_of arg; OK (Pbtbl r tbl :: k) +*) | MBreturn => + OK (make_epilogue f (Pret ::g nil)) + (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) + | _ => + Error (msg "Asmgenblock.transl_instr") + end + end. + +(* TODO - dans l'idée, transl_instr_control renvoie une liste d'instructions sous la forme : + * transl_instr_control _ _ _ = lb ++ (ctl :: nil), où lb est une liste de basics, ctl est un control_inst + + Il faut arriver à exprimer cet aspect là ; extraire le lb, le rajouter dans le body ; et extraire le ctl + qu'on met dans le exit +*) + +(** Translation of a code sequence *) + +Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := + match i with + | MBsetstack src ofs ty => before + | MBgetparam ofs ty dst => negb (mreg_eq dst R10) + | MBop op args res => before && negb (mreg_eq res R10) + | _ => false + end. + +(** This is the naive definition that we no longer use because it + is not tail-recursive. It is kept as specification. *) + +Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + match il with + | nil => OK nil + | i1 :: il' => + do k <- transl_basic_code f il' (fp_is_parent it1p i1); + transl_instr_basic f i1 it1p k + end. + +(* (** This is an equivalent definition in continuation-passing style + that runs in constant stack space. *) + +Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst) + (it1p: bool) (k: bcode -> res bcode) := + match il with + | nil => k nil + | i1 :: il' => + transl_basic_rec f il' (fp_is_parent it1p i1) + (fun c1 => do c2 <- transl_instr_basic f i1 it1p c1; k c2) + end. + +Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + transl_basic_rec f il it1p (fun c => OK c). *) + +(** Translation of a whole function. Note that we must check + that the generated code contains less than [2^32] instructions, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +(* Local Obligation Tactic := bblock_auto_correct. *) + +(* Program Definition gen_bblock_noctl (hd: list label) (c: list basic) := + match c with + | nil => {| header := hd; body := Pnop::nil; exit := None |} + | i::c => {| header := hd; body := i::c; exit := None |} + end. + *) + +(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) +Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) := + match (extract_ctl ctl) with + | None => + match c with + | nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil + | i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil + end +(* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) + | Some (PExpand (Pbuiltin ef args res)) => + match c with + | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil + | _ => {| header := hd; body := c; exit := None |} + :: {| header := nil; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil + end + | Some (PCtlFlow i) => {| header := hd; body := (c ++ extract_basic ctl); exit := Some (PCtlFlow i) |} :: nil + end +. +Next Obligation. + bblock_auto_correct. intros. constructor. apply not_eq_sym. auto. +Qed. Next Obligation. + bblock_auto_correct. +Qed. + +Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := + do c <- transl_basic_code f fb.(Machblock.body) ep; + do ctl <- transl_instr_control f fb.(Machblock.exit); + OK (gen_bblocks fb.(Machblock.header) c ctl) +. + +Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := + match lmb with + | nil => OK nil + | mb :: lmb => + do lb <- transl_block f mb (if Machblock.header mb then ep else false); + do lb' <- transl_blocks f lmb false; + OK (lb ++ lb') + end +. + +Definition transl_function (f: Machblock.function) := + do lb <- transl_blocks f f.(Machblock.fn_code) true; + OK (mkfunction f.(Machblock.fn_sig) + (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::b + Pget GPR8 RA ::b + storeind_ptr GPR8 SP f.(fn_retaddr_ofs) ::b lb)). + +Fixpoint size_blocks (l: bblocks): Z := + match l with + | nil => 0 + | b :: l => + (size b) + (size_blocks l) + end + . + +Definition transf_function (f: Machblock.function) : res Asmblock.function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + + +Definition transf_fundef (f: Machblock.fundef) : res Asmblock.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Machblock.program) : res Asmblock.program := + transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v new file mode 100644 index 00000000..ee18e5e3 --- /dev/null +++ b/mppa_k1c/Asmblockgenproof.v @@ -0,0 +1,2143 @@ +(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness proof for RISC-V generation: main proof. *)
+
+Require Import Coqlib Errors.
+Require Import Integers Floats AST Linking.
+Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Op Locations Machblock Conventions Asmblock.
+(* Require Import Asmgen Asmgenproof0 Asmgenproof1. *)
+Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1.
+
+Module MB := Machblock.
+Module AB := Asmblock.
+
+Definition match_prog (p: Machblock.program) (tp: Asmblock.program) :=
+ match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
+
+Lemma transf_program_match:
+ forall p tp, transf_program p = OK tp -> match_prog p tp.
+Proof.
+ intros. eapply match_transform_partial_program; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: Machblock.program.
+Variable tprog: Asmblock.program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+
+Lemma functions_translated:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial TRANSF).
+
+Lemma functions_transl:
+ forall fb f tf,
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge fb = Some (Internal tf).
+Proof.
+ intros. exploit functions_translated; eauto. intros [tf' [A B]].
+ monadInv B. rewrite H0 in EQ; inv EQ; auto.
+Qed.
+
+(** * Properties of control flow *)
+
+Lemma transf_function_no_overflow:
+ forall f tf,
+ transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0.
+ omega.
+Qed.
+
+(*
+Lemma exec_straight_exec:
+ forall fb f c ep tf tc c' rs m rs' m',
+ transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
+ exec_straight tge tf tc rs m c' rs' m' ->
+ plus step tge (State rs m) E0 (State rs' m').
+Proof.
+ intros. inv H.
+ eapply exec_straight_steps_1; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+Qed.
+
+Lemma exec_straight_at:
+ forall fb f c ep tf tc c' ep' tc' rs m rs' m',
+ transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
+ transl_code f c' ep' = OK tc' ->
+ exec_straight tge tf tc rs m tc' rs' m' ->
+ transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'.
+Proof.
+ intros. inv H.
+ exploit exec_straight_steps_2; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+ intros [ofs' [PC' CT']].
+ rewrite PC'. constructor; auto.
+Qed.
+ *)
+(** The following lemmas show that the translation from Mach to Asm
+ preserves labels, in the sense that the following diagram commutes:
+<<
+ translation
+ Mach code ------------------------ Asm instr sequence
+ | |
+ | Mach.find_label lbl find_label lbl |
+ | |
+ v v
+ Mach code tail ------------------- Asm instr seq tail
+ translation
+>>
+ The proof demands many boring lemmas showing that Asm constructor
+ functions do not introduce new labels.
+*)
+
+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: arith_name_rrr) (opimm: arith_name_rri32) r1 r2 n k,
+ (forall r1 r2 r3, nolabel (op r1 r2 r3)) ->
+ (forall r1 r2 n, nolabel (opimm r1 r2 n)) ->
+ tail_nolabel k (opimm32 op opimm r1 r2 n k).
+Proof.
+ intros; unfold opimm32. destruct (make_immed32 n); TailNoLabel.
+(*unfold load_hilo32. destruct (Int.eq lo Int.zero); TailNoLabel.*)
+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 cast32signed_label:
+ forall rd rs k, tail_nolabel k (cast32signed rd rs k).
+Proof.
+ intros; unfold cast32signed. destruct (ireg_eq rd rs); TailNoLabel.
+Qed.
+Hint Resolve cast32signed_label: labels.
+
+Remark opimm64_label:
+ forall (op: arith_name_rrr) (opimm: arith_name_rri64) r1 r2 n k,
+ (forall r1 r2 r3, nolabel (op r1 r2 r3)) ->
+ (forall r1 r2 n, nolabel (opimm r1 r2 n)) ->
+ tail_nolabel k (opimm64 op opimm r1 r2 n k).
+Proof.
+ intros; unfold opimm64. destruct (make_immed64 n); TailNoLabel.
+(*unfold load_hilo64. destruct (Int64.eq lo Int64.zero); TailNoLabel.*)
+Qed.
+Hint Resolve opimm64_label: labels.
+
+Remark addptrofs_label:
+ forall r1 r2 n k, tail_nolabel k (addptrofs r1 r2 n k).
+Proof.
+ unfold addptrofs; intros. destruct (Ptrofs.eq_dec n Ptrofs.zero). TailNoLabel.
+ apply opimm64_label; TailNoLabel.
+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.
+(* Ccomp *)
+ - unfold transl_comp; TailNoLabel.
+(* Ccompu *)
+ - unfold transl_comp; TailNoLabel.
+(* Ccompimm *)
+ - destruct (Int.eq n Int.zero); TailNoLabel.
+ unfold loadimm32. destruct (make_immed32 n); TailNoLabel. unfold transl_comp; TailNoLabel.
+(* Ccompuimm *)
+ - unfold transl_opt_compuimm.
+ remember (select_comp n c0) as selcomp; destruct selcomp.
+ + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_comp;
+ destruct (Int.eq n Int.zero); destruct c0; discriminate.
+ + unfold loadimm32;
+ destruct (make_immed32 n); TailNoLabel; unfold transl_comp; TailNoLabel.
+(* Ccompl *)
+ - unfold transl_compl; TailNoLabel.
+(* Ccomplu *)
+ - unfold transl_compl; TailNoLabel.
+(* Ccomplimm *)
+ - destruct (Int64.eq n Int64.zero); TailNoLabel.
+ unfold loadimm64. destruct (make_immed64 n); TailNoLabel. unfold transl_compl; TailNoLabel.
+(* Ccompluimm *)
+ - unfold transl_opt_compluimm.
+ remember (select_compl n c0) as selcomp; destruct selcomp.
+ + destruct c; TailNoLabel; contradict Heqselcomp; unfold select_compl;
+ destruct (Int64.eq n Int64.zero); destruct c0; discriminate.
+ + unfold loadimm64;
+ destruct (make_immed64 n); TailNoLabel; unfold transl_compl; TailNoLabel.
+Qed.
+
+(*
+- 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.
+*)
+
+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.
+- unfold transl_cond_int32s; destruct c0; simpl; TailNoLabel.
+- unfold transl_cond_int32u; destruct c0; simpl; TailNoLabel.
+- unfold transl_condimm_int32s; destruct c0; simpl; TailNoLabel.
+- unfold transl_condimm_int32u; destruct c0; simpl; TailNoLabel.
+- unfold transl_cond_int64s; destruct c0; simpl; TailNoLabel.
+- unfold transl_cond_int64u; destruct c0; simpl; TailNoLabel.
+- unfold transl_condimm_int64s; destruct c0; simpl; TailNoLabel.
+- unfold transl_condimm_int64u; destruct c0; simpl; TailNoLabel.
+Qed.
+
+Remark transl_op_label:
+ forall op args r k c,
+ transl_op op args r k = OK c -> tail_nolabel k c.
+Proof.
+Opaque Int.eq.
+ unfold transl_op; intros; destruct op; TailNoLabel.
+(* Omove *)
+- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel.
+(* Oaddrsymbol *)
+- destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)); TailNoLabel.
+(* Oaddimm32 *)
+- apply opimm32_label; intros; exact I.
+(* Oandimm32 *)
+- apply opimm32_label; intros; exact I.
+(* Oorimm32 *)
+- apply opimm32_label; intros; exact I.
+(* Oxorimm32 *)
+- apply opimm32_label; intros; exact I.
+(* Oshrximm *)
+- destruct (Int.eq n Int.zero); TailNoLabel.
+(* Oaddimm64 *)
+- apply opimm64_label; intros; exact I.
+(* Oandimm64 *)
+- apply opimm64_label; intros; exact I.
+(* Oorimm64 *)
+- apply opimm64_label; intros; exact I.
+(* Oxorimm64 *)
+- apply opimm64_label; intros; exact I.
+(* Ocmp *)
+- eapply transl_cond_op_label; eauto.
+Qed.
+
+(*
+- 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); 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); TailNoLabel.
+- eapply transl_cond_op_label; eauto.
+*)
+*)
+
+(* Remark indexed_memory_access_label:
+ forall (mk_instr: ireg -> offset -> instruction) base ofs k,
+ (forall r o, nolabel (mk_instr r o)) ->
+ tail_nolabel k (indexed_memory_access mk_instr base ofs k).
+Proof.
+ unfold indexed_memory_access; intros.
+ (* destruct Archi.ptr64. *)
+ destruct (make_immed64 (Ptrofs.to_int64 ofs)); TailNoLabel.
+ (* destruct (make_immed32 (Ptrofs.to_int ofs)); TailNoLabel. *)
+Qed. *)
+
+(*
+Remark loadind_label:
+ forall base ofs ty dst k c,
+ loadind base ofs ty dst k = OK c -> tail_nolabel k c.
+Proof.
+ unfold loadind; intros.
+ destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I.
+Qed.
+
+Remark storeind_label:
+ forall src base ofs ty k c,
+ storeind src base ofs ty k = OK c -> tail_nolabel k c.
+Proof.
+ unfold storeind; intros.
+ destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I.
+Qed.
+
+Remark loadind_ptr_label:
+ forall base ofs dst k, tail_nolabel k (loadind_ptr base ofs dst k).
+Proof.
+ intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I.
+Qed.
+*)
+
+(* Remark storeind_ptr_label:
+ forall src base ofs k, tail_nolabel k (storeind_ptr src base ofs k).
+Proof.
+ intros. apply indexed_memory_access_label. intros; destruct Archi.ptr64; exact I.
+Qed. *)
+
+(*
+Remark transl_memory_access_label:
+ forall (mk_instr: ireg -> offset -> instruction) addr args k c,
+ (forall r o, nolabel (mk_instr r o)) ->
+ transl_memory_access mk_instr addr args k = OK c ->
+ tail_nolabel k c.
+Proof.
+ unfold transl_memory_access; intros; destruct addr; TailNoLabel; apply indexed_memory_access_label; auto.
+Qed.
+
+Remark make_epilogue_label:
+ forall f k, tail_nolabel k (make_epilogue f k).
+Proof.
+ unfold make_epilogue; intros. eapply tail_nolabel_trans. apply loadind_ptr_label. TailNoLabel.
+Qed.
+
+Lemma transl_instr_label:
+ forall f i ep k c,
+ transl_instr f i ep k = OK c ->
+ match i with Mlabel lbl => c = Plabel lbl ::i k | _ => tail_nolabel k c end.
+Proof.
+ unfold transl_instr; intros; destruct i; TailNoLabel.
+(* loadind *)
+- eapply loadind_label; eauto.
+(* storeind *)
+- eapply storeind_label; eauto.
+(* Mgetparam *)
+- destruct ep. eapply loadind_label; eauto.
+ eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto.
+(* transl_op *)
+- eapply transl_op_label; eauto.
+(* transl_load *)
+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
+(* transl store *)
+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
+- destruct s0; monadInv H; TailNoLabel.
+- destruct s0; monadInv H; eapply tail_nolabel_trans
+ ; [eapply make_epilogue_label|TailNoLabel].
+- eapply transl_cbranch_label; eauto.
+- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].
+Qed.
+(*
+
+
+- eapply transl_op_label; eauto.
+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
+- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
+- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]).
+- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].
+*)
+
+Lemma transl_instr_label':
+ forall lbl f i ep k c,
+ transl_instr f i ep k = OK c ->
+ find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
+Proof.
+ intros. exploit transl_instr_label; eauto.
+ destruct i; try (intros [A B]; apply B).
+ intros. subst c. simpl. auto.
+Qed.
+*)
+
+Lemma gen_bblocks_label:
+ forall hd bdy ex tbb tc,
+ gen_bblocks hd bdy ex = tbb::tc ->
+ header tbb = hd.
+Proof.
+ intros until tc. intros GENB. unfold gen_bblocks in GENB.
+ destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
+ all: inv GENB; simpl; auto.
+Qed.
+
+Lemma gen_bblocks_label2:
+ forall hd bdy ex tbb1 tbb2,
+ gen_bblocks hd bdy ex = tbb1::tbb2::nil ->
+ header tbb2 = nil.
+Proof.
+ intros until tbb2. intros GENB. unfold gen_bblocks in GENB.
+ destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
+ all: inv GENB; simpl; auto.
+Qed.
+
+Lemma in_dec_transl:
+ forall lbl hd,
+ (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false).
+Proof.
+ intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto.
+Qed.
+
+Lemma transl_is_label:
+ forall lbl bb tbb f ep tc,
+ transl_block f bb ep = OK (tbb::tc) ->
+ is_label lbl tbb = MB.is_label lbl bb.
+Proof.
+ intros until tc. intros TLB.
+ destruct tbb as [thd tbdy tex]; simpl in *.
+ monadInv TLB.
+ unfold is_label. simpl.
+ apply gen_bblocks_label in H0. simpl in H0. subst.
+ rewrite in_dec_transl. auto.
+Qed.
+
+Lemma transl_is_label_false2:
+ forall lbl bb f ep tbb1 tbb2,
+ transl_block f bb ep = OK (tbb1::tbb2::nil) ->
+ is_label lbl tbb2 = false.
+Proof.
+ intros until tbb2. intros TLB.
+ destruct tbb2 as [thd tbdy tex]; simpl in *.
+ monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst.
+ apply is_label_correct_false. simpl. auto.
+Qed.
+
+Lemma transl_is_label2:
+ forall f bb ep tbb1 tbb2 lbl,
+ transl_block f bb ep = OK (tbb1::tbb2::nil) ->
+ is_label lbl tbb1 = MB.is_label lbl bb
+ /\ is_label lbl tbb2 = false.
+Proof.
+ intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto.
+Qed.
+
+Lemma transl_block_nonil:
+ forall f c ep tc,
+ transl_block f c ep = OK tc ->
+ tc <> nil.
+Proof.
+ intros. monadInv H. unfold gen_bblocks.
+ destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i.
+ all: discriminate.
+Qed.
+
+Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc,
+ ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc).
+Proof.
+ intros. intro. monadInv H.
+ unfold gen_bblocks in H0.
+ destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i.
+ all: discriminate.
+Qed.
+
+Lemma find_label_transl_false:
+ forall x f lbl bb ep x',
+ transl_block f bb ep = OK x ->
+ MB.is_label lbl bb = false ->
+ find_label lbl (x++x') = find_label lbl x'.
+Proof.
+ intros until x'. intros TLB MBis; simpl; auto.
+ destruct x as [|x0 x1]; simpl; auto.
+ destruct x1 as [|x1 x2]; simpl; auto.
+ - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto.
+ - destruct x2 as [|x2 x3]; simpl; auto.
+ + erewrite <- transl_is_label in MBis; eauto. rewrite MBis.
+ erewrite transl_is_label_false2; eauto.
+ + apply transl_block_limit in TLB. destruct TLB.
+Qed.
+
+Lemma transl_blocks_label:
+ forall lbl f c tc ep,
+ transl_blocks f c ep = OK tc ->
+ match MB.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc'
+ end.
+Proof.
+ induction c; simpl; intros.
+ inv H. auto.
+ monadInv H.
+ destruct (MB.is_label lbl a) eqn:MBis.
+ - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. }
+ simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis.
+ rewrite ABis.
+ eexists. eexists. split; eauto. simpl transl_blocks.
+ assert (MB.header a <> nil).
+ { apply MB.is_label_correct_true in MBis.
+ destruct (MB.header a). contradiction. discriminate. }
+ destruct (MB.header a); try contradiction.
+ rewrite EQ. simpl. rewrite EQ1. simpl. auto.
+ - apply IHc in EQ1. destruct (MB.find_label lbl c).
+ + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto.
+ erewrite find_label_transl_false; eauto.
+ + erewrite find_label_transl_false; eauto.
+Qed.
+
+Lemma find_label_nil:
+ forall bb lbl c,
+ header bb = nil ->
+ find_label lbl (bb::c) = find_label lbl c.
+Proof.
+ intros. destruct bb as [hd bdy ex]; simpl in *. subst.
+ assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false).
+ { erewrite <- is_label_correct_false. simpl. auto. }
+ rewrite H. auto.
+Qed.
+
+Lemma transl_find_label:
+ forall lbl f tf,
+ transf_function f = OK tf ->
+ match MB.find_label lbl f.(MB.fn_code) with
+ | None => find_label lbl tf.(fn_blocks) = None
+ | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc
+ end.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g.
+ monadInv EQ. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto.
+ eapply transl_blocks_label; eauto.
+Qed.
+
+End TRANSL_LABEL.
+
+(** A valid branch in a piece of Mach code translates to a valid ``go to''
+ transition in the generated Asm code. *)
+
+Lemma find_label_goto_label:
+ forall f tf lbl rs m c' b ofs,
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
+ rs PC = Vptr b ofs ->
+ MB.find_label lbl f.(MB.fn_code) = Some c' ->
+ exists tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
+ /\ forall r, r <> PC -> rs'#r = rs#r.
+Proof.
+ intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
+ intros (tc & A & B).
+ exploit label_pos_code_tail; eauto. instantiate (1 := 0).
+ intros [pos' [P [Q R]]].
+ exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
+ split. unfold goto_label. rewrite P. rewrite H1. auto.
+ split. rewrite Pregmap.gss. constructor; auto.
+ rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
+ intros. apply Pregmap.gso; auto.
+Qed.
+
+(** Existence of return addresses *)
+
+(* NB: the hypothesis in comment on [b] is not needed in the proof !
+*)
+Lemma return_address_exists:
+ forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) ->
+ exists ra, return_address_offset f c ra.
+Proof.
+ intros. eapply Asmblockgenproof0.return_address_exists; eauto.
+
+- intros. monadInv H0.
+ destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl.
+(* rewrite transl_code'_transl_code in EQ0. *)
+ exists x; exists true; split; auto. (* unfold fn_code. *)
+ repeat constructor.
+ - exact transf_function_no_overflow.
+Qed.
+
+(** * Proof of semantic preservation *)
+
+(** Semantic preservation is proved using simulation diagrams
+ of the following form.
+<<
+ st1 --------------- st2
+ | |
+ t| *|t
+ | |
+ v v
+ st1'--------------- st2'
+>>
+ The invariant is the [match_states] predicate below, which includes:
+- The Asm code pointed by the PC register is the translation of
+ the current Mach code sequence.
+- Mach register values and Asm register values agree.
+*)
+
+(*
+Lemma exec_straight_steps:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists rs2,
+ exec_straight tge tf c rs1 m1' k rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ (fp_is_parent ep i = true -> rs2#FP = parent_sp s)) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c ms2 m2) st'.
+Proof.
+ intros. inversion H2. subst. monadInv H7.
+ exploit H3; eauto. intros [rs2 [A [B C]]].
+ exists (State rs2 m2'); split.
+ eapply exec_straight_exec; eauto.
+ econstructor; eauto. eapply exec_straight_at; eauto.
+Qed.
+*)
+
+(*
+Lemma exec_straight_steps_goto:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ fp_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c' ms2 m2) st'.
+Proof.
+ intros. inversion H3. subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+Qed.
+
+Lemma exec_straight_opt_steps_goto:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ fp_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2') ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c' ms2 m2) st'.
+Proof.
+ intros. inversion H3. subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B C]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ inv A.
+- exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ apply plus_one. econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+- exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+Qed. *)
+
+(** We need to show that, in the simulation diagram, we cannot
+ take infinitely many Mach transitions that correspond to zero
+ transitions on the Asm side. Actually, all Mach transitions
+ correspond to at least one Asm transition, except the
+ transition from [Machsem.Returnstate] to [Machsem.State].
+ So, the following integer measure will suffice to rule out
+ the unwanted behaviour. *)
+
+
+Remark preg_of_not_FP: forall r, negb (mreg_eq r R10) = true -> IR FP <> preg_of r.
+Proof.
+ intros. change (IR FP) with (preg_of R10). red; intros.
+ exploit preg_of_injective; eauto. intros; subst r; discriminate.
+Qed.
+
+Inductive match_states: Machblock.state -> Asmblock.state -> Prop :=
+ | match_states_intro:
+ forall s fb sp c ep ms m m' rs f tf tc
+ (STACKS: match_stack ge s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
+ (AG: agree ms sp rs)
+ (DXP: ep = true -> rs#FP = parent_sp s),
+ match_states (Machblock.State s fb sp c ms m)
+ (Asmblock.State rs m')
+ | match_states_call:
+ forall s fb ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = Vptr fb Ptrofs.zero)
+ (ATLR: rs RA = parent_ra s),
+ match_states (Machblock.Callstate s fb ms m)
+ (Asmblock.State rs m')
+ | match_states_return:
+ forall s ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = parent_ra s),
+ match_states (Machblock.Returnstate s ms m)
+ (Asmblock.State rs m').
+
+Record codestate :=
+ Codestate { pstate: state;
+ pheader: list label;
+ pbody1: list basic;
+ pbody2: list basic;
+ pctl: option control;
+ fpok: bool;
+ rem: list AB.bblock;
+ cur: option bblock }.
+
+(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *)
+
+Inductive match_codestate fb: Machblock.state -> codestate -> Prop :=
+ | match_codestate_intro:
+ forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi
+ (STACKS: match_stack ge s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m0)
+ (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc)
+ (TIC: transl_instr_control f (MB.exit bb) = OK tbi)
+ (TBLS: transl_blocks f c false = OK tc)
+(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *)
+ (AG: agree ms sp rs0)
+ (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s)
+ ,
+ match_codestate fb (Machblock.State s fb sp (bb::c) ms m)
+ {| pstate := (Asmblock.State rs0 m0);
+ pheader := (MB.header bb);
+ pbody1 := tbc;
+ pbody2 := (extract_basic tbi);
+ pctl := extract_ctl tbi;
+ fpok := ep;
+ rem := tc;
+ cur := Some tbb
+ |}
+.
+
+Inductive match_asmstate fb: codestate -> Asmblock.state -> Prop :=
+ | match_asmstate_some:
+ forall rs f tf tc m tbb ofs ep tbdy tex lhd
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (TRANSF: transf_function f = OK tf)
+ (PCeq: rs PC = Vptr fb ofs)
+ (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc))
+(* (HDROK: header tbb = lhd) *)
+ ,
+ match_asmstate fb
+ {| pstate := (Asmblock.State rs m);
+ pheader := lhd;
+ pbody1 := tbdy;
+ pbody2 := extract_basic tex;
+ pctl := extract_ctl tex;
+ fpok := ep;
+ rem := tc;
+ cur := Some tbb |}
+ (Asmblock.State rs m)
+.
+
+Ltac exploreInst :=
+ repeat match goal with
+ | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var
+ | [ H : OK _ = OK _ |- _ ] => monadInv H
+ | [ |- context[if ?b then _ else _] ] => destruct b
+ | [ |- context[match ?m with | _ => _ end] ] => destruct m
+ | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m
+ | [ H : bind _ _ = OK _ |- _ ] => monadInv H
+ | [ H : Error _ = OK _ |- _ ] => inversion H
+ end.
+
+Lemma transl_blocks_nonil:
+ forall f bb c tc ep,
+ transl_blocks f (bb::c) ep = OK tc ->
+ exists tbb tc', tc = tbb :: tc'.
+Proof.
+ intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks.
+ destruct (extract_ctl x2).
+ - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto.
+ - destruct x1; simpl; eauto.
+Qed.
+
+Lemma no_builtin_preserved:
+ forall f ex x2,
+ (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
+ transl_instr_control f ex = OK x2 ->
+ (exists i, extract_ctl x2 = Some (PCtlFlow i))
+ \/ extract_ctl x2 = None.
+Proof.
+ intros until x2. intros Hbuiltin TIC.
+ destruct ex.
+ - destruct c.
+ + simpl in TIC. exploreInst; simpl; eauto.
+ + simpl in TIC. exploreInst; simpl; eauto.
+ + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)).
+ apply Hbuiltin. contradict H; auto.
+ + simpl in TIC. exploreInst; simpl; eauto.
+ + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto.
+ * unfold transl_opt_compuimm. exploreInst; simpl; eauto.
+ * unfold transl_opt_compluimm. exploreInst; simpl; eauto.
+ + simpl in TIC. inv TIC.
+ + simpl in TIC. monadInv TIC. simpl. eauto.
+ - monadInv TIC. simpl; auto.
+Qed.
+
+Lemma transl_blocks_distrib:
+ forall c f bb tbb tc ep,
+ transl_blocks f (bb::c) ep = OK (tbb::tc)
+ -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res))
+ -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil)
+ /\ transl_blocks f c false = OK tc.
+Proof.
+ intros until ep. intros TLBS Hbuiltin.
+ destruct bb as [hd bdy ex].
+ monadInv TLBS. monadInv EQ.
+ exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl.
+ - destruct H as [i Hectl].
+ unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0.
+ simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
+ unfold gen_bblocks. rewrite Hectl. auto.
+ - unfold gen_bblocks in H0. rewrite H in H0.
+ destruct x1 as [|bi x1].
+ + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
+ unfold gen_bblocks. rewrite H. auto.
+ + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
+ unfold gen_bblocks. rewrite H. auto.
+Qed.
+
+Lemma gen_bblocks_nobuiltin:
+ forall thd tbdy tex tbb,
+ (tbdy <> nil \/ extract_ctl tex <> None) ->
+ (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) ->
+ gen_bblocks thd tbdy tex = tbb :: nil ->
+ header tbb = thd
+ /\ body tbb = tbdy ++ extract_basic tex
+ /\ exit tbb = extract_ctl tex.
+Proof.
+ intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB.
+ destruct (extract_ctl tex) eqn:ECTL.
+ - destruct c.
+ + destruct i. assert False. eapply Hnobuiltin. eauto. destruct H.
+ + inv GENB. simpl. auto.
+ - inversion Hnonil.
+ + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto.
+ + contradict H; simpl; auto.
+Qed.
+
+Lemma transl_instr_basic_nonil:
+ forall k f bi ep x,
+ transl_instr_basic f bi ep k = OK x ->
+ x <> nil.
+Proof.
+ intros until x. intros TIB.
+ destruct bi.
+ - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate.
+ - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate.
+ - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate.
+ - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate.
+ unfold transl_cond_op in EQ0. exploreInst; try discriminate.
+ - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate.
+ all: unfold transl_memory_access in EQ0; exploreInst; try discriminate.
+ - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate.
+ all: unfold transl_memory_access in EQ0; exploreInst; try discriminate.
+Qed.
+
+Lemma transl_basic_code_nonil:
+ forall bdy f x ep,
+ bdy <> nil ->
+ transl_basic_code f bdy ep = OK x ->
+ x <> nil.
+Proof.
+ induction bdy as [|bi bdy].
+ intros. contradict H0; auto.
+ destruct bdy as [|bi2 bdy].
+ - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto.
+ - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'.
+ monadInv TBC.
+ assert (x0 <> nil).
+ eapply IHbdy; eauto. subst bdy'. discriminate.
+ eapply transl_instr_basic_nonil; eauto.
+Qed.
+
+Lemma transl_instr_control_nonil:
+ forall ex f x,
+ ex <> None ->
+ transl_instr_control f ex = OK x ->
+ extract_ctl x <> None.
+Proof.
+ intros ex f x Hnonil TIC.
+ destruct ex as [ex|].
+ - clear Hnonil. destruct ex.
+ all: try (simpl in TIC; exploreInst; discriminate).
+ + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate.
+ * unfold transl_opt_compuimm. exploreInst; try discriminate.
+ * unfold transl_opt_compluimm. exploreInst; try discriminate.
+ - contradict Hnonil; auto.
+Qed.
+
+Lemma transl_instr_control_nobuiltin:
+ forall f ex x,
+ (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
+ transl_instr_control f ex = OK x ->
+ (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))).
+Proof.
+ intros until x. intros Hnobuiltin TIC. intros until res.
+ unfold transl_instr_control in TIC. exploreInst.
+ all: try discriminate.
+ - assert False. eapply Hnobuiltin; eauto. destruct H.
+ - unfold transl_cbranch in TIC. exploreInst.
+ all: try discriminate.
+ + unfold transl_opt_compuimm. exploreInst. all: try discriminate.
+ + unfold transl_opt_compluimm. exploreInst. all: try discriminate.
+Qed.
+
+Theorem match_state_codestate:
+ forall mbs abs s fb sp bb c ms m,
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ (MB.body bb <> nil \/ MB.exit bb <> None) ->
+ mbs = (Machblock.State s fb sp (bb::c) ms m) ->
+ match_states mbs abs ->
+ exists cs fb f tbb tc ep,
+ match_codestate fb mbs cs /\ match_asmstate fb cs abs
+ /\ Genv.find_funct_ptr ge fb = Some (Internal f)
+ /\ transl_blocks f (bb::c) ep = OK (tbb::tc)
+ /\ body tbb = pbody1 cs ++ pbody2 cs
+ /\ exit tbb = pctl cs
+ /\ cur cs = Some tbb /\ rem cs = tc
+ /\ pstate cs = abs.
+Proof.
+ intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS.
+ inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst.
+ exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2.
+ monadInv TLB. exploit gen_bblocks_nobuiltin; eauto.
+ { inversion Hnotempty.
+ - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail).
+ left. eapply transl_basic_code_nonil; eauto.
+ - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail).
+ right. eapply transl_instr_control_nonil; eauto. }
+ eapply transl_instr_control_nobuiltin; eauto.
+ intros (Hth & Htbdy & Htexit).
+ exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0;
+ pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep.
+ repeat split. 1-2: econstructor; eauto.
+ { destruct (MB.header bb). eauto. discriminate. } eauto.
+ unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl.
+ rewrite TLBS. simpl. rewrite H2.
+ all: simpl; auto.
+Qed.
+
+Definition mb_remove_body (bb: MB.bblock) :=
+ {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}.
+
+Lemma exec_straight_pnil:
+ forall c rs1 m1 rs2 m2,
+ exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 ->
+ exec_straight tge c rs1 m1 nil rs2 m2.
+Proof.
+ intros. eapply exec_straight_trans. eapply H. econstructor; eauto.
+Qed.
+
+Lemma transl_block_nobuiltin:
+ forall f bb ep tbb,
+ (MB.body bb <> nil \/ MB.exit bb <> None) ->
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ transl_block f bb ep = OK (tbb :: nil) ->
+ exists c c',
+ transl_basic_code f (MB.body bb) ep = OK c
+ /\ transl_instr_control f (MB.exit bb) = OK c'
+ /\ body tbb = c ++ extract_basic c'
+ /\ exit tbb = extract_ctl c'.
+Proof.
+ intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil.
+ - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
+ left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
+ - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
+ right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
+Qed.
+
+Lemma nextblock_preserves:
+ forall rs rs' bb r,
+ rs' = nextblock bb rs ->
+ data_preg r = true ->
+ rs r = rs' r.
+Proof.
+ intros. destruct r; try discriminate.
+ - subst. Simpl.
+ - subst. Simpl.
+Qed.
+
+Lemma cons3_app {A: Type}:
+ forall a b c (l: list A),
+ a :: b :: c :: l = (a :: b :: c :: nil) ++ l.
+Proof.
+ intros. simpl. auto.
+Qed.
+
+Lemma exec_straight_opt_body2:
+ forall c rs1 m1 c' rs2 m2,
+ exec_straight_opt tge c rs1 m1 c' rs2 m2 ->
+ exists body,
+ exec_body tge body rs1 m1 = Next rs2 m2
+ /\ (basics_to_code body) ++g c' = c.
+Proof.
+ intros until m2. intros EXES.
+ inv EXES.
+ - exists nil. split; auto.
+ - eapply exec_straight_body2. auto.
+Qed.
+
+Lemma extract_basics_to_code:
+ forall lb c,
+ extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c.
+Proof.
+ induction lb; intros; simpl; congruence.
+Qed.
+
+Lemma extract_ctl_basics_to_code:
+ forall lb c,
+ extract_ctl (basics_to_code lb ++ c) = extract_ctl c.
+Proof.
+ induction lb; intros; simpl; congruence.
+Qed.
+
+(* Lemma goto_label_inv:
+ forall fn tbb l rs m b ofs,
+ rs PC = Vptr b ofs ->
+ goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m.
+Proof.
+ intros.
+ unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H.
+ exploreInst; auto.
+ unfold nextblock. rewrite Pregmap.gss.
+
+Qed.
+
+
+Lemma exec_control_goto_label_inv:
+ exec_control tge fn (Some ctl) rs m = goto_label fn l rs m ->
+ exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m.
+Proof.
+Qed. *)
+
+Theorem step_simu_control:
+ forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2,
+ MB.body bb' = nil ->
+ (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) ->
+ Genv.find_funct_ptr tge fb = Some (Internal fn) ->
+ pstate cs2 = (Asmblock.State rs2 m2) ->
+ pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex ->
+ cur cs2 = Some tbb ->
+ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 ->
+ match_asmstate fb cs2 (Asmblock.State rs1 m1) ->
+ exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' ->
+ (exists rs3 m3 rs4 m4,
+ exec_body tge tbdy2 rs2 m2 = Next rs3 m3
+ /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4
+ /\ match_states S'' (State rs4 m4)).
+Proof.
+ intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP.
+ inv ESTEP.
+ - inv MCS. inv MAS. simpl in *.
+ inv Hcur. inv Hpstate.
+ destruct ctl.
+ + (* MBcall *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ destruct s1 as [rf|fid]; simpl in H7.
+ * (* Indirect call *) inv H1.
+ * (* Direct call *)
+ monadInv H1.
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
+ remember (Ptrofs.add _ _) as ofs'.
+ assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
+ econstructor; eauto.
+ assert (f1 = f) by congruence. subst f1.
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+ repeat eexists.
+ rewrite H6. econstructor; eauto.
+ rewrite H7. econstructor; eauto.
+ econstructor; eauto.
+ econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
+ Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto.
+ Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto.
+ + (* MBtailcall *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]].
+ destruct s1 as [rf|fid]; simpl in H13.
+ * inv H1.
+ * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_body; eauto.
+ simpl. eauto.
+ intros EXEB.
+ repeat eexists.
+ rewrite H6. simpl extract_basic. eauto.
+ rewrite H7. simpl extract_ctl. simpl. reflexivity.
+ econstructor; eauto.
+ { apply agree_set_other.
+ - econstructor; auto with asmgen.
+ + apply V.
+ + intro r. destruct r; apply V; auto.
+ - eauto with asmgen. }
+ { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. }
+ + (* MBbuiltin (contradiction) *)
+ assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin).
+ rewrite <- H in H1. contradict H1; auto.
+ + (* MBgoto *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11.
+ remember (nextblock tbb rs2) as rs2'.
+ (* inv AT. monadInv H4. *)
+ exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'.
+ assert (tf = fn) by congruence. subst tf.
+ exploit find_label_goto_label.
+ eauto. eauto.
+ instantiate (2 := rs2').
+ { subst. unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. }
+ eauto.
+ intros (tc' & rs' & GOTO & AT2 & INV).
+
+ eexists. eexists. repeat eexists. repeat split.
+ rewrite H6. simpl extract_basic. simpl. eauto.
+ rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto.
+ econstructor; eauto.
+ rewrite Heqrs2' in INV. unfold nextblock in INV.
+ eapply agree_exten; eauto with asmgen.
+ assert (forall r : preg, r <> PC -> rs' r = rs2 r).
+ { intros. destruct r.
+ - destruct g. all: rewrite INV; Simpl; auto.
+ - destruct g. all: rewrite INV; Simpl; auto.
+ - rewrite INV; Simpl; auto.
+ - contradiction. }
+ eauto with asmgen.
+ congruence.
+ + (* MBcond *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ * (* MBcond true *)
+ assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef.
+ eapply preg_vals; eauto.
+ all: eauto.
+ intros EC.
+ exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C).
+ exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
+ assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
+ rewrite PCeq' in PCeq.
+ assert (f1 = f) by congruence. subst f1.
+ exploit find_label_goto_label.
+ 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc.
+ unfold Val.offset_ptr. rewrite PCeq. eauto.
+ intros (tc' & rs3 & GOTOL & TLPC & Hrs3).
+ exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
+ assert (tf = fn) by congruence. subst tf.
+
+ repeat eexists.
+ rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
+ rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
+
+ econstructor; eauto.
+ eapply agree_exten with rs2; eauto with asmgen.
+ { intros. destruct r; try destruct g; try discriminate.
+ all: rewrite Hrs3; try discriminate; unfold nextblock; Simpl. }
+ intros. discriminate.
+
+ * (* MBcond false *)
+ assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef.
+ eapply preg_vals; eauto.
+ all: eauto.
+ intros EC.
+
+ exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C).
+ exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
+ assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
+ rewrite PCeq' in PCeq.
+ exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
+ assert (tf = fn) by congruence. subst tf.
+
+ assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
+
+ repeat eexists.
+ rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
+ rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
+
+ econstructor; eauto.
+ unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto.
+ eapply agree_exten with rs2; eauto with asmgen.
+ { intros. destruct r; try destruct g; try discriminate.
+ all: rewrite <- C; try discriminate; unfold nextblock; Simpl. }
+ intros. discriminate.
+ + (* MBjumptable *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC.
+ + (* MBreturn *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_body; eauto.
+ simpl. eauto.
+ intros EXEB.
+ assert (f1 = f) by congruence. subst f1.
+
+ repeat eexists.
+ rewrite H6. simpl extract_basic. eauto.
+ rewrite H7. simpl extract_ctl. simpl. reflexivity.
+ econstructor; eauto.
+ unfold nextblock. repeat apply agree_set_other; auto with asmgen.
+
+ - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur.
+(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *)
+ intros (TLB & TLBS).
+ *) destruct bb' as [hd' bdy' ex']; simpl in *. subst.
+(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *)
+ monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6.
+ simpl. repeat eexists.
+ econstructor. 4: instantiate (3 := false). all:eauto.
+ unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite PCeq.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ assert (f = f0) by congruence. subst f0. econstructor; eauto.
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto.
+ eapply agree_exten; eauto. intros. Simpl.
+ discriminate.
+Qed.
+
+Definition mb_remove_first (bb: MB.bblock) :=
+ {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}.
+
+Lemma exec_straight_body:
+ forall c c' lc rs1 m1 rs2 m2,
+ exec_straight tge c rs1 m1 c' rs2 m2 ->
+ code_to_basics c = Some lc ->
+ exists l ll,
+ c = l ++ c'
+ /\ code_to_basics l = Some ll
+ /\ exec_body tge ll rs1 m1 = Next rs2 m2.
+Proof.
+ induction c; try (intros; inv H; fail).
+ intros until m2. intros EXES CTB. inv EXES.
+ - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto.
+ - inv CTB. destruct (code_to_basics c); try discriminate. inv H0.
+ eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst.
+ exists (i ::g l'),(i::ll). repeat (split; simpl; auto).
+ rewrite CTB. auto.
+ rewrite H1. auto.
+Qed.
+
+Lemma basics_to_code_app:
+ forall c l x ll,
+ basics_to_code c = l ++ basics_to_code x ->
+ code_to_basics l = Some ll ->
+ c = ll ++ x.
+Proof.
+ intros. apply (f_equal code_to_basics) in H.
+ erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id.
+ rewrite code_to_basics_id in H. inv H. auto.
+Qed.
+
+Lemma basics_to_code_app2:
+ forall i c l x ll,
+ (PBasic i) :: basics_to_code c = l ++ basics_to_code x ->
+ code_to_basics l = Some ll ->
+ i :: c = ll ++ x.
+Proof.
+ intros until ll. intros.
+ exploit basics_to_code_app. instantiate (3 := (i::c)). simpl.
+ all: eauto.
+Qed.
+
+Lemma step_simu_basic:
+ forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy,
+ MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} ->
+ basic_step ge s fb sp ms m bi ms' m' ->
+ pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy ->
+ match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
+ (exists rs2 m2 l cs2 tbdy',
+ cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1;
+ pctl := pctl cs1; fpok := fp_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur cs1 |}
+ /\ tbdy = l ++ tbdy'
+ /\ exec_body tge l rs1 m1 = Next rs2 m2
+ /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2).
+Proof.
+ intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS.
+ simpl in *. inv Hpstate.
+ rewrite Hbody in TBC. monadInv TBC.
+ inv BSTEP.
+ - (* MBgetstack *)
+ simpl in EQ0.
+ unfold Mach.load_stack in H.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+ rewrite (sp_val _ _ _ AG) in A.
+ exploit loadind_correct; eauto with asmgen.
+ intros (rs2 & EXECS & Hrs'1 & Hrs'2).
+ eapply exec_straight_body in EXECS.
+ 2: eapply code_to_basics_id; eauto.
+ destruct EXECS as (l & Hlbi & BTC & CTB & EXECB).
+ exists rs2, m1, Hlbi.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
+ rewrite <- Hheadereq. *) subst.
+
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ. (* { destruct (MB.header bb); auto. } *)
+ eapply agree_set_mreg; eauto with asmgen.
+ intro Hep. simpl in Hep. inv Hep.
+ - (* MBsetstack *)
+ simpl in EQ0.
+ unfold Mach.store_stack in H.
+ assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. }
+ exploit Mem.storev_extends; eauto. intros [m2' [A B]].
+ exploit storeind_correct; eauto with asmgen.
+ rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs', m2', ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ rewrite <- Hheadereq. *) subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
+
+ eapply agree_undef_regs; eauto with asmgen.
+ simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto.
+ - (* MBgetparam *)
+ simpl in EQ0.
+
+ assert (f0 = f) by congruence; subst f0.
+ unfold Mach.load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto.
+ intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto.
+ intros [v' [C D]].
+
+ (* Opaque loadind. *)
+(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *)
+ monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP.
+ destruct ep eqn:EPeq.
+ (* GPR31 contains parent *)
+ + exploit loadind_correct. eexact EQ1.
+ instantiate (2 := rs1). rewrite DXP; eauto. congruence.
+ intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & BTC & CTB & EXECB).
+ exists rs2, m1, ll. eexists.
+ eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ { eapply basics_to_code_app; eauto. }
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
+ (* rewrite <- Hheadereq. *)subst.
+ eapply match_codestate_intro; eauto.
+
+ eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
+ simpl; intros. rewrite R; auto with asmgen.
+ apply preg_of_not_FP; auto.
+
+ (* GPR11 does not contain parent *)
+ + rewrite chunk_of_Tptr in A.
+ exploit loadind_ptr_correct. eexact A. congruence. intros [rs2 [P [Q R]]].
+ exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. congruence.
+ intros [rs3 [S [T U]]].
+
+ exploit exec_straight_trans.
+ eapply P.
+ eapply S.
+ intros EXES.
+
+ eapply exec_straight_body in EXES.
+ 2: simpl. 2: erewrite code_to_basics_id; eauto.
+ destruct EXES as (l & ll & BTC & CTB & EXECB).
+ exists rs3, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app2; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ subst.
+ eapply match_codestate_intro; eauto.
+ eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
+ instantiate (1 := rs2#FP <- (rs3#FP)). intros.
+ rewrite Pregmap.gso; auto with asmgen.
+ congruence.
+ intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen.
+ simpl; intros. rewrite U; auto with asmgen.
+ apply preg_of_not_FP; auto.
+ - (* MBop *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_operation tge sp op (map ms args) m' = Some v).
+ rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exploit eval_operation_lessdef.
+ eapply preg_vals; eauto.
+ 2: eexact H0.
+ all: eauto.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ rewrite <- Hheadereq. *) subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
+ apply agree_set_undef_mreg with rs1; auto.
+ apply Val.lessdef_trans with v'; auto.
+ simpl; intros. destruct (andb_prop _ _ H1); clear H1.
+ rewrite R; auto. apply preg_of_not_FP; auto.
+Local Transparent destroyed_by_op.
+ destruct op; simpl; auto; congruence.
+ - (* MBload *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_addressing tge sp addr (map ms args) = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ exploit transl_load_correct; eauto.
+ intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ rewrite <- Hheadereq. *) subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ.
+
+ eapply agree_set_undef_mreg; eauto. intros; auto with asmgen.
+ simpl; congruence.
+
+ - (* MBstore *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_addressing tge sp addr (map ms args) = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ exploit transl_store_correct; eauto. intros [rs2 [P Q]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m2', ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ.
+
+ eapply agree_undef_regs; eauto with asmgen.
+ simpl; congruence.
+Qed.
+
+Lemma exec_body_trans:
+ forall l l' rs0 m0 rs1 m1 rs2 m2,
+ exec_body tge l rs0 m0 = Next rs1 m1 ->
+ exec_body tge l' rs1 m1 = Next rs2 m2 ->
+ exec_body tge (l++l') rs0 m0 = Next rs2 m2.
+Proof.
+ induction l.
+ - simpl. congruence.
+ - intros until m2. intros EXEB1 EXEB2.
+ inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate.
+ simpl. rewrite EBI. eapply IHl; eauto.
+Qed.
+
+Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}.
+
+Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}.
+Next Obligation.
+ destruct tbb. simpl. auto.
+Qed.
+
+Inductive exec_header: codestate -> codestate -> Prop :=
+ | exec_header_cons: forall cs1,
+ exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1;
+ pctl := pctl cs1; fpok := (if pheader cs1 then fpok cs1 else false); rem := rem cs1;
+ (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *)
+ cur := cur cs1 |}.
+
+Lemma step_simu_header:
+ forall bb s fb sp c ms m rs1 m1 cs1,
+(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *)
+ pstate cs1 = (State rs1 m1) ->
+ match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
+ (exists cs1',
+ exec_header cs1 cs1'
+ /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1').
+Proof.
+ intros until cs1. intros Hpstate MCS.
+ eexists. split; eauto.
+ econstructor; eauto.
+ inv MCS. simpl in *. inv Hpstate.
+ econstructor; eauto.
+Qed.
+
+Lemma step_matchasm_header:
+ forall fb cs1 cs1' s1,
+ match_asmstate fb cs1 s1 ->
+ exec_header cs1 cs1' ->
+ match_asmstate fb cs1' s1.
+Proof.
+ intros until s1. intros MAS EXH.
+ inv MAS. inv EXH.
+ simpl. econstructor; eauto.
+Qed.
+
+Lemma step_simu_body:
+ forall bb s fb sp c ms m rs1 m1 ms' cs1 m',
+ MB.header bb = nil ->
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ body_step ge s fb sp (MB.body bb) ms m ms' m' ->
+ pstate cs1 = (State rs1 m1) ->
+ match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
+ (exists rs2 m2 cs2 ep,
+ cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1;
+ pctl := pctl cs1; fpok := ep; rem := rem cs1; cur := cur cs1 |}
+ /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2
+ /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2).
+Proof.
+ intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy].
+ - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS.
+ inv BSTEP.
+ exists rs1, m1, cs1, (fpok cs1).
+ inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto).
+ econstructor; eauto.
+ - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP.
+ rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'.
+ exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto.
+ intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS').
+ simpl in *.
+ exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto.
+ intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS'').
+ exists rs3, m3, cs3, ep.
+ repeat (split; simpl; auto). subst. simpl in *. auto.
+ rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto.
+Qed.
+
+(* Lemma exec_body_straight:
+ forall l rs0 m0 rs1 m1,
+ l <> nil ->
+ exec_body tge l rs0 m0 = Next rs1 m1 ->
+ exec_straight tge l rs0 m0 nil rs1 m1.
+Proof.
+ induction l as [|i1 l].
+ intros. contradict H; auto.
+ destruct l as [|i2 l].
+ - intros until m1. intros _ EXEB. simpl in EXEB.
+ destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
+ inv EXEB. econstructor; eauto.
+ - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl.
+ destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate.
+ econstructor; eauto. eapply IHl; eauto. discriminate.
+Qed. *)
+
+Lemma exec_body_pc:
+ forall l rs1 m1 rs2 m2,
+ exec_body tge l rs1 m1 = Next rs2 m2 ->
+ rs2 PC = rs1 PC.
+Proof.
+ induction l.
+ - intros. inv H. auto.
+ - intros until m2. intro EXEB.
+ inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
+ eapply IHl in H0. rewrite H0.
+ erewrite exec_basic_instr_pc; eauto.
+Qed.
+
+Lemma exec_body_control:
+ forall b rs1 m1 rs2 m2 rs3 m3 fn,
+ exec_body tge (body b) rs1 m1 = Next rs2 m2 ->
+ exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 ->
+ exec_bblock_rel tge fn b rs1 m1 rs3 m3.
+Proof.
+ intros until fn. intros EXEB EXECTL.
+ econstructor; eauto. inv EXECTL.
+ unfold exec_bblock. rewrite EXEB. auto.
+Qed.
+
+Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat.
+
+Lemma mbsize_eqz:
+ forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None.
+Proof.
+ intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H.
+ remember (length _) as a. remember (length_opt _) as b.
+ assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H.
+ inv H0. inv H1. destruct bdy; destruct ex; auto.
+ all: try discriminate.
+Qed.
+
+Lemma mbsize_neqz:
+ forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None).
+Proof.
+ intros. destruct bb as [hd bdy ex]; simpl in *.
+ destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate).
+ contradict H. unfold mbsize. simpl. auto.
+Qed.
+
+(* Alternative form of step_simulation_bblock, easier to prove *)
+Lemma step_simulation_bblock':
+ forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1,
+ bb' = mb_remove_header bb ->
+ body_step ge sf f sp (Machblock.body bb') rs m rs' m' ->
+ bb'' = mb_remove_body bb' ->
+ (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) ->
+ exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' ->
+ match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
+ exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2.
+Proof.
+ intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS.
+ destruct (mbsize bb) eqn:SIZE.
+ - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit).
+ destruct bb as [hd bdy ex]; simpl in *; subst.
+ inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc.
+ monadInv H2. simpl in *. inv ESTEP. inv BSTEP.
+ eexists. split. eapply plus_one.
+ exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'.
+ assert (x = tf) by congruence. subst x.
+ eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto.
+ unfold exec_bblock. simpl. eauto.
+ econstructor. eauto. eauto. eauto.
+ unfold nextblock. Simpl. unfold Val.offset_ptr. rewrite <- H.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ econstructor; eauto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto.
+ eapply agree_exten; eauto. intros. Simpl.
+ intros. discriminate.
+ - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. }
+ intros Hnotempty.
+
+ (* initial setting *)
+ exploit match_state_codestate.
+ 2: eapply Hnotempty.
+ all: eauto.
+ intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate).
+
+ (* step_simu_header part *)
+ assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. }
+ destruct H as (rs1 & m1 & Hpstate2). subst.
+ assert (f = fb). { inv MCS. auto. } subst fb.
+ exploit step_simu_header.
+ 2: eapply MCS.
+ all: eauto.
+ intros (cs1' & EXEH & MCS2).
+
+ (* step_simu_body part *)
+(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. }
+ rewrite H in BSTEP. clear H. *)
+ assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. }
+ exploit step_simu_body.
+ 3: eapply BSTEP.
+ 4: eapply MCS2.
+ all: eauto. rewrite Hpstate'. eauto.
+ intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS').
+
+ (* step_simu_control part *)
+ assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)).
+ { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. }
+ destruct H as (tf & FIND').
+ assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex).
+ { inv MAS. simpl in *. eauto. }
+ destruct H as (tex & Hpbody2 & Hpctl).
+ inv EXEH. simpl in *.
+ subst. exploit step_simu_control.
+ 9: eapply MCS'. all: simpl.
+ 10: eapply ESTEP.
+ all: simpl; eauto.
+ rewrite Hpbody2. rewrite Hpctl. rewrite Hcur.
+ { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmstate_some; eauto.
+ erewrite exec_body_pc; eauto. }
+ intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS').
+
+ (* bringing the pieces together *)
+ exploit exec_body_trans.
+ eapply EXEB.
+ eauto.
+ intros EXEB2.
+ exploit exec_body_control; eauto.
+ rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto.
+ rewrite Hexit. rewrite Hpctl. eauto.
+ intros EXECB. inv EXECB.
+ exists (State rs4 m4).
+ split; auto. eapply plus_one. rewrite Hpstate2.
+ assert (exists ofs, rs1 PC = Vptr f ofs).
+ { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. }
+ destruct H0 as (ofs & Hrs1pc).
+ eapply exec_step_internal; eauto.
+
+ (* proving the initial find_bblock *)
+ rewrite Hpstate2 in MAS. inv MAS. simpl in *.
+ assert (f1 = f0) by congruence. subst f0.
+ rewrite PCeq in Hrs1pc. inv Hrs1pc.
+ exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''.
+ inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. inv Hcur.
+ eapply find_bblock_tail; eauto.
+Qed.
+
+Lemma step_simulation_bblock:
+ forall sf f sp bb ms m ms' m' S2 c,
+ body_step ge sf f sp (Machblock.body bb) ms m ms' m' ->
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 ->
+ forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
+ exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'.
+Proof.
+ intros until c. intros BSTEP Hbuiltin ESTEP S1' MS.
+ eapply step_simulation_bblock'; eauto.
+ all: destruct bb as [hd bdy ex]; simpl in *; eauto.
+ inv ESTEP.
+ - econstructor. inv H; try (econstructor; eauto; fail).
+ - econstructor.
+Qed.
+
+Definition measure (s: MB.state) : nat :=
+ match s with
+ | MB.State _ _ _ _ _ _ => 0%nat
+ | MB.Callstate _ _ _ _ => 0%nat
+ | MB.Returnstate _ _ _ => 1%nat
+ end.
+
+Definition split (c: MB.code) :=
+ match c with
+ | nil => nil
+ | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |}
+ :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c
+ end.
+
+Lemma cons_ok_eq3 {A: Type} :
+ forall (x:A) y z x' y' z',
+ x = x' -> y = y' -> z = z' ->
+ OK (x::y::z) = OK (x'::y'::z').
+Proof.
+ intros. subst. auto.
+Qed.
+
+Lemma transl_blocks_split_builtin:
+ forall bb c ep f ef args res,
+ MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil ->
+ transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep.
+Proof.
+ intros until res. intros Hexit Hbody. simpl split.
+ unfold transl_blocks. fold transl_blocks. unfold transl_block.
+ simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi.
+ remember (transl_blocks _ _ _) as tlbs.
+ destruct tbc; destruct tbi; destruct tlbs.
+ all: try simpl; auto.
+ - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl.
+ unfold gen_bblocks. simpl. destruct l.
+ + exploit transl_basic_code_nonil; eauto. intro. destruct H.
+ + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto.
+Qed.
+
+Lemma transl_code_at_pc_split_builtin:
+ forall rs f f0 bb c ep tf tc ef args res,
+ MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
+ transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc ->
+ transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc.
+Proof.
+ intros until res. intros Hbody Hexit AT. inv AT.
+ econstructor; eauto. erewrite transl_blocks_split_builtin; eauto.
+Qed.
+
+Theorem match_states_split_builtin:
+ forall sf f sp bb c rs m ef args res S1,
+ MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
+ match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
+ match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1.
+Proof.
+ intros until S1. intros Hbody Hexit MS.
+ inv MS.
+ econstructor; eauto.
+ eapply transl_code_at_pc_split_builtin; eauto.
+Qed.
+
+Lemma step_simulation_builtin:
+ forall ef args res bb sf f sp c ms m t S2,
+ MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
+ exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 ->
+ forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
+ exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+ intros until S2. intros Hbody Hexit ESTEP S1' MS.
+ inv MS. inv AT. monadInv H2. monadInv EQ.
+ rewrite Hbody in EQ0. monadInv EQ0.
+ rewrite Hexit in EQ. monadInv EQ.
+ rewrite Hexit in ESTEP. inv ESTEP. inv H4.
+
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H1); intro NOOV.
+ exploit builtin_args_match; eauto. intros [vargs' [P Q]].
+ exploit external_call_mem_extends; eauto.
+ intros [vres' [m2' [A [B [C D]]]]].
+ econstructor; split. apply plus_one.
+ simpl in H3.
+ eapply exec_step_builtin. eauto. eauto.
+ eapply find_bblock_tail; eauto.
+ simpl. eauto.
+ erewrite <- sp_val by eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ eauto.
+ econstructor; eauto.
+ instantiate (2 := tf); instantiate (1 := x0).
+ unfold nextblock. rewrite Pregmap.gss.
+ rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence.
+ rewrite <- H. simpl. econstructor; eauto.
+ eapply code_tail_next_int; eauto.
+ rewrite preg_notin_charact. intros. auto with asmgen.
+ auto with asmgen.
+ apply agree_nextblock. eapply agree_set_res; auto.
+ eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto.
+ apply Pregmap.gso; auto with asmgen.
+ congruence.
+Qed.
+
+Theorem step_simulation:
+ forall S1 t S2, MB.step return_address_offset ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
+Proof.
+ induction 1; intros.
+
+- (* bblock *)
+ left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0.
+ all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock;
+ try (rewrite MBE; try discriminate); eauto).
+ + (* MBbuiltin *)
+ destruct (MB.body bb) eqn:MBB.
+ * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto.
+ * eapply match_states_split_builtin in MS; eauto.
+ 2: rewrite MBB; discriminate.
+ simpl split in MS.
+ rewrite <- MBB in H.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1.
+ assert (MB.body bb = MB.body bb1). { subst. simpl. auto. }
+ rewrite H1 in H. subst.
+ exploit step_simulation_bblock. eapply H.
+ discriminate.
+ simpl. constructor.
+ eauto.
+ intros (S2' & PLUS1 & MS').
+ rewrite MBE in MS'.
+ assert (exit_step return_address_offset ge (Some (MBbuiltin e l b))
+ (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c)
+ rs' m') t s').
+ { inv H0. inv H3. econstructor. econstructor; eauto. }
+ exploit step_simulation_builtin.
+ 4: eapply MS'.
+ all: simpl; eauto.
+ intros (S3' & PLUS'' & MS'').
+ exists S3'. split; eauto.
+ eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto.
+ + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto.
+
+- (* internal function *)
+ inv MS.
+ exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
+ generalize EQ; intros EQ'. monadInv EQ'.
+ destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0.
+ unfold Mach.store_stack in *.
+ exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
+ intros [m1' [C D]].
+ exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ simpl chunk_of_type in F.
+ exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
+ intros [m3' [P Q]].
+ (* Execution of function prologue *)
+ monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *)
+ set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::b
+ Pget GPR8 RA ::b
+ storeind_ptr GPR8 SP (fn_retaddr_ofs f) ::b x0) in *.
+ set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *.
+ set (rs2 := nextblock (bblock_single_inst (Pallocframe (fn_stacksize f) (fn_link_ofs f)))
+ (rs0#FP <- (parent_sp s) #SP <- sp #GPR31 <- Vundef)).
+ exploit (Pget_correct tge GPR8 RA nil rs2 m2'); auto.
+ intros (rs' & U' & V').
+ exploit (exec_straight_through_singleinst); eauto.
+ intro W'. remember (nextblock _ rs') as rs''.
+ exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPR8 nil rs'' m2').
+ rewrite chunk_of_Tptr in P.
+ assert (rs' GPR8 = rs0 RA). { apply V'. }
+ assert (rs'' GPR8 = rs' GPR8). { subst. Simpl. }
+ assert (rs' GPR12 = rs2 GPR12). { apply V'; discriminate. }
+ assert (rs'' GPR12 = rs' GPR12). { subst. Simpl. }
+ rewrite H4. rewrite H3. rewrite H6. rewrite H5.
+ (* change (rs' GPR8) with (rs0 RA). *)
+ rewrite ATLR.
+ change (rs2 GPR12) with sp. eexact P.
+ congruence. congruence.
+ intros (rs3 & U & V).
+ exploit (exec_straight_through_singleinst); eauto.
+ intro W.
+ remember (nextblock _ rs3) as rs3'.
+ assert (EXEC_PROLOGUE:
+ exec_straight_blocks tge tf
+ tf.(fn_blocks) rs0 m'
+ x0 rs3' m3').
+ { change (fn_blocks tf) with tfbody; unfold tfbody.
+ apply exec_straight_blocks_step with rs2 m2'.
+ unfold exec_bblock. simpl exec_body. rewrite C. fold sp. simpl exec_control.
+ rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. reflexivity.
+ reflexivity.
+ eapply exec_straight_blocks_trans.
+ - eexact W'.
+ - eexact W. }
+ exploit exec_straight_steps_2; eauto using functions_transl.
+ simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega. constructor.
+ intros (ofs' & X & Y).
+ left; exists (State rs3' m3'); split.
+ eapply exec_straight_steps_1; eauto.
+ simpl fn_blocks. simpl fn_blocks in g. unfold tfbody. simpl bblock_single_inst. omega.
+ constructor.
+ econstructor; eauto.
+ rewrite X; econstructor; eauto.
+ apply agree_exten with rs2; eauto with asmgen.
+ unfold rs2.
+ apply agree_nextblock. apply agree_set_other; auto with asmgen.
+ apply agree_change_sp with (parent_sp s).
+ apply agree_undef_regs with rs0. auto.
+Local Transparent destroyed_at_function_entry.
+ simpl; intros; Simpl.
+ unfold sp; congruence.
+
+ intros.
+ assert (r <> GPR31). { contradict H3; rewrite H3; unfold data_preg; auto. }
+ rewrite Heqrs3'. Simpl. rewrite V. rewrite Heqrs''. Simpl. inversion V'. rewrite H6. auto.
+ assert (r <> GPR8). { contradict H3; rewrite H3; unfold data_preg; auto. }
+ assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. }
+ (* rewrite H8; auto. *)
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ auto. intros. rewrite Heqrs3'. Simpl. rewrite V by auto with asmgen.
+ assert (forall r : preg, r <> PC -> r <> GPR8 -> rs' r = rs2 r). { apply V'. }
+ rewrite Heqrs''. Simpl.
+ rewrite H4 by auto with asmgen. reflexivity.
+- (* external function *)
+ inv MS.
+ exploit functions_translated; eauto.
+ intros [tf [A B]]. simpl in B. inv B.
+ exploit extcall_arguments_match; eauto.
+ intros [args' [C D]].
+ exploit external_call_mem_extends; eauto.
+ intros [res' [m2' [P [Q [R S]]]]].
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ econstructor; eauto.
+ unfold loc_external_result.
+ apply agree_set_other; auto.
+ apply agree_set_pair; auto.
+
+- (* return *)
+ inv MS.
+ inv STACKS. simpl in *.
+ right. split. omega. split. auto.
+ rewrite <- ATPC in H5.
+ econstructor; eauto. congruence.
+Qed.
+
+Lemma transf_initial_states:
+ forall st1, MB.initial_state prog st1 ->
+ exists st2, AB.initial_state tprog st2 /\ match_states st1 st2.
+Proof.
+ intros. inversion H. unfold ge0 in *.
+ econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf_partial TRANSF); eauto.
+ replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
+ with (Vptr fb Ptrofs.zero).
+ econstructor; eauto.
+ constructor.
+ apply Mem.extends_refl.
+ split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.
+ intros. rewrite Mach.Regmap.gi. auto.
+ unfold Genv.symbol_address.
+ rewrite (match_program_main TRANSF).
+ rewrite symbols_preserved.
+ unfold ge; rewrite H1. auto.
+Qed.
+
+Lemma transf_final_states:
+ forall st1 st2 r,
+ match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r.
+Proof.
+ intros. inv H0. inv H. constructor. assumption.
+ compute in H1. inv H1.
+ generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.
+Qed.
+
+Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop :=
+ Asmblockgenproof0.return_address_offset.
+
+Theorem transf_program_correct:
+ forward_simulation (MB.semantics return_address_offset prog) (AB.semantics tprog).
+Proof.
+ eapply forward_simulation_star with (measure := measure).
+ - apply senv_preserved.
+ - eexact transf_initial_states.
+ - eexact transf_final_states.
+ - exact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v new file mode 100644 index 00000000..e2b72295 --- /dev/null +++ b/mppa_k1c/Asmblockgenproof0.v @@ -0,0 +1,1081 @@ +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. + +Module MB:=Machblock. +Module AB:=Asmblock. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma ireg_of_eq: + forall r r', ireg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold ireg_of; intros. destruct (preg_of r); inv H; auto. +(* destruct b. all: try discriminate. + inv H1. auto. + *)Qed. + +(* FIXME - Replaced FR by IR for MPPA *) +Lemma freg_of_eq: + forall r r', freg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold freg_of; intros. destruct (preg_of r); inv H; auto. +(* destruct b. all: try discriminate. + inv H1. auto. + *)Qed. + + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +Lemma preg_of_data: + forall r, data_preg (preg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. +Hint Resolve preg_of_data: asmgen. + +Lemma data_diff: + forall r r', + data_preg r = true -> data_preg r' = false -> r <> r'. +Proof. + congruence. +Qed. +Hint Resolve data_diff: asmgen. + +Lemma preg_of_not_SP: + forall r, preg_of r <> SP. +Proof. + intros. unfold preg_of; destruct r; simpl; congruence. +Qed. + +Lemma preg_of_not_PC: + forall r, preg_of r <> PC. +Proof. + intros. apply data_diff; auto with asmgen. +Qed. + +Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. + +Lemma nextblock_pc: + forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). +Proof. + intros. apply Pregmap.gss. +Qed. + +Lemma nextblock_inv: + forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. +Proof. + intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. +Qed. + +Lemma nextblock_inv1: + forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. +Proof. + intros. apply nextblock_inv. red; intro; subst; discriminate. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree ms sp rs -> + (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.undef_regs rl ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite <- agree_sp0. apply H0; auto. + rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. + intros. destruct (In_dec mreg_eq r rl). + rewrite Mach.undef_regs_same; auto. + rewrite Mach.undef_regs_other; auto. rewrite H0; auto. + apply preg_of_data. + rewrite preg_notin_charact. intros; red; intros. elim n. + exploit preg_of_injective; eauto. congruence. +Qed. + +(* Lemma agree_undef_regs2: + forall ms sp rl rs rs', + agree (Mach.undef_regs rl ms) sp rs -> + (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.undef_regs rl ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite <- agree_sp0. apply H0; auto. + rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. + intros. destruct (In_dec mreg_eq r rl). + rewrite Mach.undef_regs_same; auto. + rewrite H0; auto. + apply preg_of_data. + rewrite preg_notin_charact. intros; red; intros. elim n. + exploit preg_of_injective; eauto. congruence. +Qed. + *) + +Lemma agree_set_undef_mreg: + forall ms sp rs r v rl rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +(* NB: these two lemma should go into [Coqlib.v] *) +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; simpl; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; simpl; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + + +(* NB: the hypothesis in comment on [b] is not needed in the proof ! *) +Lemma return_address_exists: + forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. destruct (transf_function f) as [tf|] eqn:TF. + + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). +(* unfold return_address_offset. *) + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +Qed. + +End RETADDR_EXISTS. + +(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points + within the Asm code generated by translating Mach function [f], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +(* Theorem exec_straight_bblock: + forall rs1 m1 rs2 m2 rs3 m3 b, + exec_straight (body b) rs1 m1 nil rs2 m2 -> + exec_control_rel (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel b rs1 m1 rs3 m3. +Proof. + intros. + econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto. + inv H0. auto. +Qed. *) + + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +Qed. + +(** Linking exec_straight with exec_straight_blocks *) + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Lemma exec_basic_instr_pc: + forall b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + all: try (unfold exec_load in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). + all: try (unfold exec_store in H1; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). + destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H0. Simpl. discriminate. + destruct rs; try discriminate. inv H1. Simpl. + destruct rd; try discriminate. inv H1; Simpl. + auto. +Qed. + +(* Lemma exec_straight_pc': + forall c rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - erewrite exec_basic_instr_pc; eauto. + - rewrite (IHc rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. *) + +Lemma exec_straight_pc: + forall c c' rs1 m1 rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. + +(* Lemma exec_straight_through: + forall c i b lb rs1 m1 rs2 m2 rs2' m2', + bblock_basic_ctl c i = b -> + exec_straight c rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_control ge fn i rs2' m2' = Next rs2' m2' -> (* if the control does not jump *) + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. destruct i. + - constructor 1. + + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + + rewrite <- (exec_straight_pc c nil rs1 m1 rs2 m2'); auto. + - destruct c as [|i c]; try (inv H0; fail). + constructor 1. + + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + + rewrite <- (exec_straight_pc (i ::i c) nil rs1 m1 rs2 m2'); auto. +Qed. + *) +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. auto. + simpl; auto. unfold nextblock; simpl. Simpl. erewrite exec_straight_pc; eauto. +Qed. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK.
\ No newline at end of file diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v new file mode 100644 index 00000000..d0c205cd --- /dev/null +++ b/mppa_k1c/Asmblockgenproof1.v @@ -0,0 +1,1633 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Errors Maps. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op Locations Machblock Conventions. +Require Import Asmblock Asmblockgen Asmblockgenproof0. + +(** Decomposition of integer constants. *) + +Lemma make_immed32_sound: + forall n, + match make_immed32 n with + | Imm32_single imm => n = imm + end. +Proof. + intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). + predSpec Int.eq Int.eq_spec n lo; auto. +(* +- auto. +- set (m := Int.sub n lo). + assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). + assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). + { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. + auto using Int.eqmod_sub, Int.eqmod_refl. } + assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). + { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. + apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + exists (two_p (32-12)); auto. } + assert (D: Int.modu m (Int.repr 4096) = Int.zero). + { apply Int.eqmod_mod_eq in C. unfold Int.modu. + change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. + reflexivity. + apply two_p_gt_ZERO; omega. } + rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. + rewrite Int.shl_mul_two_p. + change (two_p (Int.unsigned (Int.repr 12))) with 4096. + replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m. + unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo). + rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. + rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). + rewrite D. apply Int.add_zero. +*) +Qed. + +Lemma make_immed64_sound: + forall n, + match make_immed64 n with + | Imm64_single imm => n = imm +(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo + | Imm64_large imm => n = imm +*)end. +Proof. + intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). + predSpec Int64.eq Int64.eq_spec n lo. +- auto. +- set (m := Int64.sub n lo). + set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). + predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). + auto. + auto. +Qed. + + + +(** Properties of registers *) + +Lemma ireg_of_not_GPR31: + forall m r, ireg_of m = OK r -> IR r <> IR GPR31. +Proof. + intros. erewrite <- ireg_of_eq; eauto with asmgen. +Qed. + +Lemma ireg_of_not_GPR31': + forall m r, ireg_of m = OK r -> r <> GPR31. +Proof. + intros. apply ireg_of_not_GPR31 in H. congruence. +Qed. + +Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. + + +(** Useful simplification tactic *) + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(** * Correctness of RISC-V constructor functions *) + +Section CONSTRUCTORS. + +Variable ge: genv. +Variable fn: function. + +(* +(** 32-bit integer constants and arithmetic *) +(* +Lemma load_hilo32_correct: + forall rd hi lo k rs m, + exists rs', + exec_straight ge fn (load_hilo32 rd hi lo k) rs m k rs' m + /\ rs'#rd = Vint (Int.add (Int.shl hi (Int.repr 12)) lo) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold load_hilo32; intros. + predSpec Int.eq Int.eq_spec lo Int.zero. +- subst lo. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int.add_zero. Simpl. + intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. + intros; Simpl. +Qed. +*) + +*) + +Lemma loadimm32_correct: + forall rd n k rs m, + exists rs', + exec_straight ge (loadimm32 rd n ::g 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. Simpl. + intros; Simpl. +Qed. + +Lemma loadimm64_correct: + forall rd n k rs m, + exists rs', + exec_straight ge (loadimm64 rd n ::g k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> 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. Simpl. + intros; Simpl. +Qed. + +(* +(* +Lemma opimm32_correct: + forall (op: ireg -> ireg0 -> ireg0 -> instruction) + (opi: ireg -> ireg0 -> int -> instruction) + (sem: val -> val -> val) m, + (forall d s1 s2 rs, + exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs##s1 rs##s2))) m) -> + (forall d s n rs, + exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs##s (Vint n)))) m) -> + forall rd r1 n k rs, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (opimm32 op opi rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs##r1 (Vint n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. unfold opimm32. generalize (make_immed32_sound n); intros E. + destruct (make_immed32 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +- destruct (load_hilo32_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) + as (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite H; eauto. auto. + split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. + intros; Simpl. +Qed. + +(** 64-bit integer constants and arithmetic *) + +Lemma load_hilo64_correct: + forall rd hi lo k rs m, + exists rs', + exec_straight ge fn (load_hilo64 rd hi lo k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold load_hilo64; intros. + predSpec Int64.eq Int64.eq_spec lo Int64.zero. +- subst lo. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int64.add_zero. Simpl. + intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. + intros; Simpl. +Qed. +*) +*) + +Definition yolo := 4. + +Lemma opimm64_correct: + forall (op: arith_name_rrr) + (opi: arith_name_rri64) + (sem: val -> val -> val) m, + (forall d s1 s2 rs, + exec_basic_instr ge (op d s1 s2) rs m = Next ((rs#d <- (sem rs#s1 rs#s2))) m) -> + (forall d s n rs, + exec_basic_instr ge (opi d s n) rs m = Next ((rs#d <- (sem rs#s (Vlong n)))) m) -> + forall rd r1 n k rs, + r1 <> GPR31 -> + exists rs', + exec_straight ge (opimm64 op opi rd r1 n ::g k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. unfold opimm64. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +(* +- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) + as (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite H; eauto. auto. + split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. + intros; Simpl. +- subst imm. econstructor; split. + eapply exec_straight_two. simpl; eauto. rewrite H. simpl; eauto. auto. auto. + split. Simpl. intros; Simpl. +*) +Qed. + +(** Add offset to pointer *) + +Lemma addptrofs_correct: + forall rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge (addptrofs rd r1 n ::g k) rs m k rs' m + /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold addptrofs; intros. + destruct (Ptrofs.eq_dec n Ptrofs.zero). +- subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. + intros; Simpl. +- unfold addimm64. + exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. + rewrite B. destruct (rs r1); simpl; auto. + rewrite Ptrofs.of_int64_to_int64 by auto. auto. +Qed. + +(* +(* +Lemma addptrofs_correct_2: + forall rd r1 n k (rs: regset) m b ofs, + r1 <> GPR31 -> rs#r1 = Vptr b of +s -> + exists rs', + exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m + /\ rs'#rd = Vptr b (Ptrofs.add ofs n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C). + exists rs'; intuition eauto. + rewrite H0 in B. inv B. auto. +Qed. + +(** Translation of conditional branches *) + +Remark branch_on_GPR31: + forall normal lbl (rs: regset) m b, + rs#GPR31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 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 + | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args + | [ H: bind _ _ = OK _ |- _ ] => monadInv H + | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + end); + subst; + repeat (match goal with + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * + | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * + end). + +Inductive exec_straight_opt: list instruction -> regset -> mem -> list instruction -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight ge c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Remark exec_straight_opt_right: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> + exec_straight ge c2 rs2 m2 c3 rs3 m3 -> + exec_straight ge c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma transl_comp_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compu_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez GPR31 lbl)))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpubool. + destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compl_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_complu_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez GPR31 lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # GPR31 (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_opt_compuimm_correct: + forall n cmp r1 lbl k rs m b tbb c, + select_comp n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. +(* unfold transl_opt_compuimm. unfold select_comp in H. rewrite H; simpl. *) + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compuimm. subst. rewrite H'. + + exists rs, (Pcbu BTweqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. + (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) + auto; + unfold eval_branch. rewrite H0; auto. + - (* c = Cne *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compuimm. subst. rewrite H'. + + exists rs, (Pcbu BTwnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. + auto; + unfold eval_branch. rewrite H0. auto. + - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_opt_compluimm_correct: + forall n cmp r1 lbl k rs m b tbb c, + select_compl n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. +(* unfold transl_opt_compluimm; rewrite H; simpl. *) + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compluimm; subst; rewrite H'. + + exists rs, (Pcbu BTdeqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. + auto; + unfold eval_branch. rewrite H0; auto. + - (* c = Cne *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compluimm; subst; rewrite H'. + + exists rs, (Pcbu BTdnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock. Simpl. rewrite H1 in H0. + auto; + unfold eval_branch. rewrite H0; auto. + - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_cbranch_correct_1: + forall cond args lbl k c m ms b sp rs m' tbb, + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some b -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = eval_branch fn lbl (nextblock tbb rs') m' (Some b) + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until tbb; intros TRANSL EVAL AG MEXT. + set (vl' := map rs (map preg_of args)). + assert (EVAL': eval_condition cond vl' m' = Some b). + { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } + clear EVAL MEXT AG. + destruct cond; simpl in TRANSL; ArgsInv. +(* Ccomp *) +- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompu *) +- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompimm *) +- remember (Int.eq n Int.zero) as eqz. + destruct eqz. + + assert (n = (Int.repr 0)). { + destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. + generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpswz c0) x lbl). + split. + * constructor. + * split; auto. + assert (rs x = (nextblock tbb rs) x). + unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +(* Ccompuimm *) +- remember (select_comp n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + assert (transl_opt_compuimm n c0 x lbl k = loadimm32 GPR31 n ::g transl_comp c0 Unsigned x GPR31 lbl k). + { unfold transl_opt_compuimm. + destruct (Int.eq n Int.zero) eqn:EQN. + all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. + all: discriminate. } + rewrite H. clear H. + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +(* Ccompl *) +- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplu *) +- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplimm *) +- remember (Int64.eq n Int64.zero) as eqz. + destruct eqz. + + assert (n = (Int64.repr 0)). { + destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. + generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). + split. + * constructor. + * split; auto. + assert (rs x = (nextblock tbb rs) x). + unfold nextblock. Simpl. rewrite H0 in EVAL'. clear H0. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } + +(* Ccompluimm *) +- remember (select_compl n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + assert (transl_opt_compluimm n c0 x lbl k = loadimm64 GPR31 n ::g transl_compl c0 Unsigned x GPR31 lbl k). + { unfold transl_opt_compluimm. + destruct (Int64.eq n Int64.zero) eqn:EQN. + all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. + all: discriminate. } + rewrite H. clear H. + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +Qed. + +Lemma transl_cbranch_correct_true: + forall cond args lbl k c m ms sp rs m' tbb, + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some true -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. + +Lemma transl_cbranch_correct_false: + forall cond args lbl k c m ms sp rs tbb m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some false -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. exploit transl_cbranch_correct_1; eauto. +Qed. +(* intros (rs' & insn & A & B & C). + exists rs'. + split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. + intros; Simpl. + *) + +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int32s cmp rd r1 r2 k)) rs m (basics_to_code 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]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code 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]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int64s cmp rd r1 r2 k)) rs m (basics_to_code 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]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code 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]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int32s cmp rd r1 n k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int32u cmp rd r1 n k)) rs m (basics_to_code 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 <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int64s cmp rd r1 n k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int64u cmp rd r1 n k)) rs m (basics_to_code 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 <> GPR31 -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +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 (basics_to_code c) rs m (basics_to_code 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 <> GPR31 -> 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. simpl. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. simpl. 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. simpl. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. simpl. 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. simpl. + 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. simpl. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. +Qed. + +(* +(* ++ (* 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. +*) +*) + +(** 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. + +Lemma cast32signed_correct: + forall (d s: ireg) (k: code) (rs: regset) (m: mem), + exists rs': regset, + exec_straight ge (cast32signed d s ::g k) rs m k rs' m + /\ Val.lessdef (Val.longofint (rs s)) (rs' d) + /\ (forall r: preg, r <> PC -> r <> d -> rs' r = rs r). +Proof. + intros. unfold cast32signed. destruct (ireg_eq d s). +- econstructor; split. + + apply exec_straight_one. simpl. eauto with asmgen. + + split. + * rewrite e. Simpl. + * intros. destruct r; Simpl. +- econstructor; split. + + apply exec_straight_one. simpl. eauto with asmgen. + + split. + * Simpl. + * intros. destruct r; Simpl. +Qed. + +(* Translation of arithmetic operations *) + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inv H + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; reflexivity + | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ]. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. + assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } +Opaque Int.eq. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +- (* Omove *) + destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Oaddrsymbol *) + destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ set (rs1 := (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs (basics_to_code 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. +- (* Oaddrstack *) + exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* Ocast8signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. + split; intros; simpl; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* Ocast16signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* Oshrximm *) + clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. + 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. +- (* Ocast32signed *) + exploit cast32signed_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. split. apply B. + intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } + apply C; auto. +- (* longofintu *) + econstructor; split. + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. + split; intros; Simpl. (* unfold Pregmap.set; Simpl. *) destruct (PregEq.eq x0 x0). + + 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. + + contradict n. auto. +- (* Ocmp *) + exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. +(* +- (* 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. +- (* stackoffset *) + exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* 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. + + + +- (* 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 *) + clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. 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. +*) +Qed. + +(** Memory accesses *) + +Lemma indexed_memory_access_correct: + forall mk_instr base ofs k rs m, + base <> GPR31 -> + exists base' ofs' rs', + exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m + (mk_instr base' ofs' ::g k) rs' m + /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold indexed_memory_access; intros. + (* destruct Archi.ptr64 eqn:SF. *) + assert (Archi.ptr64 = true) as SF; auto. +- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. + destruct (make_immed64 (Ptrofs.to_int64 ofs)). ++ econstructor; econstructor; econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. +(* ++ econstructor; econstructor; econstructor; split. + constructor. eapply exec_straight_two. + simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. + rewrite Ptrofs.add_assoc. f_equal. f_equal. + rewrite <- (Ptrofs.of_int64_to_int64 SF ofs). rewrite EQ. + symmetry; auto with ptrofs. ++ econstructor; econstructor; econstructor; split. + constructor. eapply exec_straight_two. + simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold eval_offset. destruct (rs base); auto; simpl. rewrite SF. simpl. + rewrite Ptrofs.add_zero. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. +(* 32 bits part, irrelevant for us +- generalize (make_immed32_sound (Ptrofs.to_int ofs)); intros EQ. + destruct (make_immed32 (Ptrofs.to_int ofs)). ++ econstructor; econstructor; econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. subst imm. rewrite Ptrofs.of_int_to_int by auto. auto. ++ econstructor; econstructor; econstructor; split. + constructor. eapply exec_straight_two. + simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. + rewrite Ptrofs.add_assoc. f_equal. f_equal. + rewrite <- (Ptrofs.of_int_to_int SF ofs). rewrite EQ. + symmetry; auto with ptrofs. +*)*) +Qed. + + +Lemma indexed_load_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) rd m, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + forall (base: ireg) ofs k (rs: regset) v, + Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> rd <> PC -> + exists rs', + exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_load. rewrite B, LOAD. eauto. Simpl. + split; intros; Simpl. auto. +Qed. + +Lemma indexed_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) r1 m, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + forall (base: ireg) ofs k (rs: regset) m', + Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> + base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> + exists rs', + exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. + exploit indexed_memory_access_correct. instantiate (1 := base). eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. + unfold exec_store. rewrite B, C, STORE. eauto. eauto. auto. + intros; Simpl. rewrite C; auto. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k c (rs: regset) m v, + loadind base ofs ty dst k = OK c -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR LOAD NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs :: k + /\ forall base' ofs' rs', + exec_basic_instr ge (mk_instr base' ofs') rs' m = + exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). + { unfold loadind in TR. + destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_load_access_correct; eauto with asmgen. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k c (rs: regset) m m', + storeind src base ofs ty k = OK c -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> + base <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR STORE NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs :: k + /\ forall base' ofs' rs', + exec_basic_instr ge (mk_instr base' ofs') rs' m = + exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). + { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_store_access_correct; eauto with asmgen. +Qed. + +Ltac bsimpl := unfold exec_bblock; simpl. + +Lemma Pget_correct: + forall (dst: gpreg) (src: preg) k (rs: regset) m, + src = RA -> + exists rs', + exec_straight ge (Pget dst src ::g k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor. +- rewrite H. bsimpl. auto. +- Simpl. +- intros. Simpl. +Qed. + +Lemma Pset_correct: + forall (dst: preg) (src: gpreg) k (rs: regset) m, + dst = RA -> + exists rs', + exec_straight ge (Pset dst src ::g k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor; simpl. + rewrite H. auto. + Simpl. + Simpl. + intros. rewrite H. Simpl. +Qed. + +Lemma loadind_ptr_correct: + forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> + exists rs', + exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r. +Proof. + intros. eapply indexed_load_access_correct; eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H1. auto. +Qed. + +Lemma storeind_ptr_correct: + forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', + Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + base <> GPR31 -> src <> GPR31 -> + exists rs', + exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true); auto. +Qed. + +Lemma transl_memory_access_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ofs rs', + exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m + /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access in TR; destruct addr; ArgsInv. +- (* indexed *) + inv EV. apply indexed_memory_access_correct; eauto with asmgen. +- (* global *) + simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. + constructor. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. unfold eval_offset. + assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). + { apply Val.offset_ptr_zero. } + remember (Genv.symbol_address ge i i0) as symbol. + destruct symbol; auto. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + simpl. rewrite Ptrofs.add_zero; auto. +- (* stack *) + inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. +Qed. + +Lemma transl_load_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = Some v' -> + rd <> PC -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros INSTR TR EV LOAD NOTPC. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + +Lemma transl_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.storev chunk m v rs#r1 = Some m' -> + r1 <> PC -> r1 <> GPR31 -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros INSTR TR EV STORE NOTPC NOT31. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. +Qed. + +Lemma transl_load_correct: + forall chunk addr args dst k c (rs: regset) m a v, + transl_load chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV LOAD. + assert (A: exists mk_instr, + transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). + { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } + destruct A as (mk_instr & B & C). + eapply transl_load_access_correct; eauto with asmgen. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m a m', + transl_store chunk addr args src k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR EV STORE. + assert (A: exists mk_instr chunk', + transl_memory_access mk_instr addr args k = OK c + /\ (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). + { unfold transl_store in TR; destruct chunk; ArgsInv; + (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). + destruct a; auto. apply Mem.store_signed_unsigned_8. + destruct a; auto. apply Mem.store_signed_unsigned_16. + } + destruct A as (mk_instr & chunk' & B & C & D). + rewrite D in STORE; clear D. + eapply transl_store_access_correct; eauto with asmgen. +Qed. + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs k tm, + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge (make_epilogue f k) rs tm k rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r). +Proof. + intros until tm; intros LP LRA FREE AG MEXT MCS. + exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). + exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). + exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. + exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. + exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). + unfold make_epilogue. + rewrite chunk_of_Tptr in *. + + exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) + rs tm). + - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. + - congruence. + - intros (rs1 & A1 & B1 & C1). + assert (agree ms (Vptr stk soff) rs1) as AG1. + + destruct AG. + apply mkagree; auto. + rewrite C1; discriminate || auto. + intro. rewrite C1; auto; destruct r; simpl; try discriminate. + + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto. + intros (rs2 & A2 & B2 & C2). + econstructor; econstructor; split. + * eapply exec_straight_trans. + { eexact A1. } + { eapply exec_straight_trans. + { eapply A2. } + { apply exec_straight_one. simpl. + rewrite (C2 GPR12) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. + rewrite FREE'; eauto. (* auto. *) } } + * split. (* apply agree_nextinstr. *)apply agree_set_other; auto with asmgen. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. rewrite B2. auto. + split. Simpl. + intros. Simpl. + rewrite C2; auto. +Qed. + +End CONSTRUCTORS. + + diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml new file mode 100644 index 00000000..13869268 --- /dev/null +++ b/mppa_k1c/Asmexpand.ml @@ -0,0 +1,578 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(* Expanding built-ins and some pseudo-instructions by rewriting + of the RISC-V assembly code. *) + +open Asm +open Asmgen +open Asmexpandaux +open AST +open Camlcoq +open Integers + +exception Error of string + +(* Useful constants and helper functions *) + +let _0 = Integers.Int.zero +let _1 = Integers.Int.one +let _2 = coqint_of_camlint 2l +let _4 = coqint_of_camlint 4l +let _8 = coqint_of_camlint 8l +let _16 = coqint_of_camlint 16l +let _m1 = coqint_of_camlint (-1l) + +let wordsize = if Archi.ptr64 then 8 else 4 + +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 []) +*) +let expand_addptrofs dst src n = + List.iter emit (addptrofs dst src n :: []) +let expand_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 + locations; generate no code; + - inlined by the compiler: take their arguments in arbitrary + registers. +*) + +(* Fix-up code around calls to variadic functions. Floating-point arguments + residing in FP registers need to be moved to integer registers. *) + +let int_param_regs = let open Asmblock in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7 |] +(* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) +let float_param_regs = [| |] + +let fixup_variadic_call pos tyl = assert false +(*if pos < 8 then + match tyl with + | [] -> + () + | (Tint | Tany32) :: tyl -> + fixup_variadic_call (pos + 1) tyl + | Tsingle :: tyl -> + let rs =float_param_regs.(pos) + and rd = int_param_regs.(pos) in + emit (Pfmvxs(rd, rs)); + fixup_variadic_call (pos + 1) tyl + | Tlong :: tyl -> + let pos' = if Archi.ptr64 then pos + 1 else align pos 2 + 2 in + fixup_variadic_call pos' tyl + | (Tfloat | Tany64) :: tyl -> + if Archi.ptr64 then begin + let rs = float_param_regs.(pos) + and rd = int_param_regs.(pos) in + emit (Pfmvxd(rd, rs)); + fixup_variadic_call (pos + 1) tyl + end else begin + let pos = align pos 2 in + if pos < 8 then begin + let rs = float_param_regs.(pos) + and rd1 = int_param_regs.(pos) + and rd2 = int_param_regs.(pos + 1) in + emit (Paddiw(X2, X X2, Integers.Int.neg _16)); + emit (Pfsd(rs, X2, Ofsimm _0)); + emit (Plw(rd1, X2, Ofsimm _0)); + emit (Plw(rd2, X2, Ofsimm _4)); + emit (Paddiw(X2, X X2, _16)); + fixup_variadic_call (pos + 2) tyl + end + end +*) + +let fixup_call sg = + if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args + +(* Handling of annotations *) + +let expand_annot_val kind txt targ args res = assert false +(*emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); + match args, res with + | [BA(IR src)], BR(IR dst) -> + if dst <> src then emit (Pmv (dst, src)) + | [BA(FR src)], BR(FR dst) -> + if dst <> src then emit (Pfmv (dst, src)) + | _, _ -> + raise (Error "ill-formed __builtin_annot_val") +*) + +(* Handling of memcpy *) + +(* Unaligned accesses are slow on RISC-V, so don't use them *) + +let offset_in_range ofs = + let ofs = Z.to_int64 ofs in -2048L <= ofs && ofs < 2048L + +let memcpy_small_arg sz arg tmp = assert false +(*match arg with + | BA (IR r) -> + (r, _0) + | BA_addrstack ofs -> + if offset_in_range ofs + && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) + then (GPR12, ofs) + else begin expand_addptrofs tmp GPR12 ofs; (tmp, _0) end + | _ -> + assert false +*) + +let expand_builtin_memcpy_small sz al src dst = assert false +(*let (tsrc, tdst) = + if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in + let (rsrc, osrc) = memcpy_small_arg sz src tsrc in + let (rdst, odst) = memcpy_small_arg sz dst tdst in + let rec copy osrc odst sz = + if sz >= 8 && al >= 8 then + begin + emit (Pfld (F0, rsrc, Ofsimm osrc)); + emit (Pfsd (F0, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _8) (Ptrofs.add odst _8) (sz - 8) + end + else if sz >= 4 && al >= 4 then + begin + emit (Plw (X31, rsrc, Ofsimm osrc)); + emit (Psw (X31, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _4) (Ptrofs.add odst _4) (sz - 4) + end + else if sz >= 2 && al >= 2 then + begin + emit (Plh (X31, rsrc, Ofsimm osrc)); + emit (Psh (X31, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _2) (Ptrofs.add odst _2) (sz - 2) + end + else if sz >= 1 then + begin + emit (Plb (X31, rsrc, Ofsimm osrc)); + emit (Psb (X31, rdst, Ofsimm odst)); + copy (Ptrofs.add osrc _1) (Ptrofs.add odst _1) (sz - 1) + end + in copy osrc odst sz +*) + +let memcpy_big_arg sz arg tmp = assert false +(*match arg with + | BA (IR r) -> if r <> tmp then emit (Pmv(tmp, r)) + | BA_addrstack ofs -> + expand_addptrofs tmp X2 ofs + | _ -> + assert false +*) + +let expand_builtin_memcpy_big sz al src dst = assert false +(*assert (sz >= al); + assert (sz mod al = 0); + let (s, d) = + if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in + memcpy_big_arg sz src s; + memcpy_big_arg sz dst d; + (* Use X7 as loop count, X1 and F0 as ld/st temporaries. *) + let (load, store, chunksize) = + if al >= 8 then + (Pfld (F0, s, Ofsimm _0), Pfsd (F0, d, Ofsimm _0), 8) + else if al >= 4 then + (Plw (X31, s, Ofsimm _0), Psw (X31, d, Ofsimm _0), 4) + else if al = 2 then + (Plh (X31, s, Ofsimm _0), Psh (X31, d, Ofsimm _0), 2) + else + (Plb (X31, s, Ofsimm _0), Psb (X31, d, Ofsimm _0), 1) in + expand_loadimm32 X7 (Z.of_uint (sz / chunksize)); + let delta = Z.of_uint chunksize in + let lbl = new_label () in + emit (Plabel lbl); + emit load; + expand_addptrofs s s delta; + emit (Paddiw(X7, X X7, _m1)); + emit store; + expand_addptrofs d d delta; + emit (Pbnew (X X7, X0, lbl)) +*) + +let expand_builtin_memcpy sz al args = + let (dst, src) = + match args with [d; s] -> (d, s) | _ -> assert false in + if sz <= 32 + then expand_builtin_memcpy_small sz al src dst + else expand_builtin_memcpy_big sz al src dst + +(* Handling of volatile reads and writes *) + +let expand_builtin_vload_common chunk base ofs res = assert false +(*match chunk, res with + | Mint8unsigned, BR(IR res) -> + emit (Plbu (res, base, Ofsimm ofs)) + | Mint8signed, BR(IR res) -> + emit (Plb (res, base, Ofsimm ofs)) + | Mint16unsigned, BR(IR res) -> + emit (Plhu (res, base, Ofsimm ofs)) + | Mint16signed, BR(IR res) -> + emit (Plh (res, base, Ofsimm ofs)) + | Mint32, BR(IR res) -> + emit (Plw (res, base, Ofsimm ofs)) + | Mint64, BR(IR res) -> + emit (Pld (res, base, Ofsimm ofs)) + | Mint64, BR_splitlong(BR(IR res1), BR(IR res2)) -> + let ofs' = Ptrofs.add ofs _4 in + if base <> res2 then begin + emit (Plw (res2, base, Ofsimm ofs)); + emit (Plw (res1, base, Ofsimm ofs')) + end else begin + emit (Plw (res1, base, Ofsimm ofs')); + emit (Plw (res2, base, Ofsimm ofs)) + end + | Mfloat32, BR(FR res) -> + emit (Pfls (res, base, Ofsimm ofs)) + | Mfloat64, BR(FR res) -> + emit (Pfld (res, base, Ofsimm ofs)) + | _ -> + assert false +*) + +let expand_builtin_vload chunk args res = assert false +(*match args with + | [BA(IR addr)] -> + expand_builtin_vload_common chunk addr _0 res + | [BA_addrstack ofs] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk GPR12 ofs res + else begin + expand_addptrofs GPR32 GPR12 ofs; (* X31 <- sp + ofs *) + expand_builtin_vload_common chunk GPR32 _0 res + end + | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs))] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vload_common chunk addr ofs res + else begin + expand_addptrofs GPR32 addr ofs; (* X31 <- addr + ofs *) + expand_builtin_vload_common chunk GPR32 _0 res + end + | _ -> + assert false +*) + +let expand_builtin_vstore_common chunk base ofs src = assert false +(*match chunk, src with + | (Mint8signed | Mint8unsigned), BA(IR src) -> + emit (Psb (src, base, Ofsimm ofs)) + | (Mint16signed | Mint16unsigned), BA(IR src) -> + emit (Psh (src, base, Ofsimm ofs)) + | Mint32, BA(IR src) -> + emit (Psw (src, base, Ofsimm ofs)) + | Mint64, BA(IR src) -> + emit (Psd (src, base, Ofsimm ofs)) + | Mint64, BA_splitlong(BA(IR src1), BA(IR src2)) -> + let ofs' = Ptrofs.add ofs _4 in + emit (Psw (src2, base, Ofsimm ofs)); + emit (Psw (src1, base, Ofsimm ofs')) + | Mfloat32, BA(FR src) -> + emit (Pfss (src, base, Ofsimm ofs)) + | Mfloat64, BA(FR src) -> + emit (Pfsd (src, base, Ofsimm ofs)) + | _ -> + assert false +*) + +let expand_builtin_vstore chunk args = assert false +(*match args with + | [BA(IR addr); src] -> + expand_builtin_vstore_common chunk addr _0 src + | [BA_addrstack ofs; src] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk X2 ofs src + else begin + expand_addptrofs X31 X2 ofs; (* X31 <- sp + ofs *) + expand_builtin_vstore_common chunk X31 _0 src + end + | [BA_addptr(BA(IR addr), (BA_int ofs | BA_long ofs)); src] -> + if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then + expand_builtin_vstore_common chunk addr ofs src + else begin + expand_addptrofs X31 addr ofs; (* X31 <- addr + ofs *) + expand_builtin_vstore_common chunk X31 _0 src + end + | _ -> + assert false +*) + +(* Handling of varargs *) + +(* Size in words of the arguments to a function. This includes both + arguments passed in registers and arguments passed on stack. *) + +let rec args_size sz = function + | [] -> sz + | (Tint | Tsingle | Tany32) :: l -> + args_size (sz + 1) l + | (Tlong | Tfloat | Tany64) :: l -> + args_size (if Archi.ptr64 then sz + 1 else align sz 2 + 2) l + +let arguments_size sg = + args_size 0 sg.sig_args + +let save_arguments first_reg base_ofs = let open Asmblock in + for i = first_reg to 7 do + expand_storeind_ptr + int_param_regs.(i) + GPR12 + (Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))) + done + +let vararg_start_ofs : Z.t option ref = ref None + +let expand_builtin_va_start r = assert false +(*match !vararg_start_ofs with + | None -> + invalid_arg "Fatal error: va_start used in non-vararg function" + | Some ofs -> + expand_addptrofs X31 X2 (Ptrofs.repr ofs); + expand_storeind_ptr X31 r Ptrofs.zero +*) + +(* Auxiliary for 64-bit integer arithmetic built-ins. They expand to + two instructions, one computing the low 32 bits of the result, + followed by another computing the high 32 bits. In cases where + the first instruction would overwrite arguments to the second + instruction, we must go through X31 to hold the low 32 bits of the result. +*) + +let expand_int64_arith conflict rl fn = assert false +(*if conflict then (fn X31; emit (Pmv(rl, X31))) else fn rl *) + +(* Byte swaps. There are no specific instructions, so we use standard, + not-very-efficient formulas. *) + +let expand_bswap16 d s = assert false + (* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *) +(*emit (Pandiw(X31, X s, coqint_of_camlint 0xFFl)); + emit (Pslliw(X31, X X31, _8)); + emit (Psrliw(d, X s, _8)); + emit (Pandiw(d, X d, coqint_of_camlint 0xFFl)); + emit (Porw(d, X X31, X d)) +*) + +let expand_bswap32 d s = assert false + (* d = (s << 24) + | (((s >> 8) & 0xFF) << 16) + | (((s >> 16) & 0xFF) << 8) + | (s >> 24) *) +(*emit (Pslliw(X1, X s, coqint_of_camlint 24l)); + emit (Psrliw(X31, X s, _8)); + emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl)); + emit (Pslliw(X31, X X31, _16)); + emit (Porw(X1, X X1, X X31)); + emit (Psrliw(X31, X s, _16)); + emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl)); + emit (Pslliw(X31, X X31, _8)); + emit (Porw(X1, X X1, X X31)); + emit (Psrliw(X31, X s, coqint_of_camlint 24l)); + emit (Porw(d, X X1, X X31)) +*) + +let expand_bswap64 d s = assert false + (* d = s << 56 + | (((s >> 8) & 0xFF) << 48) + | (((s >> 16) & 0xFF) << 40) + | (((s >> 24) & 0xFF) << 32) + | (((s >> 32) & 0xFF) << 24) + | (((s >> 40) & 0xFF) << 16) + | (((s >> 48) & 0xFF) << 8) + | s >> 56 *) +(*emit (Psllil(X1, X s, coqint_of_camlint 56l)); + List.iter + (fun (n1, n2) -> + emit (Psrlil(X31, X s, coqint_of_camlint n1)); + emit (Pandil(X31, X X31, coqint_of_camlint 0xFFl)); + emit (Psllil(X31, X X31, coqint_of_camlint n2)); + emit (Porl(X1, X X1, X X31))) + [(8l,48l); (16l,40l); (24l,32l); (32l,24l); (40l,16l); (48l,8l)]; + emit (Psrlil(X31, X s, coqint_of_camlint 56l)); + emit (Porl(d, X X1, X X31)) +*) + +(* Handling of compiler-inlined builtins *) + +let expand_builtin_inline name args res = let open Asmblock in + match name, args, res with + (* Synchronization *) + | "__builtin_membar", [], _ -> + () + (* Vararg stuff *) + | "__builtin_va_start", [BA(IR a)], _ -> + expand_builtin_va_start a + | "__builtin_clzll", [BA(IR a)], BR(IR res) -> + emit (Pclzll(res, a)) + | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> + emit (Pstsud(res, a1, a2)) + (* Byte swaps *) +(*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + expand_bswap16 res a1 + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> + emit (Pfabsd(res, a1)) +*) + (* Catch-all *) + | _ -> + raise (Error ("unrecognized builtin " ^ name)) + +(* Expansion of instructions *) + +let expand_instruction instr = + match instr with + | Pallocframe (sz, ofs) -> + let sg = get_current_function_sig() in + emit (Pmv (Asmblock.GPR10, Asmblock.GPR12)); + if sg.sig_cc.cc_vararg then begin + let n = arguments_size sg in + let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in + let full_sz = Z.add sz (Z.of_uint extra_sz) in + expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg full_sz)); + expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs; + let va_ofs = + Z.add full_sz (Z.of_sint ((n - 8) * wordsize)) in + vararg_start_ofs := Some va_ofs; + save_arguments n va_ofs + end else begin + expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.neg sz)); + expand_storeind_ptr Asmblock.GPR10 Asmblock.GPR12 ofs; + vararg_start_ofs := None + end + | Pfreeframe (sz, ofs) -> + let sg = get_current_function_sig() in + let extra_sz = + if sg.sig_cc.cc_vararg then begin + let n = arguments_size sg in + if n >= 8 then 0 else align 16 ((8 - n) * wordsize) + end else 0 in + expand_addptrofs Asmblock.GPR12 Asmblock.GPR12 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + +(*| Pseqw(rd, rs1, rs2) -> + (* emulate based on the fact that x == 0 iff x <u 1 (unsigned cmp) *) + if rs2 = X0 then begin + emit (Psltiuw(rd, rs1, Int.one)) + end else begin + emit (Pxorw(rd, rs1, rs2)); emit (Psltiuw(rd, X rd, Int.one)) + end + | Psnew(rd, rs1, rs2) -> + (* emulate based on the fact that x != 0 iff 0 <u x (unsigned cmp) *) + if rs2 = X0 then begin + emit (Psltuw(rd, X0, rs1)) + end else begin + emit (Pxorw(rd, rs1, rs2)); emit (Psltuw(rd, X0, X rd)) + end + | Pseql(rd, rs1, rs2) -> + (* emulate based on the fact that x == 0 iff x <u 1 (unsigned cmp) *) + if rs2 = X0 then begin + emit (Psltiul(rd, rs1, Int64.one)) + end else begin + emit (Pxorl(rd, rs1, rs2)); emit (Psltiul(rd, X rd, Int64.one)) + end + | Psnel(rd, rs1, rs2) -> + (* emulate based on the fact that x != 0 iff 0 <u x (unsigned cmp) *) + if rs2 = X0 then begin + emit (Psltul(rd, X0, rs1)) + end else begin + emit (Pxorl(rd, rs1, rs2)); emit (Psltul(rd, X0, X rd)) + end +*)| Pcvtl2w (rd, rs) -> + assert Archi.ptr64; + emit (Paddiw (rd, rs, Int.zero)) (* 32-bit sign extension *) + | Pcvtw2l (r) -> (* Pcvtw2l *) + assert Archi.ptr64 + (* no-operation because the 32-bit integer was kept sign extended already *) + (* FIXME - is it really the case on the MPPA ? *) + +(*| Pjal_r(r, sg) -> + fixup_call sg; emit instr + | Pjal_s(symb, sg) -> + fixup_call sg; emit instr + | Pj_r(r, sg) when r <> X1 -> + fixup_call sg; emit instr + | Pj_s(symb, sg) -> + fixup_call sg; emit instr + +*)| Pbuiltin (ef,args,res) -> + begin match ef with + | EF_builtin (name,sg) -> + expand_builtin_inline (camlstring_of_coqstring name) args res + (*| EF_vload chunk -> + expand_builtin_vload chunk args res + | EF_vstore chunk -> + expand_builtin_vstore chunk args + | EF_annot_val (kind,txt,targ) -> + expand_annot_val kind txt targ args res + | EF_memcpy(sz, al) -> + expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args + | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + emit instr + *)| _ -> + assert false + end + | _ -> + emit instr + +(* NOTE: Dwarf register maps for RV32G are not yet specified + officially. This is just a placeholder. *) +let int_reg_to_dwarf = let open Asmblock in function + | GPR0 -> 1 | GPR1 -> 2 | GPR2 -> 3 | GPR3 -> 4 | GPR4 -> 5 + | GPR5 -> 6 | GPR6 -> 7 | GPR7 -> 8 | GPR8 -> 9 | GPR9 -> 10 + | GPR10 -> 11 | GPR11 -> 12 | GPR12 -> 13 | GPR13 -> 14 | GPR14 -> 15 + | GPR15 -> 16 | GPR16 -> 17 | GPR17 -> 18 | GPR18 -> 19 | GPR19 -> 20 + | GPR20 -> 21 | GPR21 -> 22 | GPR22 -> 23 | GPR23 -> 24 | GPR24 -> 25 + | GPR25 -> 26 | GPR26 -> 27 | GPR27 -> 28 | GPR28 -> 29 | GPR29 -> 30 + | GPR30 -> 31 | GPR31 -> 32 | GPR32 -> 33 | GPR33 -> 34 | GPR34 -> 35 + | GPR35 -> 36 | GPR36 -> 37 | GPR37 -> 38 | GPR38 -> 39 | GPR39 -> 40 + | GPR40 -> 41 | GPR41 -> 42 | GPR42 -> 43 | GPR43 -> 44 | GPR44 -> 45 + | GPR45 -> 46 | GPR46 -> 47 | GPR47 -> 48 | GPR48 -> 49 | GPR49 -> 50 + | GPR50 -> 51 | GPR51 -> 52 | GPR52 -> 53 | GPR53 -> 54 | GPR54 -> 55 + | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 + | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 + +let preg_to_dwarf = let open Asmblock in function + | IR r -> int_reg_to_dwarf r + | FR r -> int_reg_to_dwarf r + | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) + | _ -> assert false + +let expand_function id fn = + try + set_current_function fn; + if !Clflags.option_g then + expand_debug id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code + else + List.iter expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) + +let expand_fundef id = function + | Internal f -> + begin match expand_function id f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) + +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v new file mode 100644 index 00000000..9b9e6272 --- /dev/null +++ b/mppa_k1c/Asmgen.v @@ -0,0 +1,43 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +Require Import Integers. +Require Import Mach Asm Asmblock Asmblockgen Machblockgen. +Require Import Errors. + +Local Open Scope error_monad_scope. + +(** For OCaml code *) +Definition addptrofs (rd rs: ireg) (n: ptrofs) := basic_to_instruction (addptrofs rd rs n). +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := + basic_to_instruction (storeind_ptr src base ofs). + +Definition transf_program (p: Mach.program) : res Asm.program := + let mbp := Machblockgen.transf_program p in + do abp <- Asmblockgen.transf_program mbp; + OK (Asm.transf_program abp). + +Definition transf_function (f: Mach.function) : res Asm.function := + let mbf := Machblockgen.transf_function f in + do abf <- Asmblockgen.transf_function mbf; + OK (Asm.transf_function abf). + +Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruction) := + let mbf := Machblockgen.transf_function f in + let mbc := Machblockgen.trans_code l in + do abc <- transl_blocks mbf mbc true; + OK (unfold abc).
\ No newline at end of file diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v new file mode 100644 index 00000000..74be571d --- /dev/null +++ b/mppa_k1c/Asmgenproof.v @@ -0,0 +1,162 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. +Require Import Machblockgenproof Asmblockgenproof. + +Local Open Scope linking_scope. + +Definition block_passes := + mkpass Machblockgenproof.match_prog + ::: mkpass Asmblockgenproof.match_prog + ::: mkpass Asm.match_prog + ::: pass_nil _. + +Definition match_prog := pass_match (compose_passes block_passes). + +Lemma transf_program_match: + forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp. +Proof. + intros p tp H. + unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. + inversion_clear H. inversion H1. remember (Machblockgen.transf_program p) as mbp. + unfold match_prog; simpl. + exists mbp; split. apply Machblockgenproof.transf_program_match; auto. + exists x; split. apply Asmblockgenproof.transf_program_match; auto. + exists tp; split. apply Asm.transf_program_match; auto. auto. +Qed. + +(** Return Address Offset *) + +Definition return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := + Asmblockgenproof.return_address_offset (Machblockgen.transf_function f) (Machblockgen.trans_code c) ofs. + + +(* TODO: put this proof in Machblocgen ? (it is specific to Machblocgen) *) +Lemma trans_code_monotonic c i b l: + trans_code c = b::l -> + exists l', exists b', trans_code (i::c) = l' ++ (b'::l). +Proof. + destruct c as [|i' c]. { rewrite trans_code_equation; intros; congruence. } + destruct (get_code_nature (i :: i':: c)) eqn:GCNIC. + - apply get_code_nature_empty in GCNIC. discriminate. + - (* i=label *) + destruct i; try discriminate. + rewrite! trans_code_equation; + remember (to_bblock (Mlabel l0 :: i' :: c)) as b0. + destruct b0 as [b0 c0]. + exploit to_bblock_label; eauto. + intros (H1 & H2). rewrite H2; simpl; clear H2. + intros H2; inversion H2; subst. + exists nil; simpl; eauto. + - (*i=basic *) + rewrite! trans_code_equation; destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. + destruct (cn_eqdec (get_code_nature (i':: c)) IsLabel). + + (* i'=label *) remember (to_bblock (i :: i' :: c)) as b1. + destruct b1 as [b1 c1]. + assert (X: c1 = i'::c). + { generalize Heqb1; clear Heqb1. + unfold to_bblock. + erewrite to_bblock_header_noLabel; try congruence. + destruct i'; try discriminate. + destruct i; try discriminate; simpl; + intro X; inversion X; auto. + } + subst c1. + rewrite !trans_code_equation. intro H1; rewrite H1. + exists (b1 :: nil). simpl; eauto. + + (* i'<>label *) remember (to_bblock (i :: i' :: c)) as b1. + destruct b1 as [b1 c1]. + remember (to_bblock (i' :: c)) as b2. + destruct b2 as [b2 c2]. + intro H1; assert (X: c1=c2). + { generalize Heqb1, Heqb2; clear Heqb1 Heqb2. + unfold to_bblock. + erewrite to_bblock_header_noLabel; try congruence. + destruct i'; simpl in * |- ; try congruence; + destruct i; try discriminate; simpl; + try (destruct (to_bblock_body c) as [xx yy], (to_bblock_exit yy); + intros X1 X2; inversion X1; inversion X2; auto). + } + subst; inversion H1. + exists nil; simpl; eauto. + - (* i=cfi *) + remember (to_cfi i) as cfi. + intros H. destruct cfi. + + erewrite trans_code_cfi; eauto. + rewrite H. + refine (ex_intro _ (_::nil) _). simpl; eauto. + + destruct i; simpl in * |-; try congruence. +Qed. + +Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> + exists b, (* Machblock.exit b = Some (Machblock.MBcall sg ros) /\ *) + is_tail (b :: trans_code c) (trans_code c2). +Proof. + intro H; induction 1. + - intros; subst. + rewrite (trans_code_equation (Mcall sg ros :: c)). + simpl. + eapply ex_intro; eauto with coqlib. + - intros; exploit IHis_tail; eauto. clear IHis_tail. + intros (b & Hb). + + inversion Hb; clear Hb. + * exploit (trans_code_monotonic c2 i); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eauto with coqlib. + * exploit (trans_code_monotonic c2 i); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eapply ex_intro. + eapply is_tail_trans; eauto with coqlib. +Qed. + +Lemma return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. + exploit Mach_Machblock_tail; eauto. + destruct 1. + eapply Asmblockgenproof.return_address_exists; eauto. +Qed. + + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). +Proof. + unfold match_prog in TRANSF. simpl in TRANSF. + inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. + eapply compose_forward_simulations. + exploit Machblockgenproof.transf_program_correct; eauto. + unfold Machblockgenproof.inv_trans_rao. + intros X; apply X. + eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + apply Asm.transf_program_correct. eauto. +Qed. + +End PRESERVATION. + +Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). + diff --git a/mppa_k1c/Asmgenproof1.v b/mppa_k1c/Asmgenproof1.v new file mode 100644 index 00000000..bb39b4a5 --- /dev/null +++ b/mppa_k1c/Asmgenproof1.v @@ -0,0 +1,1585 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Errors Maps. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op Locations Mach Conventions. +Require Import Asm Asmgen Asmgenproof0. + +(** Decomposition of integer constants. *) + +Lemma make_immed32_sound: + forall n, + match make_immed32 n with + | Imm32_single imm => n = imm + end. +Proof. + intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). + predSpec Int.eq Int.eq_spec n lo; auto. +(* +- auto. +- set (m := Int.sub n lo). + assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto). + assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0). + { replace 0 with (Int.unsigned n - Int.unsigned n) by omega. + auto using Int.eqmod_sub, Int.eqmod_refl. } + assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0). + { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto. + apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr. + exists (two_p (32-12)); auto. } + assert (D: Int.modu m (Int.repr 4096) = Int.zero). + { apply Int.eqmod_mod_eq in C. unfold Int.modu. + change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C. + reflexivity. + apply two_p_gt_ZERO; omega. } + rewrite <- (Int.divu_pow2 m (Int.repr 4096) (Int.repr 12)) by auto. + rewrite Int.shl_mul_two_p. + change (two_p (Int.unsigned (Int.repr 12))) with 4096. + replace (Int.mul (Int.divu m (Int.repr 4096)) (Int.repr 4096)) with m. + unfold m. rewrite Int.sub_add_opp. rewrite Int.add_assoc. rewrite <- (Int.add_commut lo). + rewrite Int.add_neg_zero. rewrite Int.add_zero. auto. + rewrite (Int.modu_divu_Euclid m (Int.repr 4096)) at 1 by (vm_compute; congruence). + rewrite D. apply Int.add_zero. +*) +Qed. + +Lemma make_immed64_sound: + forall n, + match make_immed64 n with + | Imm64_single imm => n = imm +(*| Imm64_pair hi lo => n = Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo + | Imm64_large imm => n = imm +*)end. +Proof. + intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). + predSpec Int64.eq Int64.eq_spec n lo. +- auto. +- set (m := Int64.sub n lo). + set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). + predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). + auto. + auto. +Qed. + +(** Properties of registers *) + +Lemma ireg_of_not_GPR31: + forall m r, ireg_of m = OK r -> IR r <> IR GPR31. +Proof. + intros. erewrite <- ireg_of_eq; eauto with asmgen. +Qed. + +Lemma ireg_of_not_GPR31': + forall m r, ireg_of m = OK r -> r <> GPR31. +Proof. + intros. apply ireg_of_not_GPR31 in H. congruence. +Qed. + +Hint Resolve ireg_of_not_GPR31 ireg_of_not_GPR31': asmgen. + +(** Useful simplification tactic *) + +Ltac Simplif := + ((rewrite nextinstr_inv by eauto with asmgen) + || (rewrite nextinstr_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextinstr_pc) + || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(** * Correctness of RISC-V constructor functions *) + +Section CONSTRUCTORS. + +Variable ge: genv. +Variable fn: function. + +(** 32-bit integer constants and arithmetic *) +(* +Lemma load_hilo32_correct: + forall rd hi lo k rs m, + exists rs', + exec_straight ge fn (load_hilo32 rd hi lo k) rs m k rs' m + /\ rs'#rd = Vint (Int.add (Int.shl hi (Int.repr 12)) lo) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold load_hilo32; intros. + predSpec Int.eq Int.eq_spec lo Int.zero. +- subst lo. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int.add_zero. Simpl. + intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. + 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. Simpl. + 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 <> GPR31 -> 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. Simpl. + intros; Simpl. +Qed. + +(* +Lemma opimm32_correct: + forall (op: ireg -> ireg0 -> ireg0 -> instruction) + (opi: ireg -> ireg0 -> int -> instruction) + (sem: val -> val -> val) m, + (forall d s1 s2 rs, + exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs##s1 rs##s2))) m) -> + (forall d s n rs, + exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs##s (Vint n)))) m) -> + forall rd r1 n k rs, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (opimm32 op opi rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs##r1 (Vint n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. unfold opimm32. generalize (make_immed32_sound n); intros E. + destruct (make_immed32 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +- destruct (load_hilo32_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) + as (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite H; eauto. auto. + split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. + intros; Simpl. +Qed. + +(** 64-bit integer constants and arithmetic *) + +Lemma load_hilo64_correct: + forall rd hi lo k rs m, + exists rs', + exec_straight ge fn (load_hilo64 rd hi lo k) rs m k rs' m + /\ rs'#rd = Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold load_hilo64; intros. + predSpec Int64.eq Int64.eq_spec lo Int64.zero. +- subst lo. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. rewrite Int64.add_zero. Simpl. + intros; Simpl. +- econstructor; split. + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. + split. Simpl. + intros; Simpl. +Qed. +*) + +Lemma opimm64_correct: + forall (op: arith_name_rrr) + (opi: arith_name_rri64) + (sem: val -> val -> val) m, + (forall d s1 s2 rs, + exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs###s1 rs###s2))) m) -> + (forall d s n rs, + exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs###s (Vlong n)))) m) -> + forall rd r1 n k rs, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (opimm64 op opi rd r1 n k) rs m k rs' m + /\ rs'#rd = sem rs##r1 (Vlong n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. unfold opimm64. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +(* +- destruct (load_hilo64_correct GPR31 hi lo (op rd r1 GPR31 :: k) rs m) + as (rs' & A & B & C). + econstructor; split. + eapply exec_straight_trans. eexact A. apply exec_straight_one. + rewrite H; eauto. auto. + split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. + intros; Simpl. +- subst imm. econstructor; split. + eapply exec_straight_two. simpl; eauto. rewrite H. simpl; eauto. auto. auto. + split. Simpl. intros; Simpl. +*) +Qed. + +(** Add offset to pointer *) + +Lemma addptrofs_correct: + forall rd r1 n k rs m, + r1 <> GPR31 -> + exists rs', + exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m + /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold addptrofs; intros. + destruct (Ptrofs.eq_dec n Ptrofs.zero). +- subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. + intros; Simpl. +- unfold addimm64. + exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. + rewrite B. unfold getw. destruct (rs r1); simpl; auto. + rewrite Ptrofs.of_int64_to_int64 by auto. auto. +Qed. +(* +Lemma addptrofs_correct_2: + forall rd r1 n k (rs: regset) m b ofs, + r1 <> GPR31 -> rs#r1 = Vptr b of +s -> + exists rs', + exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m + /\ rs'#rd = Vptr b (Ptrofs.add ofs n) + /\ forall r, r <> PC -> r <> rd -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C). + exists rs'; intuition eauto. + rewrite H0 in B. inv B. auto. +Qed. + +(** Translation of conditional branches *) + +Remark branch_on_GPR31: + forall normal lbl (rs: regset) m b, + rs#GPR31 = Val.of_bool (eqb normal b) -> + exec_instr ge fn (if normal then Pbnew GPR31 X0 lbl else Pbeqw GPR31 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 + | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args + | [ H: bind _ _ = OK _ |- _ ] => monadInv H + | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + end); + subst; + repeat (match goal with + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * + | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * + end). + +Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight ge fn c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Remark exec_straight_opt_right: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> + exec_straight ge fn c2 rs2 m2 c3 rs3 m3 -> + exec_straight ge fn c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma transl_comp_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Signed) rs ## r1 rs ## r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs##r1 rs##r2) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compu_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_int (itest_for_cmp cmp Unsigned) rs ## r1 rs ## r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 rs##r2) as cmpubool. + destruct cmp; simpl; unfold Val.cmpu; rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compl_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Signed) rs ### r1 rs ### r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs###r1 rs###r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmpl; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_complu_correct: + forall cmp r1 r2 lbl k rs m b, + exists rs', + exec_straight ge fn (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez GPR31 lbl ::i k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2 = Some b -> + exec_instr ge fn (Pcb BTwnez GPR31 lbl) rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (nextinstr rs # GPR31 <- (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)) as rs'. + simpl. assert (Val.cmp_bool Cne rs' ## GPR31 (Vint (Int.repr 0)) = Some b). + { + assert (rs' ## GPR31 = (compare_long (itest_for_cmp cmp Unsigned) rs ### r1 rs ### r2 m)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 rs###r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long; + unfold Val.cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_opt_compuimm_correct: + forall n cmp r1 lbl k rs m b c, + select_comp n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m (insn :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpu_bool (Mem.valid_pointer m) cmp rs##r1 (Vint n) = Some b -> + exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. + unfold transl_opt_compuimm; rewrite H; simpl. + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + + exists rs, (Pcbu BTweqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) + auto; + unfold eval_branch. unfold getw. rewrite H0 in H2. unfold getw in H2. + rewrite H1. rewrite H2; auto. + - (* c = Cne *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + exists rs, (Pcbu BTwnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite <- H0. rewrite H1. rewrite H2. auto. + - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_opt_compluimm_correct: + forall n cmp r1 lbl k rs m b c, + select_compl n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m (insn :: k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmplu_bool (Mem.valid_pointer m) cmp rs###r1 (Vlong n) = Some b -> + exec_instr ge fn insn rs' m = eval_branch fn lbl rs' m (Some b)) + . +Proof. + intros. + unfold transl_opt_compluimm; rewrite H; simpl. + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + + exists rs, (Pcbu BTdeqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + - (* c = Cne *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + exists rs, (Pcbu BTdnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + auto; + unfold eval_branch. rewrite H1. rewrite <- H0. destruct b; rewrite H2; auto. + - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_cbranch_correct_1: + forall cond args lbl k c m ms b sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some b -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' (insn :: k) rs' m' + /\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b) + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros TRANSL EVAL AG MEXT. + set (vl' := map rs (map preg_of args)). + assert (EVAL': eval_condition cond vl' m' = Some b). + { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } + clear EVAL MEXT AG. + destruct cond; simpl in TRANSL; ArgsInv. +(* Ccomp *) +- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompu *) +- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompimm *) +- remember (Int.eq n Int.zero) as eqz. + destruct eqz. + + assert (n = (Int.repr 0)). { + destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. + generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpswz c0) x lbl). + split. + * constructor. + * split; auto. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; unfold getw; rewrite EVAL'; auto. + + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_comp_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +(* Ccompuimm *) +- remember (select_comp n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + unfold transl_opt_compuimm. rewrite <- Heqselcomp; simpl. + exploit (loadimm32_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_comp c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getw. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +(* Ccompl *) +- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplu *) +- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez GPR31 lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplimm *) +- remember (Int64.eq n Int64.zero) as eqz. + destruct eqz. + + assert (n = (Int64.repr 0)). { + destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. + generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). + split. + * constructor. + * split; auto. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; unfold getl; rewrite EVAL'; auto. + + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_compl_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Signed x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } + +(* Ccompluimm *) +- remember (select_compl n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + unfold transl_opt_compluimm. rewrite <- Heqselcomp; simpl. + exploit (loadimm64_correct GPR31 n); eauto. intros (rs' & A & B & C). + exploit (transl_complu_correct c0 x GPR31 lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez GPR31 lbl). + split. + * constructor. apply exec_straight_trans + with (c2 := (transl_compl c0 Unsigned x GPR31 lbl k)) (rs2 := rs') (m2 := m'). + eexact A. eexact A'. + * split; auto. + { apply C'; auto. unfold getl. rewrite B, C; eauto with asmgen. } + { intros. rewrite B'; eauto with asmgen. } +Qed. + +Lemma transl_cbranch_correct_true: + forall cond args lbl k c m ms sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some true -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' (insn :: k) rs' m' + /\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. + +Lemma transl_cbranch_correct_false: + forall cond args lbl k c m ms sp rs m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some false -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', + exec_straight ge fn c rs m' k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. exploit transl_cbranch_correct_1; eauto. simpl. + intros (rs' & insn & A & B & C). + exists (nextinstr rs'). + split. eapply exec_straight_opt_right; eauto. apply exec_straight_one; auto. + 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. +- 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. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +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. 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. +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. +- 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. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto|auto]. + split; intros; Simpl. +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. 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. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + 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 <> GPR31 -> 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. 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. +Qed. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + 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 <> GPR31 -> 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. 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. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + 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 <> GPR31 -> 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. 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. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> GPR31 -> + 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 <> GPR31 -> 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. 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. +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 <> GPR31 -> 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. +Qed. + +(* ++ (* 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. +*) + +(** 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. + +Lemma cast32signed_correct: + forall (d s: ireg) (k: code) (rs: regset) (m: mem), + exists rs': regset, + exec_straight ge fn (cast32signed d s k) rs m k rs' m + /\ Val.lessdef (Val.longofint (rs s)) (rs' d) + /\ (forall r: preg, r <> PC -> r <> d -> rs' r = rs r). +Proof. + intros. unfold cast32signed. destruct (ireg_eq d s). +- econstructor; split. + + apply exec_straight_one. simpl. eauto with asmgen. Simpl. + + split. + * rewrite e. Simpl. + * intros. destruct r; Simpl. +- econstructor; split. + + apply exec_straight_one. simpl. eauto with asmgen. Simpl. + + split. + * Simpl. + * intros. destruct r; Simpl. +Qed. + +(* Translation of arithmetic operations *) + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inv H + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; [simpl; eauto | reflexivity] + | split; [ apply Val.lessdef_same; Simpl; fail | intros; Simpl; fail ] ]. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. + assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } +Opaque Int.eq. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +- (* Omove *) + destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Oaddrsymbol *) + 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. +- (* Oaddrstack *) + exploit addptrofs_correct. instantiate (1 := GPR12); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* Ocast8signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. + split; intros; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. unfold getw. + destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* Ocast16signed *) + 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. unfold getw. + destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* Oshrximm *) + clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. 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; unfold getw; Simpl. +- (* Ocast32signed *) + exploit cast32signed_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. split. apply B. + intros. assert (r <> PC). { destruct r; auto; contradict H; discriminate. } + apply C; auto. +- (* longofintu *) + econstructor; split. + eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. + split; intros; Simpl. unfold getl; unfold Pregmap.set; Simpl. destruct (PregEq.eq x0 x0). + + 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. + + contradict n. auto. +- (* Ocmp *) + exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. +(* +- (* 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. +- (* stackoffset *) + exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* 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. + + + +- (* 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 *) + clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV. + destruct (Int.eq n Int.zero). ++ econstructor; split. apply exec_straight_one. simpl; eauto. 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. +*) +Qed. + + +(** Memory accesses *) + +Lemma indexed_memory_access_correct: + forall mk_instr base ofs k rs m, + base <> GPR31 -> + exists base' ofs' rs', + exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m + (mk_instr base' ofs' :: k) rs' m + /\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + unfold indexed_memory_access; intros. + (* destruct Archi.ptr64 eqn:SF. *) + assert (Archi.ptr64 = true) as SF; auto. +- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. + destruct (make_immed64 (Ptrofs.to_int64 ofs)). ++ econstructor; econstructor; econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. +(* ++ econstructor; econstructor; econstructor; split. + constructor. eapply exec_straight_two. + simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. + rewrite Ptrofs.add_assoc. f_equal. f_equal. + rewrite <- (Ptrofs.of_int64_to_int64 SF ofs). rewrite EQ. + symmetry; auto with ptrofs. ++ econstructor; econstructor; econstructor; split. + constructor. eapply exec_straight_two. + simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. unfold eval_offset. destruct (rs base); auto; simpl. rewrite SF. simpl. + rewrite Ptrofs.add_zero. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. +(* 32 bits part, irrelevant for us +- generalize (make_immed32_sound (Ptrofs.to_int ofs)); intros EQ. + destruct (make_immed32 (Ptrofs.to_int ofs)). ++ econstructor; econstructor; econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. subst imm. rewrite Ptrofs.of_int_to_int by auto. auto. ++ econstructor; econstructor; econstructor; split. + constructor. eapply exec_straight_two. + simpl; eauto. simpl; eauto. auto. auto. + split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. + rewrite Ptrofs.add_assoc. f_equal. f_equal. + rewrite <- (Ptrofs.of_int_to_int SF ofs). rewrite EQ. + symmetry; auto with ptrofs. +*)*) +Qed. + +Lemma indexed_load_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) rd m, + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + forall (base: ireg) ofs k (rs: regset) v, + Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> rd <> PC -> + exists rs', + exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until v; intros LOAD NOT31 NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_load. rewrite B, LOAD. eauto. Simpl. + split; intros; Simpl. +Qed. + +Lemma indexed_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) r1 m, + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + forall (base: ireg) ofs k (rs: regset) m', + Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> + base <> GPR31 -> r1 <> GPR31 -> r1 <> PC -> + exists rs', + exec_straight ge fn (indexed_memory_access mk_instr base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until m'; intros STORE NOT31 NOT31' NOTPC. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_store. rewrite B, C, STORE by auto. eauto. auto. + intros; Simpl. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k c (rs: regset) m v, + loadind base ofs ty dst k = OK c -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR LOAD NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs k + /\ forall base' ofs' rs', + exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_load ge (chunk_of_type ty) rs' m (preg_of dst) base' ofs'). + { unfold loadind in TR. + destruct ty, (preg_of dst); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_load_access_correct; eauto with asmgen. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k c (rs: regset) m m', + storeind src base ofs ty k = OK c -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> + base <> GPR31 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR STORE NOT31. + assert (A: exists mk_instr, + c = indexed_memory_access mk_instr base ofs k + /\ forall base' ofs' rs', + exec_instr ge fn (mk_instr base' ofs') rs' m = + exec_store ge (chunk_of_type ty) rs' m (preg_of src) base' ofs'). + { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; split; eauto. } + destruct A as (mk_instr & B & C). subst c. + eapply indexed_store_access_correct; eauto with asmgen. +Qed. + + +Lemma Pget_correct: + forall (dst: gpreg) (src: preg) k (rs: regset) m, + src = RA -> + exists rs', + exec_straight ge fn (Pget dst src ::i k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor. +- simpl. rewrite H. auto. +- Simpl. +- Simpl. +- intros. rewrite H. Simpl. +Qed. + +Lemma Pset_correct: + forall (dst: preg) (src: gpreg) k (rs: regset) m, + dst = RA -> + exists rs', + exec_straight ge fn (Pset dst src ::i k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor; simpl. + rewrite H. auto. + Simpl. + Simpl. + intros. rewrite H. Simpl. +Qed. + +Lemma loadind_ptr_correct: + forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> + base <> GPR31 -> + exists rs', + exec_straight ge fn (loadind_ptr base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> dst -> rs'#r = rs#r. +Proof. + intros. eapply indexed_load_access_correct; eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H1. auto. +Qed. + +Lemma storeind_ptr_correct: + forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', + Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + base <> GPR31 -> src <> GPR31 -> + exists rs', + exec_straight ge fn (storeind_ptr src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true); auto. +Qed. + +Lemma transl_memory_access_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ofs rs', + exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m + /\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access in TR; destruct addr; ArgsInv. +- (* indexed *) + inv EV. apply indexed_memory_access_correct; eauto with asmgen. +- (* global *) + simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; split. + constructor. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. unfold eval_offset. + assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). + { apply Val.offset_ptr_zero. } + remember (Genv.symbol_address ge i i0) as symbol. + destruct symbol; auto. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + simpl. rewrite Ptrofs.add_zero; auto. +- (* stack *) + inv TR. inv EV. apply indexed_memory_access_correct; eauto with asmgen. +Qed. + +Lemma transl_load_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c rd (rs: regset) m v v', + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = Some v' -> + rd <> PC -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> GPR31 -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros INSTR TR EV LOAD NOTPC. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. +Qed. + +Lemma transl_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> instruction) addr args k c r1 (rs: regset) m v m', + (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk rs m r1 base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.storev chunk m v rs#r1 = Some m' -> + r1 <> PC -> r1 <> GPR31 -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros INSTR TR EV STORE NOTPC NOT31. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & A & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_store. rewrite B, C, STORE by auto. reflexivity. auto. + intros; Simpl. +Qed. + +Lemma transl_load_correct: + forall chunk addr args dst k c (rs: regset) m a v, + transl_load chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight ge fn c rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR31 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV LOAD. + assert (A: exists mk_instr, + transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_load ge chunk rs m (preg_of dst) base ofs). + { unfold transl_load in TR; destruct chunk; ArgsInv; econstructor; (split; [eassumption|auto]). } + destruct A as (mk_instr & B & C). + eapply transl_load_access_correct; eauto with asmgen. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m a m', + transl_store chunk addr args src k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge fn c rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR31 -> rs'#r = rs#r. +Proof. + intros until m'; intros TR EV STORE. + assert (A: exists mk_instr chunk', + transl_memory_access mk_instr addr args k = OK c + /\ (forall base ofs rs, + exec_instr ge fn (mk_instr base ofs) rs m = exec_store ge chunk' rs m (preg_of src) base ofs) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src)). + { unfold transl_store in TR; destruct chunk; ArgsInv; + (econstructor; econstructor; split; [eassumption | split; [ intros; simpl; reflexivity | auto]]). + destruct a; auto. apply Mem.store_signed_unsigned_8. + destruct a; auto. apply Mem.store_signed_unsigned_16. + } + destruct A as (mk_instr & chunk' & B & C & D). + rewrite D in STORE; clear D. + eapply transl_store_access_correct; eauto with asmgen. +Qed. + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs k tm, + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge fn (make_epilogue f k) rs tm k rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> GPR31 -> r <> GPR8 -> rs'#r = rs#r). +Proof. + intros until tm; intros LP LRA FREE AG MEXT MCS. + exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). + exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). + exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. + exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. + exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). + unfold make_epilogue. + rewrite chunk_of_Tptr in *. + + exploit (loadind_ptr_correct SP (fn_retaddr_ofs f) GPR8 (Pset RA GPR8 + ::i Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs tm). + - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. + - congruence. + - intros (rs1 & A1 & B1 & C1). + assert (agree ms (Vptr stk soff) rs1) as AG1. + + destruct AG. + apply mkagree; auto. + rewrite C1; discriminate || auto. + intro. rewrite C1; auto; destruct r; simpl; try discriminate. + + exploit (Pset_correct RA GPR8 (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::i k) rs1 tm). auto. + intros (rs2 & A2 & B2 & C2). + econstructor; econstructor; split. + * eapply exec_straight_trans. + { eexact A1. } + { eapply exec_straight_trans. + { eapply A2. } + { apply exec_straight_one. simpl. + rewrite (C2 GPR12) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. + rewrite FREE'; eauto. auto. } } + * split. apply agree_nextinstr. apply agree_set_other; auto with asmgen. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. rewrite B2. auto. + split. Simpl. + intros. Simpl. + rewrite C2; auto. +Qed. + +End CONSTRUCTORS. + + + diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml new file mode 100644 index 00000000..a5bdaa28 --- /dev/null +++ b/mppa_k1c/CBuiltins.ml @@ -0,0 +1,128 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Processor-dependent builtin C functions *) + +open C + +let builtins = { + Builtins.typedefs = [ + "__builtin_va_list", TPtr(TVoid [], []) + ]; + (* The builtin list is inspired from the GCC file builtin_k1.h *) + Builtins.functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) + (* BCU Instructions *) + "__builtin_k1_await", (TVoid [], [], false); + "__builtin_k1_barrier", (TVoid [], [], false); + "__builtin_k1_doze", (TVoid [], [], false); + (* No __builtin_k1_get - not compatible with the Asm model *) + "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); + "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); + "__builtin_k1_invaldtlb", (TVoid [], [], false); + "__builtin_k1_invalitlb", (TVoid [], [], false); + "__builtin_k1_probetlb", (TVoid [], [], false); + "__builtin_k1_readtlb", (TVoid [], [], false); + "__builtin_k1_sleep", (TVoid [], [], false); + "__builtin_k1_stop", (TVoid [], [], false); + "__builtin_k1_syncgroup", (TVoid [], [TInt(IUInt, [])], false); + "__builtin_k1_tlbwrite", (TVoid [], [], false); + + (* LSU Instructions *) + (* No ACWS - __int128 *) + "__builtin_k1_afda", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); + "__builtin_k1_aldc", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_dinval", (TVoid [], [], false); + "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_fence", (TVoid [], [], false); + "__builtin_k1_iinval", (TVoid [], [], false); + "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); + "__builtin_k1_lbsu", (TInt(IChar, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lbzu", (TInt(IUChar, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lhsu", (TInt(IShort, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lhzu", (TInt(IUShort, []), [TPtr(TVoid [], [])], false); + "__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); + + (* ALU Instructions *) + (* "__builtin_k1_addhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_k1_adds", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_k1_bwlu", (TInt(IUInt, []), + [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUShort, [])], false); *) + (* "__builtin_k1_bwluhp", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_bwluwp", (TInt(IULongLong, []), + [TInt(IULongLong, []); TInt(IULongLong, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *) + (* "__builtin_k1_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_k1_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) + "__builtin_k1_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_k1_clzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + (* "__builtin_k1_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_k1_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_k1_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) + "__builtin_k1_ctzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_k1_ctzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + (* "__builtin_k1_ctzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_k1_extfz", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_landhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_k1_sat", (TInt(IInt, []), [TInt(IInt, []); TInt(IUChar, [])], false); *) + "__builtin_k1_satd", (TInt(ILongLong, []), [TInt(ILongLong, []); TInt(IUChar, [])], false); + (* "__builtin_k1_sbfhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + "__builtin_k1_sbmm8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + "__builtin_k1_sbmmt8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + (* "__builtin_k1_sllhps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_srahps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_k1_stsu", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + "__builtin_k1_stsud", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + + + (* Synchronization *) +(* "__builtin_fence", + (TVoid [], [], false); + (* Integer arithmetic *) + "__builtin_bswap64", + (TInt(IULongLong, []), + [TInt(IULongLong, [])], false); + (* Float arithmetic *) + "__builtin_fmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fnmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fnmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmax", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmin", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, [])], false); +*)] +} + +let va_list_type = TPtr(TVoid [], []) (* to check! *) +let size_va_list = if Archi.ptr64 then 8 else 4 +let va_list_scalar = true + +(* Expand memory references inside extended asm statements. Used in C2C. *) + +let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/mppa_k1c/CombineOp.v b/mppa_k1c/CombineOp.v new file mode 100644 index 00000000..6236f38f --- /dev/null +++ b/mppa_k1c/CombineOp.v @@ -0,0 +1,138 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Op. +Require Import CSEdomain. + +Section COMBINE. + +Variable get: valnum -> option rhs. + +Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (c, ys) + | _ => None + end. + +Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) + | _ => None + end. + +Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (c, ys) + | _ => None + end. + +Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) + | _ => None + end. + +Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) := + match cond, args with + | Ccompimm Cne n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_ne_0 x + else if Int.eq_dec n Int.one then combine_compimm_ne_1 x + else None + | Ccompimm Ceq n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_eq_0 x + else if Int.eq_dec n Int.one then combine_compimm_eq_1 x + else None + | Ccompuimm Cne n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_ne_0 x + else if Int.eq_dec n Int.one then combine_compimm_ne_1 x + else None + | Ccompuimm Ceq n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_eq_0 x + else if Int.eq_dec n Int.one then combine_compimm_eq_1 x + else None + | _, _ => None + end. + +Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := + match addr, args with + | Aindexed n, x::nil => + match get x with + | Some(Op (Oaddimm m) ys) => + if Archi.ptr64 then None else Some(Aindexed (Ptrofs.add (Ptrofs.of_int m) n), ys) + | Some(Op (Oaddlimm m) ys) => + if Archi.ptr64 then Some(Aindexed (Ptrofs.add (Ptrofs.of_int64 m) n), ys) else None + | _ => None + end + | _, _ => None + end. + +Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) := + match op, args with + | Oaddimm n, x :: nil => + match get x with + | Some(Op (Oaddimm m) ys) => Some(Oaddimm (Int.add m n), ys) + | _ => None + end + | Oandimm n, x :: nil => + match get x with + | Some(Op (Oandimm m) ys) => + Some(let p := Int.and m n in + if Int.eq p m then (Omove, x :: nil) else (Oandimm p, ys)) + | _ => None + end + | Oorimm n, x :: nil => + match get x with + | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys) + | _ => None + end + | Oxorimm n, x :: nil => + match get x with + | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys) + | _ => None + end + | Oaddlimm n, x :: nil => + match get x with + | Some(Op (Oaddlimm m) ys) => Some(Oaddlimm (Int64.add m n), ys) + | _ => None + end + | Oandlimm n, x :: nil => + match get x with + | Some(Op (Oandlimm m) ys) => + Some(let p := Int64.and m n in + if Int64.eq p m then (Omove, x :: nil) else (Oandlimm p, ys)) + | _ => None + end + | Oorlimm n, x :: nil => + match get x with + | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys) + | _ => None + end + | Oxorlimm n, x :: nil => + match get x with + | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys) + | _ => None + end + | Ocmp cond, _ => + match combine_cond cond args with + | Some(cond', args') => Some(Ocmp cond', args') + | None => None + end + | _, _ => None + end. + +End COMBINE. diff --git a/mppa_k1c/CombineOpproof.v b/mppa_k1c/CombineOpproof.v new file mode 100644 index 00000000..a24de1e5 --- /dev/null +++ b/mppa_k1c/CombineOpproof.v @@ -0,0 +1,173 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import FunInd. +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import CSEdomain. +Require Import CombineOp. + +Section COMBINE. + +Variable ge: genv. +Variable sp: val. +Variable m: mem. +Variable get: valnum -> option rhs. +Variable valu: valnum -> val. +Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v). + +Lemma get_op_sound: + forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v). +Proof. + intros. exploit get_sound; eauto. intros REV; inv REV; auto. +Qed. + +Ltac UseGetSound := + match goal with + | [ H: get _ = Some _ |- _ ] => + let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv) + end. + +Lemma combine_compimm_ne_0_sound: + forall x cond args, + combine_compimm_ne_0 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero). +Proof. + intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_eq_0_sound: + forall x cond args, + combine_compimm_eq_0 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero). +Proof. + intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + rewrite eval_negate_condition. + destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_eq_1_sound: + forall x cond args, + combine_compimm_eq_1 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one). +Proof. + intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_ne_1_sound: + forall x cond args, + combine_compimm_ne_1 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one). +Proof. + intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + rewrite eval_negate_condition. + destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Theorem combine_cond_sound: + forall cond args cond' args', + combine_cond get cond args = Some(cond', args') -> + eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m. +Proof. + intros. functional inversion H; subst. + (* compimm ne zero *) + - simpl; eapply combine_compimm_ne_0_sound; eauto. + (* compimm ne one *) + - simpl; eapply combine_compimm_ne_1_sound; eauto. + (* compimm eq zero *) + - simpl; eapply combine_compimm_eq_0_sound; eauto. + (* compimm eq one *) + - simpl; eapply combine_compimm_eq_1_sound; eauto. + (* compuimm ne zero *) + - simpl; eapply combine_compimm_ne_0_sound; eauto. + (* compuimm ne one *) + - simpl; eapply combine_compimm_ne_1_sound; eauto. + (* compuimm eq zero *) + - simpl; eapply combine_compimm_eq_0_sound; eauto. + (* compuimm eq one *) + - simpl; eapply combine_compimm_eq_1_sound; eauto. +Qed. + +Theorem combine_addr_sound: + forall addr args addr' args', + combine_addr get addr args = Some(addr', args') -> + eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args). +Proof. + intros. functional inversion H; subst. +- (* indexed - addimm *) + UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. + rewrite Ptrofs.add_assoc. auto. +- (* indexed - addimml *) + UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. + rewrite Ptrofs.add_assoc. auto. +Qed. + +Theorem combine_op_sound: + forall op args op' args', + combine_op get op args = Some(op', args') -> + eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m. +Proof. + intros. functional inversion H; subst. + (* addimm - addimm *) + - UseGetSound. FuncInv. simpl. + rewrite <- H0. rewrite Val.add_assoc. auto. + (* andimm - andimm *) + - UseGetSound; simpl. + generalize (Int.eq_spec p m0); rewrite H7; intros. + rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto. + - UseGetSound; simpl. + rewrite <- H0. rewrite Val.and_assoc. auto. + (* orimm - orimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto. + (* xorimm - xorimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto. + (* addlimm - addlimm *) + - UseGetSound. FuncInv. simpl. + rewrite <- H0. rewrite Val.addl_assoc. auto. + (* andlimm - andlimm *) + - UseGetSound; simpl. + generalize (Int64.eq_spec p m0); rewrite H7; intros. + rewrite <- H0. rewrite Val.andl_assoc. simpl. fold p. rewrite H1. auto. + - UseGetSound; simpl. + rewrite <- H0. rewrite Val.andl_assoc. auto. + (* orlimm - orlimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.orl_assoc. auto. + (* xorlimm - xorlimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto. + (* cmp *) + - simpl. decEq; decEq. eapply combine_cond_sound; eauto. +Qed. + +End COMBINE. diff --git a/mppa_k1c/ConstpropOp.v b/mppa_k1c/ConstpropOp.v new file mode 100644 index 00000000..e7391ab5 --- /dev/null +++ b/mppa_k1c/ConstpropOp.v @@ -0,0 +1,613 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Strength reduction for operators and conditions. + This is the machine-dependent part of [Constprop]. *) + +Require Archi. +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. +Require Import ValueDomain. + +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => if Archi.ptr64 then Some(Olongconst n) else None + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + +(** * Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +(** Original definition: +<< +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list aval) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c n2, r1 :: nil) + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. +>> +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list aval), Type := + | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | cond_strength_reduction_case5: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | cond_strength_reduction_case6: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompl c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | cond_strength_reduction_case7: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | cond_strength_reduction_case8: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomplu c) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list aval), cond_strength_reduction_cases cond args vl. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list aval) := + match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2 + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2 + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2 + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2 + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case5 c r1 r2 n1 v2 + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case6 c r1 r2 v1 n2 + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => cond_strength_reduction_case7 c r1 r2 n1 v2 + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => cond_strength_reduction_case8 c r1 r2 v1 n2 + | cond, args, vl => cond_strength_reduction_default cond args vl + end. + +Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list aval) := + match cond_strength_reduction_match cond args vl with + | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompimm c n2, r1 :: nil) + | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + (Ccompuimm c n2, r1 :: nil) + | cond_strength_reduction_case5 c r1 r2 n1 v2 => (* Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case6 c r1 r2 v1 n2 => (* Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Ccomplimm c n2, r1 :: nil) + | cond_strength_reduction_case7 c r1 r2 n1 v2 => (* Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | cond_strength_reduction_case8 c r1 r2 v1 n2 => (* Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + (Ccompluimm c n2, r1 :: nil) + | cond_strength_reduction_default cond args vl => + (cond, args) + end. + + +Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +(** Original definition: +<< +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. +>> +*) + +Inductive make_cmp_cases: forall (c: condition) (args: list reg) (vl: list aval), Type := + | make_cmp_case1: forall n r1 v1, make_cmp_cases (Ccompimm Ceq n) (r1 :: nil) (v1 :: nil) + | make_cmp_case2: forall n r1 v1, make_cmp_cases (Ccompimm Cne n) (r1 :: nil) (v1 :: nil) + | make_cmp_case3: forall n r1 v1, make_cmp_cases (Ccompuimm Ceq n) (r1 :: nil) (v1 :: nil) + | make_cmp_case4: forall n r1 v1, make_cmp_cases (Ccompuimm Cne n) (r1 :: nil) (v1 :: nil) + | make_cmp_default: forall (c: condition) (args: list reg) (vl: list aval), make_cmp_cases c args vl. + +Definition make_cmp_match (c: condition) (args: list reg) (vl: list aval) := + match c as zz1, args as zz2, vl as zz3 return make_cmp_cases zz1 zz2 zz3 with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case1 n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case2 n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case3 n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case4 n r1 v1 + | c, args, vl => make_cmp_default c args vl + end. + +Definition make_cmp (c: condition) (args: list reg) (vl: list aval) := + match make_cmp_match c args vl with + | make_cmp_case1 n r1 v1 => (* Ccompimm Ceq n, r1 :: nil, v1 :: nil *) + make_cmp_imm_eq c args vl n r1 v1 + | make_cmp_case2 n r1 v1 => (* Ccompimm Cne n, r1 :: nil, v1 :: nil *) + make_cmp_imm_ne c args vl n r1 v1 + | make_cmp_case3 n r1 v1 => (* Ccompuimm Ceq n, r1 :: nil, v1 :: nil *) + make_cmp_imm_eq c args vl n r1 v1 + | make_cmp_case4 n r1 v1 => (* Ccompuimm Cne n, r1 :: nil, v1 :: nil *) + make_cmp_imm_ne c args vl n r1 v1 + | make_cmp_default c args vl => + make_cmp_base c args vl + end. + + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) + else (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) + else (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) + else (Oshru, r1 :: r2 :: nil). + +Definition make_mulimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshlimm l, r1 :: nil) + | None => (Omul, r1 :: r2 :: nil) + end. + +Definition make_andimm (n: int) (r: reg) (a: aval) := + if Int.eq n Int.zero then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero + | _ => false end + then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Definition make_divimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshruimm l, r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) + end. + +Definition make_addlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero + then (Omove, r :: nil) + else (Oaddlimm n, r :: nil). + +Definition make_shllimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) + else (Oshll, r1 :: r2 :: nil). + +Definition make_shrlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) + else (Oshrl, r1 :: r2 :: nil). + +Definition make_shrluimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) + else (Oshrlu, r1 :: r2 :: nil). + +Definition make_mullimm (n: int64) (r1 r2: reg) := + if Int64.eq n Int64.zero then + (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.one then + (Omove, r1 :: nil) + else + match Int64.is_power2' n with + | Some l => (Oshllimm l, r1 :: nil) + | None => (Omull, r1 :: r2 :: nil) + end. + +Definition make_andlimm (n: int64) (r: reg) (a: aval) := + if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.mone then (Omove, r :: nil) + else (Oandlimm n, r :: nil). + +Definition make_orlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) + else (Oorlimm n, r :: nil). + +Definition make_xorlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else (Oxorlimm n, r :: nil). + +Definition make_divlimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => if Int.ltu l (Int.repr 63) + then (Oshrxlimm l, r1 :: nil) + else (Odivl, r1 :: r2 :: nil) + | None => (Odivl, r1 :: r2 :: nil) + end. + +Definition make_divluimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => (Oshrluimm l, r1 :: nil) + | None => (Odivlu, r1 :: r2 :: nil) + end. + +Definition make_modluimm n (r1 r2: reg) := + match Int64.is_power2 n with + | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) + | None => (Omodlu, r1 :: r2 :: nil) + end. + +Definition make_mulfimm (n: float) (r r1 r2: reg) := + if Float.eq_dec n (Float.of_int (Int.repr 2)) + then (Oaddf, r :: r :: nil) + else (Omulf, r1 :: r2 :: nil). + +Definition make_mulfsimm (n: float32) (r r1 r2: reg) := + if Float32.eq_dec n (Float32.of_int (Int.repr 2)) + then (Oaddfs, r :: r :: nil) + else (Omulfs, r1 :: r2 :: nil). + +Definition make_cast8signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). +Definition make_cast16signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). + +(** Original definition: +<< +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 + | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 + | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 + | Ocmp c, args, vl => make_cmp c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 + | _, _, _ => (op, args) + end. +>> +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list aval), Type := + | op_strength_reduction_case1: forall r1 v1, op_strength_reduction_cases (Ocast8signed) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case2: forall r1 v1, op_strength_reduction_cases (Ocast16signed) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case3: forall r1 r2 n1 v2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case4: forall r1 r2 v1 n2, op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case6: forall r1 r2 n1 v2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case11: forall r1 r2 n1 v2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case12: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case13: forall n r1 v1, op_strength_reduction_cases (Oandimm n) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case14: forall r1 r2 n1 v2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case15: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case16: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil) + | op_strength_reduction_case17: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case18: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case19: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case20: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case21: forall r1 r2 n1 v2, op_strength_reduction_cases (Oaddl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case22: forall r1 r2 v1 n2, op_strength_reduction_cases (Oaddl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case23: forall r1 r2 v1 n2, op_strength_reduction_cases (Osubl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case24: forall r1 r2 n1 v2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case25: forall r1 r2 v1 n2, op_strength_reduction_cases (Omull) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case26: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case27: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case28: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodlu) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case29: forall r1 r2 n1 v2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case30: forall r1 r2 v1 n2, op_strength_reduction_cases (Oandl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case31: forall n r1 v1, op_strength_reduction_cases (Oandlimm n) (r1 :: nil) (v1 :: nil) + | op_strength_reduction_case32: forall r1 r2 n1 v2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case33: forall r1 r2 v1 n2, op_strength_reduction_cases (Oorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case34: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (L n1 :: v2 :: nil) + | op_strength_reduction_case35: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxorl) (r1 :: r2 :: nil) (v1 :: L n2 :: nil) + | op_strength_reduction_case36: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshll) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case37: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case38: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshrlu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil) + | op_strength_reduction_case39: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl) + | op_strength_reduction_case40: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (v1 :: F n2 :: nil) + | op_strength_reduction_case41: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (F n1 :: v2 :: nil) + | op_strength_reduction_case42: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (v1 :: FS n2 :: nil) + | op_strength_reduction_case43: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (FS n1 :: v2 :: nil) + | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list aval), op_strength_reduction_cases op args vl. + +Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list aval) := + match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with + | Ocast8signed, r1 :: nil, v1 :: nil => op_strength_reduction_case1 r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => op_strength_reduction_case2 r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case3 r1 r2 n1 v2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case4 r1 r2 v1 n2 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case6 r1 r2 n1 v2 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case11 r1 r2 n1 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case12 r1 r2 v1 n2 + | Oandimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case13 n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case14 r1 r2 n1 v2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case15 r1 r2 v1 n2 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case16 r1 r2 n1 v2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case17 r1 r2 v1 n2 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case18 r1 r2 v1 n2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case19 r1 r2 v1 n2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case20 r1 r2 v1 n2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case21 r1 r2 n1 v2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case22 r1 r2 v1 n2 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case23 r1 r2 v1 n2 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case24 r1 r2 n1 v2 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case25 r1 r2 v1 n2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case26 r1 r2 v1 n2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case27 r1 r2 v1 n2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case28 r1 r2 v1 n2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case29 r1 r2 n1 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case30 r1 r2 v1 n2 + | Oandlimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case31 n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case32 r1 r2 n1 v2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case33 r1 r2 v1 n2 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => op_strength_reduction_case34 r1 r2 n1 v2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => op_strength_reduction_case35 r1 r2 v1 n2 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case36 r1 r2 v1 n2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case37 r1 r2 v1 n2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case38 r1 r2 v1 n2 + | Ocmp c, args, vl => op_strength_reduction_case39 c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => op_strength_reduction_case40 r1 r2 v1 n2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => op_strength_reduction_case41 r1 r2 n1 v2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => op_strength_reduction_case42 r1 r2 v1 n2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => op_strength_reduction_case43 r1 r2 n1 v2 + | op, args, vl => op_strength_reduction_default op args vl + end. + +Definition op_strength_reduction (op: operation) (args: list reg) (vl: list aval) := + match op_strength_reduction_match op args vl with + | op_strength_reduction_case1 r1 v1 => (* Ocast8signed, r1 :: nil, v1 :: nil *) + make_cast8signed r1 v1 + | op_strength_reduction_case2 r1 v1 => (* Ocast16signed, r1 :: nil, v1 :: nil *) + make_cast16signed r1 v1 + | op_strength_reduction_case3 r1 r2 n1 v2 => (* Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_addimm n1 r2 + | op_strength_reduction_case4 r1 r2 v1 n2 => (* Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm n2 r1 + | op_strength_reduction_case5 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_addimm (Int.neg n2) r1 + | op_strength_reduction_case6 r1 r2 n1 v2 => (* Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_mulimm n1 r2 r1 + | op_strength_reduction_case7 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_mulimm n2 r1 r2 + | op_strength_reduction_case8 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divimm n2 r1 r2 + | op_strength_reduction_case9 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_divuimm n2 r1 r2 + | op_strength_reduction_case10 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_moduimm n2 r1 r2 + | op_strength_reduction_case11 r1 r2 n1 v2 => (* Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_andimm n1 r2 v2 + | op_strength_reduction_case12 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_andimm n2 r1 v1 + | op_strength_reduction_case13 n r1 v1 => (* Oandimm n, r1 :: nil, v1 :: nil *) + make_andimm n r1 v1 + | op_strength_reduction_case14 r1 r2 n1 v2 => (* Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_orimm n1 r2 + | op_strength_reduction_case15 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_orimm n2 r1 + | op_strength_reduction_case16 r1 r2 n1 v2 => (* Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil *) + make_xorimm n1 r2 + | op_strength_reduction_case17 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_xorimm n2 r1 + | op_strength_reduction_case18 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shlimm n2 r1 r2 + | op_strength_reduction_case19 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrimm n2 r1 r2 + | op_strength_reduction_case20 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shruimm n2 r1 r2 + | op_strength_reduction_case21 r1 r2 n1 v2 => (* Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_addlimm n1 r2 + | op_strength_reduction_case22 r1 r2 v1 n2 => (* Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_addlimm n2 r1 + | op_strength_reduction_case23 r1 r2 v1 n2 => (* Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_addlimm (Int64.neg n2) r1 + | op_strength_reduction_case24 r1 r2 n1 v2 => (* Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_mullimm n1 r2 r1 + | op_strength_reduction_case25 r1 r2 v1 n2 => (* Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_mullimm n2 r1 r2 + | op_strength_reduction_case26 r1 r2 v1 n2 => (* Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_divlimm n2 r1 r2 + | op_strength_reduction_case27 r1 r2 v1 n2 => (* Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_divluimm n2 r1 r2 + | op_strength_reduction_case28 r1 r2 v1 n2 => (* Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_modluimm n2 r1 r2 + | op_strength_reduction_case29 r1 r2 n1 v2 => (* Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_andlimm n1 r2 v2 + | op_strength_reduction_case30 r1 r2 v1 n2 => (* Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_andlimm n2 r1 v1 + | op_strength_reduction_case31 n r1 v1 => (* Oandlimm n, r1 :: nil, v1 :: nil *) + make_andlimm n r1 v1 + | op_strength_reduction_case32 r1 r2 n1 v2 => (* Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_orlimm n1 r2 + | op_strength_reduction_case33 r1 r2 v1 n2 => (* Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_orlimm n2 r1 + | op_strength_reduction_case34 r1 r2 n1 v2 => (* Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil *) + make_xorlimm n1 r2 + | op_strength_reduction_case35 r1 r2 v1 n2 => (* Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil *) + make_xorlimm n2 r1 + | op_strength_reduction_case36 r1 r2 v1 n2 => (* Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shllimm n2 r1 r2 + | op_strength_reduction_case37 r1 r2 v1 n2 => (* Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrlimm n2 r1 r2 + | op_strength_reduction_case38 r1 r2 v1 n2 => (* Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil *) + make_shrluimm n2 r1 r2 + | op_strength_reduction_case39 c args vl => (* Ocmp c, args, vl *) + make_cmp c args vl + | op_strength_reduction_case40 r1 r2 v1 n2 => (* Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil *) + make_mulfimm n2 r1 r1 r2 + | op_strength_reduction_case41 r1 r2 n1 v2 => (* Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil *) + make_mulfimm n1 r2 r1 r2 + | op_strength_reduction_case42 r1 r2 v1 n2 => (* Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil *) + make_mulfsimm n2 r1 r1 r2 + | op_strength_reduction_case43 r1 r2 n1 v2 => (* Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil *) + make_mulfsimm n1 r2 r1 r2 + | op_strength_reduction_default op args vl => + (op, args) + end. + + +(** Original definition: +<< +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list aval) := + match addr, args, vl with + | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => + if Archi.pic_code tt + then (addr, args) + else (Aglobal symb (Ptrofs.add n1 n), nil) + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => + (Ainstack (Ptrofs.add n1 n), nil) + | _, _, _ => + (addr, args) + end. +>> +*) + +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type := + | addr_strength_reduction_case1: forall n r1 symb n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (Ptr(Gl symb n1) :: nil) + | addr_strength_reduction_case2: forall n r1 n1, addr_strength_reduction_cases (Aindexed n) (r1 :: nil) (Ptr(Stk n1) :: nil) + | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_cases addr args vl. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list aval) := + match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with + | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => addr_strength_reduction_case1 n r1 symb n1 + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => addr_strength_reduction_case2 n r1 n1 + | addr, args, vl => addr_strength_reduction_default addr args vl + end. + +Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) := + match addr_strength_reduction_match addr args vl with + | addr_strength_reduction_case1 n r1 symb n1 => (* Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil *) + if Archi.pic_code tt then (addr, args) else (Aglobal symb (Ptrofs.add n1 n), nil) + | addr_strength_reduction_case2 n r1 n1 => (* Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil *) + (Ainstack (Ptrofs.add n1 n), nil) + | addr_strength_reduction_default addr args vl => + (addr, args) + end. + + diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp new file mode 100644 index 00000000..aab2424d --- /dev/null +++ b/mppa_k1c/ConstpropOp.vp @@ -0,0 +1,309 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Strength reduction for operators and conditions. + This is the machine-dependent part of [Constprop]. *) + +Require Archi. +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. +Require Import ValueDomain. + +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => if Archi.ptr64 then Some(Olongconst n) else None + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + +(** * Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list aval) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c n2, r1 :: nil) + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. + +Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) + else (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) + else (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) + else (Oshru, r1 :: r2 :: nil). + +Definition make_mulimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshlimm l, r1 :: nil) + | None => (Omul, r1 :: r2 :: nil) + end. + +Definition make_andimm (n: int) (r: reg) (a: aval) := + if Int.eq n Int.zero then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero + | _ => false end + then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Definition make_divimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshruimm l, r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) + end. + +Definition make_addlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero + then (Omove, r :: nil) + else (Oaddlimm n, r :: nil). + +Definition make_shllimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) + else (Oshll, r1 :: r2 :: nil). + +Definition make_shrlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) + else (Oshrl, r1 :: r2 :: nil). + +Definition make_shrluimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) + else (Oshrlu, r1 :: r2 :: nil). + +Definition make_mullimm (n: int64) (r1 r2: reg) := + if Int64.eq n Int64.zero then + (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.one then + (Omove, r1 :: nil) + else + match Int64.is_power2' n with + | Some l => (Oshllimm l, r1 :: nil) + | None => (Omull, r1 :: r2 :: nil) + end. + +Definition make_andlimm (n: int64) (r: reg) (a: aval) := + if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.mone then (Omove, r :: nil) + else (Oandlimm n, r :: nil). + +Definition make_orlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) + else (Oorlimm n, r :: nil). + +Definition make_xorlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else (Oxorlimm n, r :: nil). + +Definition make_divlimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => if Int.ltu l (Int.repr 63) + then (Oshrxlimm l, r1 :: nil) + else (Odivl, r1 :: r2 :: nil) + | None => (Odivl, r1 :: r2 :: nil) + end. + +Definition make_divluimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => (Oshrluimm l, r1 :: nil) + | None => (Odivlu, r1 :: r2 :: nil) + end. + +Definition make_modluimm n (r1 r2: reg) := + match Int64.is_power2 n with + | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) + | None => (Omodlu, r1 :: r2 :: nil) + end. + +Definition make_mulfimm (n: float) (r r1 r2: reg) := + if Float.eq_dec n (Float.of_int (Int.repr 2)) + then (Oaddf, r :: r :: nil) + else (Omulf, r1 :: r2 :: nil). + +Definition make_mulfsimm (n: float32) (r r1 r2: reg) := + if Float32.eq_dec n (Float32.of_int (Int.repr 2)) + then (Oaddfs, r :: r :: nil) + else (Omulfs, r1 :: r2 :: nil). + +Definition make_cast8signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). +Definition make_cast16signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). + +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 + | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 + | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 + | Ocmp c, args, vl => make_cmp c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 + | _, _, _ => (op, args) + end. + +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list aval) := + match addr, args, vl with + | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => + if Archi.pic_code tt + then (addr, args) + else (Aglobal symb (Ptrofs.add n1 n), nil) + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => + (Ainstack (Ptrofs.add n1 n), nil) + | _, _, _ => + (addr, args) + end. + diff --git a/mppa_k1c/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v new file mode 100644 index 00000000..b6c73281 --- /dev/null +++ b/mppa_k1c/ConstpropOpproof.v @@ -0,0 +1,743 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for operator strength reduction. *) + +Require Import Coqlib Compopts. +Require Import Integers Floats Values Memory Globalenvs Events. +Require Import Op Registers RTL ValueDomain. +Require Import ConstpropOp. + +Section STRENGTH_REDUCTION. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. +Variable ae: AE.t. +Variable e: regset. +Variable m: mem. +Hypothesis MATCH: ematch bc e ae. + +Lemma match_G: + forall r id ofs, + AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). +Proof. + intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Lemma match_S: + forall r ofs, + AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). +Proof. + intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = AE.get ?r ae |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. + +Ltac SimplVM := + match goal with + | [ H: vmatch _ ?v (I ?n) |- _ ] => + let E := fresh in + assert (E: v = Vint n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (L ?n) |- _ ] => + let E := fresh in + assert (E: v = Vlong n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (F ?n) |- _ ] => + let E := fresh in + assert (E: v = Vfloat n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (FS ?n) |- _ ] => + let E := fresh in + assert (E: v = Vsingle n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); + clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); + clear H; SimplVM + | _ => idtac + end. + +Lemma const_for_result_correct: + forall a op v, + const_for_result a = Some op -> + vmatch bc v a -> + exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. +Proof. + unfold const_for_result. generalize Archi.ptr64; intros ptr64; intros. + destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* long *) + destruct ptr64; inv H2. exists (Vlong n); auto. +- (* float *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto. +- (* single *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto. +- (* pointer *) + destruct p; try discriminate; SimplVM. + + (* global *) + inv H2. exists (Genv.symbol_address ge id ofs); auto. + + (* stack *) + inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args vl, + vl = map (fun r => AE.get r ae) args -> + let (cond', args') := cond_strength_reduction cond args vl in + eval_condition cond' e##args' m = eval_condition cond e##args m. +Proof. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM. +- apply Val.swap_cmp_bool. +- auto. +- apply Val.swap_cmpu_bool. +- auto. +- apply Val.swap_cmpl_bool. +- auto. +- apply Val.swap_cmplu_bool. +- auto. +- auto. +Qed. + +Lemma make_cmp_base_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp_base c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros. unfold make_cmp_base. + generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. + econstructor; split. simpl; eauto. rewrite EQ. auto. +Qed. + +Lemma make_cmp_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros c args vl. + assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> + e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). + { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } + unfold make_cmp. case (make_cmp_match c args vl); intros. +- unfold make_cmp_imm_eq. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_ne. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_eq. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_ne. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- apply make_cmp_base_correct; auto. +Qed. + +Lemma make_addimm_correct: + forall n r, + let (op, args) := make_addimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. +Proof. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. + exists (Val.add e#r (Vint n)); split; auto. +Qed. + +Lemma make_shlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shruimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shruimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. +Proof. + intros; unfold make_shruimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mulimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_mulimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. +Proof. + intros; unfold make_mulimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) eqn:?; intros. + rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. + econstructor; split; eauto. simpl. rewrite H; auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + destruct (Int.ltu i (Int.repr 31)) eqn:?. + exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. + exists v; auto. +Qed. + +Lemma make_moduimm_correct: + forall n r1 r2 v, + Val.modu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_moduimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_moduimm. + destruct (Int.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. + exists v; auto. +Qed. + +Lemma make_andimm_correct: + forall n r x, + vmatch bc e#r x -> + let (op, args) := make_andimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. +Proof. + intros; unfold make_andimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. + destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero + | _ => false end) eqn:UNS. + destruct x; try congruence. + exists (e#r); split; auto. + inv H; auto. simpl. replace (Int.and i n) with i; auto. + generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. + Int.bit_solve. destruct (zlt i0 n0). + replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). + rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite Int.bits_not by auto. apply negb_involutive. + rewrite H6 by auto. auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orimm_correct: + forall n r, + let (op, args) := make_orimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. +Proof. + intros; unfold make_orimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorimm_correct: + forall n r, + let (op, args) := make_xorimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. +Proof. + intros; unfold make_xorimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Val.notint e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_addlimm_correct: + forall n r, + let (op, args) := make_addlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v. +Proof. + intros. unfold make_addlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto. + exists (Val.addl e#r (Vlong n)); split; auto. +Qed. + +Lemma make_shllimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shllimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v. +Proof. + intros; unfold make_shllimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrluimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrluimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrluimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mullimm_correct: + forall n r1 r2, + e#r2 = Vlong n -> + let (op, args) := make_mullimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v. +Proof. + intros; unfold make_mullimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst. + exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto. + destruct (Int64.is_power2' n) eqn:?; intros. + exists (Val.shll e#r1 (Vint i)); split; auto. + destruct (e#r1); simpl; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.mul_pow2' by eauto. auto. + econstructor; split; eauto. simpl; rewrite H; auto. +Qed. + +Lemma make_divlimm_correct: + forall n r1 r2 v, + Val.divls e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divlimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divlimm. + destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. + rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divluimm_correct: + forall n r1 r2 v, + Val.divlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divluimm. + destruct (Int64.is_power2' n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. auto. + exists v; auto. +Qed. + +Lemma make_modluimm_correct: + forall n r1 r2 v, + Val.modlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_modluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_modluimm. + destruct (Int64.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. erewrite Int64.modu_and by eauto. auto. + exists v; auto. +Qed. + +Lemma make_andlimm_correct: + forall n r x, + let (op, args) := make_andlimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v. +Proof. + intros; unfold make_andlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orlimm_correct: + forall n r, + let (op, args) := make_orlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v. +Proof. + intros; unfold make_orlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorlimm_correct: + forall n r, + let (op, args) := make_xorlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v. +Proof. + intros; unfold make_xorlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Val.notl e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_mulfimm_correct: + forall n r1 r2, + e#r2 = Vfloat n -> + let (op, args) := make_mulfimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfimm_correct_2: + forall n r1 r2, + e#r1 = Vfloat n -> + let (op, args) := make_mulfimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto. + rewrite Float.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct: + forall n r1 r2, + e#r2 = Vsingle n -> + let (op, args) := make_mulfsimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct_2: + forall n r1 r2, + e#r1 = Vsingle n -> + let (op, args) := make_mulfsimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto. + rewrite Float32.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_cast8signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast8signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. +Proof. + intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 8)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma make_cast16signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast16signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. +Proof. + intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 16)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma op_strength_reduction_correct: + forall op args vl v, + vl = map (fun r => AE.get r ae) args -> + eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v -> + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w. +Proof. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +- (* cast8signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto. +- (* cast16signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. +- (* add 1 *) + rewrite Val.add_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. +- (* add 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. +- (* sub *) + InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +- (* mul 1 *) + rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +- (* mul 2*) + InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +- (* divs *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divimm_correct; auto. +- (* divu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divuimm_correct; auto. +- (* modu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_moduimm_correct; auto. +- (* and 1 *) + rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* and 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* andimm *) + inv H; inv H0. apply make_andimm_correct; auto. +- (* or 1 *) + rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* or 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* xor 1 *) + rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* xor 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* shl *) + InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto. +- (* shr *) + InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto. +- (* shru *) + InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. +- (* addl 1 *) + rewrite Val.addl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. +- (* addl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. +- (* subl *) + InvApproxRegs; SimplVM; inv H0. + replace (Val.subl e#r1 (Vlong n2)) with (Val.addl e#r1 (Vlong (Int64.neg n2))). + apply make_addlimm_correct; auto. + unfold Val.addl, Val.subl. destruct Archi.ptr64 eqn:SF, e#r1; auto. + rewrite Int64.sub_add_opp; auto. + rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs. + rewrite Int64.sub_add_opp; auto. +- (* mull 1 *) + rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +- (* mull 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +- (* divl *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divlimm_correct; auto. +- (* divlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divluimm_correct; auto. +- (* modlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_modluimm_correct; auto. +- (* andl 1 *) + rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* andl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* andlimm *) + inv H; inv H0. apply make_andlimm_correct; auto. +- (* orl 1 *) + rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* orl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* xorl 1 *) + rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* xorl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* shll *) + InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto. +- (* shrl *) + InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto. +- (* shrlu *) + InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. +- (* cond *) + inv H0. apply make_cmp_correct; auto. +- (* mulf 1 *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. +- (* mulf 2 *) + InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). + rewrite <- H2. apply make_mulfimm_correct_2; auto. +- (* mulfs 1 *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. +- (* mulfs 2 *) + InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). + rewrite <- H2. apply make_mulfsimm_correct_2; auto. +- (* default *) + exists v; auto. +Qed. + +Lemma addr_strength_reduction_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction addr args vl in + exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. + intros until res. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; + intros VL EA; InvApproxRegs; SimplVM; try (inv EA). +- destruct (Archi.pic_code tt). ++ exists (Val.offset_ptr e#r1 n); auto. ++ simpl. rewrite Genv.shift_symbol_address. econstructor; split; eauto. + inv H0; simpl; auto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + change (Vptr sp (Ptrofs.add n1 n)) with (Val.offset_ptr (Vptr sp n1) n). + inv H0; simpl; auto. +- exists res; auto. +Qed. + +End STRENGTH_REDUCTION. diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v new file mode 100644 index 00000000..99044be8 --- /dev/null +++ b/mppa_k1c/Conventions1.v @@ -0,0 +1,410 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib Decidableplus. +Require Import AST Machregs Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Callee-save registers, whose value is preserved across a function call. +- Caller-save registers that can be modified during a function call. + + We follow the RISC-V application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition is_callee_save (r: mreg) : bool := + match r with + | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 + | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 => true + | _ => false + end. + +Definition int_caller_save_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 + :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 + :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 + :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 + :: R62 :: R63 :: nil. + +Definition float_caller_save_regs := R62 :: nil. (* FIXME - for the dummy_float_reg *) + +Definition int_callee_save_regs := + R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 + :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: nil. + +Definition float_callee_save_regs := @nil mreg. + +Definition destroyed_at_call := + List.filter (fun r => negb (is_callee_save r)) all_mregs. + +Definition dummy_int_reg := R63. (**r Used in [Coloring]. *) +Definition dummy_float_reg := R62. (**r Used in [Coloring]. *) + +Definition callee_save_type := mreg_type. + +Definition is_float_reg (r: mreg) := false. + +(** * Function calling conventions *) + +(** The functions in this section determine the locations (machine registers + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. To ensure binary interoperability of code generated by our + compiler with libraries compiled by another compiler, we + implement the standard RISC-V conventions. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R10] or [F10] or [R10,R11], depending on the type of the + returned value. We treat a function without result as a function + with one integer result. *) + +Definition loc_result (s: signature) : rpair mreg := + match s.(sig_res) with + | None => One R0 + | Some (Tint | Tany32) => One R0 + | Some (Tfloat | Tsingle | Tany64) => One R0 + | Some Tlong => if Archi.ptr64 then One R0 else One R0 + end. + +(** The result registers have types compatible with that given in the signature. *) + +Lemma loc_result_type: + forall sig, + subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. +Proof. + intros. unfold proj_sig_res, loc_result, mreg_type; + destruct (sig_res sig) as [[]|]; auto; destruct Archi.ptr64; auto. +Qed. + +(** The result locations are caller-save registers *) + +Lemma loc_result_caller_save: + forall (s: signature), + forall_rpair (fun r => is_callee_save r = false) (loc_result s). +Proof. + intros. unfold loc_result, is_callee_save; + destruct (sig_res s) as [[]|]; simpl; auto; destruct Archi.ptr64; simpl; auto. +Qed. + +(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) + +Lemma loc_result_pair: + forall sg, + match loc_result sg with + | One _ => True + | Twolong r1 r2 => + r1 <> r2 /\ sg.(sig_res) = Some Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.ptr64 = false + end. +Proof. + intros. + unfold loc_result; destruct (sig_res sg) as [[]|]; auto. + unfold mreg_type; destruct Archi.ptr64; auto. +Qed. + +(** The location of the result depends only on the result part of the signature *) + +Lemma loc_result_exten: + forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. +Proof. + intros. unfold loc_result. rewrite H; auto. +Qed. + +(** ** Location of function arguments *) + +(** The RISC-V ABI states the following convention for passing arguments + to a function: + +- Arguments are passed in registers when possible. + +- Up to eight integer registers (ai: int_param_regs) and up to eight + floating-point registers (fai: float_param_regs) are used for this + purpose. + +- If the arguments to a function are conceptualized as fields of a C + struct, each with pointer alignment, the argument registers are a + shadow of the first eight pointer-words of that struct. If argument + i < 8 is a floating-point type, it is passed in floating-point + register fa_i; otherwise, it is passed in integer register a_i. + +- When primitive arguments twice the size of a pointer-word are passed + on the stack, they are naturally aligned. When they are passed in the + integer registers, they reside in an aligned even-odd register pair, + with the even register holding the least-significant bits. + +- Floating-point arguments to variadic functions (except those that + are explicitly named in the parameter list) are passed in integer + registers. + +- The portion of the conceptual struct that is not passed in argument + registers is passed on the stack. The stack pointer sp points to the + first argument not passed in a register. + +The bit about variadic functions doesn't quite fit CompCert's model. +We do our best by passing the FP arguments in registers, as usual, +and reserving the corresponding integer registers, so that fixup +code can be introduced in the Asmexpand pass. +*) + +Definition param_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: nil. + +Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) + (rec: Z -> Z -> list (rpair loc)) := + match list_nth_z regs rn with + | Some r => + One(R r) :: rec (rn + 1) ofs + | None => + let ofs := align ofs (typealign ty) in + One(S Outgoing ofs ty) :: rec rn (ofs + (if Archi.ptr64 then 2 else typesize ty)) + end. + +Definition two_args (regs: list mreg) (rn: Z) (ofs: Z) + (rec: Z -> Z -> list (rpair loc)) := + let rn := align rn 2 in + match list_nth_z regs rn, list_nth_z regs (rn + 1) with + | Some r1, Some r2 => + Twolong (R r2) (R r1) :: rec (rn + 2) ofs + | _, _ => + let ofs := align ofs 2 in + Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) :: + rec rn (ofs + 2) + end. + +Definition hybrid_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) + (rec: Z -> Z -> list (rpair loc)) := + let rn := align rn 2 in + match list_nth_z regs rn with + | Some r => + One (R r) :: rec (rn + 2) ofs + | None => + let ofs := align ofs 2 in + One (S Outgoing ofs ty) :: rec rn (ofs + 2) + end. + +Fixpoint loc_arguments_rec (va: bool) + (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | ty :: tys => one_arg param_regs r ofs ty (loc_arguments_rec va tys) +(* + | (Tint | Tany32) as ty :: tys => + one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + | Tsingle as ty :: tys => + one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + | Tlong as ty :: tys => + if Archi.ptr64 + then one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + else two_args int_param_regs r ofs (loc_arguments_rec va tys) + | (Tfloat | Tany64) as ty :: tys => + if va && negb Archi.ptr64 + then hybrid_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + else one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) +*) + end. + +(** [loc_arguments s] returns the list of locations where to store arguments + when calling a function with signature [s]. *) + +Definition loc_arguments (s: signature) : list (rpair loc) := + loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Definition max_outgoing_1 (accu: Z) (l: loc) : Z := + match l with + | S Outgoing ofs ty => Z.max accu (ofs + typesize ty) + | _ => accu + end. + +Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z := + match rl with + | One l => max_outgoing_1 accu l + | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2 + end. + +Definition size_arguments (s: signature) : Z := + List.fold_left max_outgoing_2 (loc_arguments s) 0. + +(** Argument locations are either non-temporary registers or [Outgoing] + stack slots at nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => is_callee_save r = false + | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) + | _ => False + end. + +Lemma loc_arguments_rec_charact: + forall va tyl rn ofs p, + ofs >= 0 -> + In p (loc_arguments_rec va tyl rn ofs) -> forall_rpair loc_argument_acceptable p. +Proof. + set (OK := fun (l: list (rpair loc)) => + forall p, In p l -> forall_rpair loc_argument_acceptable p). + set (OKF := fun (f: Z -> Z -> list (rpair loc)) => + forall rn ofs, ofs >= 0 -> OK (f rn ofs)). + set (OKREGS := fun (l: list mreg) => forall r, In r l -> is_callee_save r = false). + assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typealign ty) >= 0). + { intros. + assert (ofs <= align ofs (typealign ty)) by (apply align_le; apply typealign_pos). + omega. } + assert (SK: (if Archi.ptr64 then 2 else 1) > 0). + { destruct Archi.ptr64; omega. } + assert (SKK: forall ty, (if Archi.ptr64 then 2 else typesize ty) > 0). + { intros. destruct Archi.ptr64. omega. apply typesize_pos. } + assert (A: forall regs rn ofs ty f, + OKREGS regs -> OKF f -> ofs >= 0 -> OK (one_arg regs rn ofs ty f)). + { intros until f; intros OR OF OO; red; unfold one_arg; intros. + destruct (list_nth_z regs rn) as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - subst p; simpl. auto using align_divides, typealign_pos. + - eapply OF; [idtac|eauto]. + generalize (AL ofs ty OO) (SKK ty); omega. + } + assert (B: forall regs rn ofs f, + OKREGS regs -> OKF f -> ofs >= 0 -> OK (two_args regs rn ofs f)). + { intros until f; intros OR OF OO; unfold two_args. + set (rn' := align rn 2). + set (ofs' := align ofs 2). + assert (OO': ofs' >= 0) by (apply (AL ofs Tlong); auto). + assert (DFL: OK (Twolong (S Outgoing (ofs' + 1) Tint) (S Outgoing ofs' Tint) + :: f rn' (ofs' + 2))). + { red; simpl; intros. destruct H. + - subst p; simpl. + repeat split; auto using Z.divide_1_l. omega. + - eapply OF; [idtac|eauto]. omega. + } + destruct (list_nth_z regs rn') as [r1|] eqn:NTH1; + destruct (list_nth_z regs (rn' + 1)) as [r2|] eqn:NTH2; + try apply DFL. + red; simpl; intros; destruct H. + - subst p; simpl. split; apply OR; eauto using list_nth_z_in. + - eapply OF; [idtac|eauto]. auto. + } + assert (C: forall regs rn ofs ty f, + OKREGS regs -> OKF f -> ofs >= 0 -> typealign ty = 1 -> OK (hybrid_arg regs rn ofs ty f)). + { intros until f; intros OR OF OO OTY; unfold hybrid_arg; red; intros. + set (rn' := align rn 2) in *. + destruct (list_nth_z regs rn') as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - subst p; simpl. rewrite OTY. split. apply (AL ofs Tlong OO). apply Z.divide_1_l. + - eapply OF; [idtac|eauto]. generalize (AL ofs Tlong OO); simpl; omega. + } + assert (D: OKREGS param_regs). + { red. decide_goal. } + assert (E: OKREGS param_regs). + { red. decide_goal. } + + cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). + unfold OK. eauto. + induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. + - red; simpl; tauto. + - destruct ty1. ++ (* int *) apply A; auto. ++ (* float *) + apply A; auto. ++ (* long *) + apply A; auto. ++ (* single *) + apply A; auto. ++ (* any32 *) + apply A; auto. ++ (* any64 *) + apply A; auto. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (p: rpair loc), + In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. +Proof. + unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. omega. +Qed. + +(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) + +Remark fold_max_outgoing_above: + forall l n, fold_left max_outgoing_2 l n >= n. +Proof. + assert (A: forall n l, max_outgoing_1 n l >= n). + { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + induction l; simpl; intros. + - omega. + - eapply Zge_trans. eauto. + destruct a; simpl. apply A. eapply Zge_trans; eauto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +Proof. + intros. apply fold_max_outgoing_above. +Qed. + +Lemma loc_arguments_bounded: + forall (s: signature) (ofs: Z) (ty: typ), + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) -> + ofs + typesize ty <= size_arguments s. +Proof. + intros until ty. + assert (A: forall n l, n <= max_outgoing_1 n l). + { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + assert (B: forall p n, + In (S Outgoing ofs ty) (regs_of_rpair p) -> + ofs + typesize ty <= max_outgoing_2 n p). + { intros. destruct p; simpl in H; intuition; subst; simpl. + - xomega. + - eapply Z.le_trans. 2: apply A. xomega. + - xomega. } + assert (C: forall l n, + In (S Outgoing ofs ty) (regs_of_rpairs l) -> + ofs + typesize ty <= fold_left max_outgoing_2 l n). + { induction l; simpl; intros. + - contradiction. + - rewrite in_app_iff in H. destruct H. + + eapply Z.le_trans. eapply B; eauto. apply Z.ge_le. apply fold_max_outgoing_above. + + apply IHl; auto. + } + apply C. +Qed. + +Lemma loc_arguments_main: + loc_arguments signature_main = nil. +Proof. + reflexivity. +Qed. diff --git a/mppa_k1c/Machblock.v b/mppa_k1c/Machblock.v new file mode 100644 index 00000000..44cec642 --- /dev/null +++ b/mppa_k1c/Machblock.v @@ -0,0 +1,355 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. + +(** instructions "basiques" (ie non control-flow) *) +Inductive basic_inst: Type := + | MBgetstack: ptrofs -> typ -> mreg -> basic_inst + | MBsetstack: mreg -> ptrofs -> typ -> basic_inst + | MBgetparam: ptrofs -> typ -> mreg -> basic_inst + | MBop: operation -> list mreg -> mreg -> basic_inst + | MBload: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + . + +Definition bblock_body := list basic_inst. + +(** instructions de control flow *) +Inductive control_flow_inst: Type := + | MBcall: signature -> mreg + ident -> control_flow_inst + | MBtailcall: signature -> mreg + ident -> control_flow_inst + | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst + | MBgoto: label -> control_flow_inst + | MBcond: condition -> list mreg -> label -> control_flow_inst + | MBjumptable: mreg -> list label -> control_flow_inst + | MBreturn: control_flow_inst + . + +Record bblock := mk_bblock { + header: list label; + body: bblock_body; + exit: option control_flow_inst +}. + +Lemma bblock_eq: + forall b1 b2, + header b1 = header b2 -> + body b1 = body b2 -> + exit b1 = exit b2 -> + b1 = b2. +Proof. + intros. destruct b1. destruct b2. + simpl in *. subst. auto. +Qed. + +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)). + +Lemma size_null b: + size b = 0%nat -> + header b = nil /\ body b = nil /\ exit b = None. +Proof. + destruct b as [h b e]. simpl. unfold size. simpl. + intros H. + assert (length h = 0%nat) as Hh; [ omega |]. + assert (length b = 0%nat) as Hb; [ omega |]. + assert (length_opt e = 0%nat) as He; [ omega|]. + repeat split. + destruct h; try (simpl in Hh; discriminate); auto. + destruct b; try (simpl in Hb; discriminate); auto. + destruct e; try (simpl in He; discriminate); auto. +Qed. + +Definition code := list bblock. + +Record function: Type := mkfunction + { fn_sig: signature; + fn_code: code; + fn_stacksize: Z; + fn_link_ofs: ptrofs; + fn_retaddr_ofs: ptrofs }. + +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef unit. + +Definition genv := Genv.t fundef unit. + +(*** sémantique ***) + +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + + +Local Open Scope nat_scope. + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Section RELSEM. + +Variable rao:function -> code -> ptrofs -> Prop. +Variable ge:genv. + +Definition find_function_ptr + (ge: genv) (ros: mreg + ident) (rs: regset) : option block := + match ros with + | inl r => + match rs r with + | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None + | _ => None + end + | inr symb => + Genv.find_symbol ge symb + end. + +(** Machblock execution states. *) + +Inductive stackframe: Type := + | Stackframe: + forall (f: block) (**r pointer to calling function *) + (sp: val) (**r stack pointer in calling function *) + (retaddr: val) (**r Asm return address in calling function *) + (c: code), (**r program point in calling function *) + stackframe. + +Inductive state: Type := + | State: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to current function *) + (sp: val) (**r stack pointer *) + (c: code) (**r current program point *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Callstate: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to function to call *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Returnstate: + forall (stack: list stackframe) (**r call stack *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state. + +Definition parent_sp (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => sp + end. + +Definition parent_ra (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => ra + end. + +Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop := + | exec_MBgetstack: + forall ofs ty dst v, + load_stack m sp ty ofs = Some v -> + basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m + | exec_MBsetstack: + forall src ofs ty m' rs', + store_stack m sp ty ofs (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_setstack ty) rs -> + basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' + | exec_MBgetparam: + forall ofs ty dst v rs' f, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> + rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> + basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m + | exec_MBop: + forall op args v rs' res, + eval_operation ge sp op rs##args m = Some v -> + rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) -> + basic_step s fb sp rs m (MBop op args res) rs' m + | exec_MBload: + forall addr args a v rs' chunk dst, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> + basic_step s fb sp rs m (MBload chunk addr args dst) rs' m + | exec_MBstore: + forall chunk addr args src m' a rs', + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_store chunk addr) rs -> + basic_step s fb sp rs m (MBstore chunk addr args src) rs' m' + . + + +Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop := + | exec_nil_body: + forall rs m, + body_step s f sp nil rs m rs m + | exec_cons_body: + forall rs m bi p rs' m' rs'' m'', + basic_step s f sp rs m bi rs' m' -> + body_step s f sp p rs' m' rs'' m'' -> + body_step s f sp (bi::p) rs m rs'' m'' + . + +Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop := + | exec_MBcall: + forall s fb sp sig ros c b rs m f f' ra, + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + rao f c ra -> + cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m) + E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) + f' rs m) + | exec_MBtailcall: + forall s fb stk soff sig ros c rs m f f' m', + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m) + E0 (Callstate s f' rs m') + | exec_MBbuiltin: + forall s f sp rs m ef args res b c vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> + cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m) + t (State s f sp c rs' m') + | exec_MBgoto: + forall s fb f sp lbl c rs m c', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + cfi_step (MBgoto lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs m) + | exec_MBcond_true: + forall s fb f sp cond args lbl c rs m c' rs', + eval_condition cond rs##args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBcond_false: + forall s f sp cond args lbl b c rs m rs', + eval_condition cond rs##args m = Some false -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m) + E0 (State s f sp c rs' m) + | exec_MBjumptable: + forall s fb f sp arg tbl c rs m n lbl c' rs', + rs arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs destroyed_by_jumptable rs -> + cfi_step (MBjumptable arg tbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBreturn: + forall s fb stk soff c rs m f m', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step MBreturn (State s fb (Vptr stk soff) c rs m) + E0 (Returnstate s rs m') + . + +Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop := + | exec_Some_exit: + forall ctl s t s', + cfi_step ctl s t s' -> + exit_step (Some ctl) s t s' + | exec_None_exit: + forall stk f sp b lb rs m, + exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m) + . + +Inductive step: state -> trace -> state -> Prop := + | exec_bblock: + forall sf f sp bb c rs m rs' m' t s', + body_step sf f sp (body bb) rs m rs' m' -> + exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' -> + step (State sf f sp (bb::c) rs m) t s' + | exec_function_internal: + forall s fb rs m f m1 m2 m3 stk rs', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> + let sp := Vptr stk Ptrofs.zero in + store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + rs' = undef_regs destroyed_at_function_entry rs -> + step (Callstate s fb rs m) + E0 (State s fb sp f.(fn_code) rs' m3) + | exec_function_external: + forall s fb rs m t rs' ef args res m', + Genv.find_funct_ptr ge fb = Some (External ef) -> + extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> + external_call ef ge args m t res m' -> + rs' = set_pair (loc_result (ef_sig ef)) res rs -> + step (Callstate s fb rs m) + t (Returnstate s rs' m') + | exec_return: + forall s f sp ra c rs m, + step (Returnstate (Stackframe f sp ra c :: s) rs m) + E0 (State s f sp c rs m) + . + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall fb m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some fb -> + initial_state p (Callstate nil fb (Regmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r retcode, + loc_result signature_main = One r -> + rs r = Vint retcode -> + final_state (Returnstate nil rs m) retcode. + +Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := + Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/Machblockgen.v b/mppa_k1c/Machblockgen.v new file mode 100644 index 00000000..1d5555df --- /dev/null +++ b/mppa_k1c/Machblockgen.v @@ -0,0 +1,578 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. + + +Fixpoint to_bblock_header (c: Mach.code): list label * Mach.code := + match c with + | (Mlabel l)::c' => + let (h, c'') := to_bblock_header c' in + (l::h, c'') + | _ => (nil, c) + end. + +Definition to_basic_inst(i: Mach.instruction): option basic_inst := + match i with + | Mgetstack ofs ty dst => Some (MBgetstack ofs ty dst) + | Msetstack src ofs ty => Some (MBsetstack src ofs ty) + | Mgetparam ofs ty dst => Some (MBgetparam ofs ty dst) + | Mop op args res => Some (MBop op args res) + | Mload chunk addr args dst => Some (MBload chunk addr args dst) + | Mstore chunk addr args src => Some (MBstore chunk addr args src) + | _ => None + end. + +Fixpoint to_bblock_body(c: Mach.code): bblock_body * Mach.code := + match c with + | nil => (nil,nil) + | i::c' => + match to_basic_inst i with + | Some bi => + let (p,c'') := to_bblock_body c' in + (bi::p, c'') + | None => (nil, c) + end + end. + + +Definition to_cfi (i: Mach.instruction): option control_flow_inst := + match i with + | Mcall sig ros => Some (MBcall sig ros) + | Mtailcall sig ros => Some (MBtailcall sig ros) + | Mbuiltin ef args res => Some (MBbuiltin ef args res) + | Mgoto lbl => Some (MBgoto lbl) + | Mcond cond args lbl => Some (MBcond cond args lbl) + | Mjumptable arg tbl => Some (MBjumptable arg tbl) + | Mreturn => Some (MBreturn) + | _ => None + end. + +Definition to_bblock_exit (c: Mach.code): option control_flow_inst * Mach.code := + match c with + | nil => (None,nil) + | i::c' => + match to_cfi i with + | Some bi as o => (o, c') + | None => (None, c) + end + end. + +Inductive code_nature: Set := IsEmpty | IsLabel | IsBasicInst | IsCFI. + +Definition get_code_nature (c: Mach.code): code_nature := + match c with + | nil => IsEmpty + | (Mlabel _)::_ => IsLabel + | i::_ => match to_basic_inst i with + | Some _ => IsBasicInst + | None => IsCFI + end + end. + +Lemma cn_eqdec (cn1 cn2: code_nature): { cn1=cn2 } + {cn1 <> cn2}. +Proof. + decide equality. +Qed. + +Lemma get_code_nature_nil c: c<>nil -> get_code_nature c <> IsEmpty. +Proof. + intros H. unfold get_code_nature. + destruct c; try (contradict H; auto; fail). + destruct i; discriminate. +Qed. + +Lemma get_code_nature_empty c: get_code_nature c = IsEmpty -> c = nil. +Proof. + intros H. destruct c; auto. exploit (get_code_nature_nil (i::c)); discriminate || auto. + intro F. contradict F. +Qed. + +Lemma to_bblock_header_noLabel c: + get_code_nature c <> IsLabel -> + to_bblock_header c = (nil, c). +Proof. + intros H. destruct c as [|i c]; auto. + destruct i; simpl; auto. + contradict H; simpl; auto. +Qed. + +Lemma to_bblock_header_wfe c: + forall h c0, + to_bblock_header c = (h, c0) -> + (length c >= length c0)%nat. +Proof. + induction c as [ |i c]; simpl; intros h c' H. + - inversion H; subst; clear H; simpl; auto. + - destruct i; try (inversion H; subst; simpl; auto; fail). + remember (to_bblock_header c) as bhc; destruct bhc as [h0 c0]. + inversion H; subst. + lapply (IHc h0 c'); auto. +Qed. + +Lemma to_bblock_header_wf c b c0: + get_code_nature c = IsLabel -> + to_bblock_header c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros H1 H2; destruct c; [ contradict H1; simpl; discriminate | ]. + destruct i; try discriminate. + simpl in H2. + remember (to_bblock_header c) as bh; destruct bh as [h c'']. + inversion H2; subst. + exploit to_bblock_header_wfe; eauto. + simpl; omega. +Qed. + +Lemma to_bblock_body_noBasic c: + get_code_nature c <> IsBasicInst -> + to_bblock_body c = (nil, c). +Proof. + intros H. destruct c as [|i c]; simpl; auto. + destruct i; simpl; auto. + all: contradict H; simpl; auto. +Qed. + +Lemma to_bblock_body_wfe c b c0: + to_bblock_body c = (b, c0) -> + (length c >= length c0)%nat. +Proof. + generalize b c0; clear b c0. + induction c as [|i c]. + - intros b c0 H. simpl in H. inversion H; subst; auto. + - intros b c0 H. simpl in H. destruct (to_basic_inst i). + + remember (to_bblock_body c) as tbbc; destruct tbbc as [p c'']. + exploit (IHc p c''); auto. inversion H; subst; simpl; omega. + + inversion H; subst; auto. +Qed. + +(** Attempt to eliminate cons_to_bblock_body *) +(* +Lemma to_bblock_body_basic c: + get_code_nature c = IsBasicInst -> + exists i bi b c', + to_basic_inst i = Some bi + /\ c = i :: c' + /\ to_bblock_body c = (bi::b, snd (to_bblock_body c')). +Proof. + intros H. + destruct c as [|i c]; try (contradict H; simpl; discriminate). + destruct i eqn:I; try (contradict H; simpl; discriminate). + all: simpl; destruct (to_bblock_body c) as [p c''] eqn:TBBC; repeat (eapply ex_intro); (repeat split); + simpl; eauto; rewrite TBBC; simpl; eauto. +Qed. + +Lemma to_bblock_body_wf c b c0: + get_code_nature c = IsBasicInst -> + to_bblock_body c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros H1 H2; exploit to_bblock_body_basic; eauto. + intros X. destruct X as (i & bi & b' & c' & X1 & X2 & X3). + exploit to_bblock_body_wfe. eauto. subst. simpl. + rewrite X3 in H2. inversion H2; clear H2; subst. + simpl; omega. +Qed. +*) + +Inductive cons_to_bblock_body c0: Mach.code -> bblock_body -> Prop := + Cons_to_bbloc_body i bi c' b': + to_basic_inst i = Some bi + -> to_bblock_body c' = (b', c0) + -> cons_to_bblock_body c0 (i::c') (bi::b'). + +Lemma to_bblock_body_IsBasicInst c b c0: + get_code_nature c = IsBasicInst -> + to_bblock_body c = (b, c0) -> + cons_to_bblock_body c0 c b. +Proof. + intros H1 H2. destruct c; [ contradict H1; simpl; discriminate | ]. + remember (to_basic_inst i) as tbii. destruct tbii. + - simpl in H2. rewrite <- Heqtbii in H2. + remember (to_bblock_body c) as tbbc. destruct tbbc as [p1 c1]. + inversion H2. subst. eapply Cons_to_bbloc_body; eauto. + - destruct i; try discriminate. +Qed. + +Lemma to_bblock_body_wf c b c0: + get_code_nature c = IsBasicInst -> + to_bblock_body c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros H1 H2; exploit to_bblock_body_IsBasicInst; eauto. + intros X. destruct X. + exploit to_bblock_body_wfe; eauto. subst. simpl. + simpl; omega. +Qed. + +Lemma to_bblock_exit_noCFI c: + get_code_nature c <> IsCFI -> + to_bblock_exit c = (None, c). +Proof. + intros H. destruct c as [|i c]; simpl; auto. + destruct i; simpl; auto. + all: contradict H; simpl; auto. +Qed. + +Lemma to_bblock_exit_wf c b c0: + get_code_nature c = IsCFI -> + to_bblock_exit c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intros H1 H2. destruct c as [|i c]; try discriminate. + destruct i; try discriminate; + unfold to_bblock_header in H2; inversion H2; auto. +Qed. + +Lemma to_bblock_exit_wfe c b c0: + to_bblock_exit c = (b, c0) -> + (length c >= length c0)%nat. +Proof. + intros H. destruct c as [|i c]. + - simpl in H. inversion H; subst; clear H; auto. + - destruct i; try ( simpl in H; inversion H; subst; clear H; auto ). + all: simpl; auto. +Qed. + +Definition to_bblock(c: Mach.code): bblock * Mach.code := + let (h,c0) := to_bblock_header c in + let (bdy, c1) := to_bblock_body c0 in + let (ext, c2) := to_bblock_exit c1 in + ({| header := h; body := bdy; exit := ext |}, c2) + . + +Lemma to_bblock_acc_label c l b c': + to_bblock c = (b, c') -> + to_bblock (Mlabel l :: c) = ({| header := l::(header b); body := (body b); exit := (exit b) |}, c'). +Proof. + unfold to_bblock; simpl. + remember (to_bblock_header c) as bhc; destruct bhc as [h c0]. + remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1]. + remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2]. + intros H; inversion H; subst; clear H; simpl; auto. +Qed. + +Lemma to_bblock_basic_then_label i c bi: + get_code_nature (i::c) = IsBasicInst -> + get_code_nature c = IsLabel -> + to_basic_inst i = Some bi -> + fst (to_bblock (i::c)) = {| header := nil; body := bi::nil; exit := None |}. +Proof. + intros H1 H2 H3. + destruct c as [|i' c]; try (contradict H1; simpl; discriminate). + destruct i'; try (contradict H1; simpl; discriminate). + destruct i; simpl in *; inversion H3; subst; auto. +Qed. + +Lemma to_bblock_CFI i c cfi: + get_code_nature (i::c) = IsCFI -> + to_cfi i = Some cfi -> + fst (to_bblock (i::c)) = {| header := nil; body := nil; exit := Some cfi |}. +Proof. + intros H1 H2. + destruct i; try discriminate. + all: subst; rewrite <- H2; simpl; auto. +Qed. + +Lemma to_bblock_noLabel c: + get_code_nature c <> IsLabel -> + fst (to_bblock c) = {| + header := nil; + body := body (fst (to_bblock c)); + exit := exit (fst (to_bblock c)) + |}. +Proof. + intros H. + destruct c as [|i c]; simpl; auto. + apply bblock_eq; simpl; + destruct i; ( + try ( + remember (to_bblock _) as bb; + unfold to_bblock in *; + remember (to_bblock_header _) as tbh; + destruct tbh; + destruct (to_bblock_body _); + destruct (to_bblock_exit _); + subst; simpl; inversion Heqtbh; auto; fail + ) + || contradict H; simpl; auto ). +Qed. + +Lemma to_bblock_body_nil c c': + to_bblock_body c = (nil, c') -> + c = c'. +Proof. + intros H. + destruct c as [|i c]; [ simpl in *; inversion H; auto |]. + destruct i; try ( simpl in *; remember (to_bblock_body c) as tbc; destruct tbc as [p c'']; inversion H ). + all: auto. +Qed. + +Lemma to_bblock_exit_nil c c': + to_bblock_exit c = (None, c') -> + c = c'. +Proof. + intros H. + destruct c as [|i c]; [ simpl in *; inversion H; auto |]. + destruct i; try ( simpl in *; remember (to_bblock_exit c) as tbe; destruct tbe as [p c'']; inversion H ). + all: auto. +Qed. + +Lemma to_bblock_label b l c c': + to_bblock (Mlabel l :: c) = (b, c') -> + (header b) = l::(tail (header b)) /\ to_bblock c = ({| header:=tail (header b); body := body b; exit := exit b |}, c'). +Proof. + unfold to_bblock; simpl. + remember (to_bblock_header c) as bhc; destruct bhc as [h c0]. + remember (to_bblock_body c0) as bbc; destruct bbc as [bdy c1]. + remember (to_bblock_exit c1) as bbc; destruct bbc as [ext c2]. + intros H; inversion H; subst; clear H; simpl; auto. +Qed. + +Lemma to_bblock_basic c i bi: + get_code_nature (i::c) = IsBasicInst -> + to_basic_inst i = Some bi -> + get_code_nature c <> IsLabel -> + fst (to_bblock (i::c)) = {| + header := nil; + body := bi :: body (fst (to_bblock c)); + exit := exit (fst (to_bblock c)) + |}. +Proof. + intros. + destruct c; try (destruct i; inversion H0; subst; simpl; auto; fail). + apply bblock_eq; simpl. +(* header *) + + destruct i; simpl; auto; ( + exploit to_bblock_noLabel; [rewrite H; discriminate | intro; rewrite H2; simpl; auto]). +(* body *) +(* FIXME - the proof takes some time to prove.. N² complexity :( *) + + unfold to_bblock. + remember (to_bblock_header _) as tbh; destruct tbh. + remember (to_bblock_body _) as tbb; destruct tbb. + remember (to_bblock_exit _) as tbe; destruct tbe. + simpl. + destruct i; destruct i0. + all: try (simpl in H1; contradiction). + all: try discriminate. + all: try ( + simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst; + simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; + inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1; + inversion H0; clear H0; subst; destruct (to_bblock_body c); + inversion Heqtbbc; clear Heqtbbc; subst; + destruct (to_bblock_exit c1); simpl; auto; fail). +(* exit *) + + unfold to_bblock. + remember (to_bblock_header _) as tbh; destruct tbh. + remember (to_bblock_body _) as tbb; destruct tbb. + remember (to_bblock_exit _) as tbe; destruct tbe. + simpl. + destruct i; destruct i0. + all: try (simpl in H1; contradiction). + all: try discriminate. + all: try ( + simpl in Heqtbh; inversion Heqtbh; clear Heqtbh; subst; + simpl in Heqtbb; remember (to_bblock_body c) as tbbc; destruct tbbc; + inversion Heqtbb; clear Heqtbb; subst; simpl in *; clear H H1; + inversion H0; clear H0; subst; destruct (to_bblock_body c) eqn:TBBC; + inversion Heqtbbc; clear Heqtbbc; subst; + destruct (to_bblock_exit c1) eqn:TBBE; simpl; + inversion Heqtbe; clear Heqtbe; subst; auto; fail). +Qed. + +Lemma to_bblock_size_single_label c i: + get_code_nature (i::c) = IsLabel -> + size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). +Proof. + intros H. + destruct i; try discriminate. + remember (to_bblock c) as bl. destruct bl as [b c']. + erewrite to_bblock_acc_label; eauto. + unfold size; simpl. + auto. +Qed. + +Lemma to_bblock_size_label_neqz c: + get_code_nature c = IsLabel -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + destruct c as [ |i c]; try discriminate. + intros; rewrite to_bblock_size_single_label; auto. +Qed. + +Lemma to_bblock_size_basic_neqz c: + get_code_nature c = IsBasicInst -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). + destruct i; try (contradict H; simpl; discriminate); + ( + destruct (get_code_nature c) eqn:gcnc; + (* Case gcnc is not IsLabel *) + try (erewrite to_bblock_basic; eauto; [ + unfold size; simpl; auto + | simpl; auto + | rewrite gcnc; discriminate + ]); + erewrite to_bblock_basic_then_label; eauto; [ + unfold size; simpl; auto + | simpl; auto + ] + ). +Qed. + +Lemma to_bblock_size_cfi_neqz c: + get_code_nature c = IsCFI -> + size (fst (to_bblock c)) <> 0%nat. +Proof. + intros H. destruct c as [|i c]; try (contradict H; auto; simpl; discriminate). + destruct i; discriminate. +Qed. + +Lemma to_bblock_size_single_basic c i: + get_code_nature (i::c) = IsBasicInst -> + get_code_nature c <> IsLabel -> + size (fst (to_bblock (i::c))) = Datatypes.S (size (fst (to_bblock c))). +Proof. + intros. + destruct i; try (contradict H; simpl; discriminate); try ( + (exploit to_bblock_basic; eauto); + [remember (to_basic_inst _) as tbi; destruct tbi; eauto |]; + intro; rewrite H1; unfold size; simpl; + assert ((length (header (fst (to_bblock c)))) = 0%nat); + exploit to_bblock_noLabel; eauto; intro; rewrite H2; simpl; auto; + rewrite H2; auto + ). +Qed. + +Lemma to_bblock_wf c b c0: + c <> nil -> + to_bblock c = (b, c0) -> + (length c > length c0)%nat. +Proof. + intro H; lapply (get_code_nature_nil c); eauto. + intro H'; remember (get_code_nature c) as gcn. + unfold to_bblock. + remember (to_bblock_header c) as p1; eauto. + destruct p1 as [h c1]. + intro H0. + destruct gcn. + - contradict H'; auto. + - exploit to_bblock_header_wf; eauto. + remember (to_bblock_body c1) as p2; eauto. + destruct p2 as [h2 c2]. + exploit to_bblock_body_wfe; eauto. + remember (to_bblock_exit c2) as p3; eauto. + destruct p3 as [h3 c3]. + exploit to_bblock_exit_wfe; eauto. + inversion H0. omega. + - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate. + intro. rewrite H1 in Heqp1. inversion Heqp1. clear Heqp1. subst. + remember (to_bblock_body c) as p2; eauto. + destruct p2 as [h2 c2]. + exploit to_bblock_body_wf; eauto. + remember (to_bblock_exit c2) as p3; eauto. + destruct p3 as [h3 c3]. + exploit to_bblock_exit_wfe; eauto. + inversion H0. omega. + - exploit to_bblock_header_noLabel; eauto. rewrite <- Heqgcn. discriminate. + intro. rewrite H1 in Heqp1. inversion Heqp1; clear Heqp1; subst. + remember (to_bblock_body c) as p2; eauto. + destruct p2 as [h2 c2]. + exploit (to_bblock_body_noBasic c); eauto. rewrite <- Heqgcn. discriminate. + intros H2; rewrite H2 in Heqp2; inversion Heqp2; clear Heqp2; subst. + remember (to_bblock_exit c) as p3; eauto. + destruct p3 as [h3 c3]. + exploit (to_bblock_exit_wf c h3 c3); eauto. + inversion H0. omega. +Qed. + +Lemma to_bblock_nonil i c0: + size (fst (to_bblock (i :: c0))) <> 0%nat. +Proof. + intros H. remember (i::c0) as c. remember (get_code_nature c) as gcnc. destruct gcnc. + - contradict Heqgcnc. subst. simpl. destruct i; discriminate. + - eapply to_bblock_size_label_neqz; eauto. + - eapply to_bblock_size_basic_neqz; eauto. + - eapply to_bblock_size_cfi_neqz; eauto. +Qed. + +Function trans_code (c: Mach.code) { measure length c }: code := + match c with + | nil => nil + | _ => + let (b, c0) := to_bblock c in + b::(trans_code c0) + end. +Proof. + intros; eapply to_bblock_wf; eauto. discriminate. +Qed. + +Lemma trans_code_nonil c: + c <> nil -> trans_code c <> nil. +Proof. + intros H. + induction c, (trans_code c) using trans_code_ind; simpl; auto. discriminate. +Qed. + +Lemma trans_code_step c b lb0 hb c1 bb c2 eb c3: + trans_code c = b :: lb0 -> + to_bblock_header c = (hb, c1) -> + to_bblock_body c1 = (bb, c2) -> + to_bblock_exit c2 = (eb, c3) -> + hb = header b /\ bb = body b /\ eb = exit b /\ trans_code c3 = lb0. +Proof. + intros. + induction c, (trans_code c) using trans_code_ind. discriminate. clear IHc0. + subst. destruct _x as [|i c]; try (contradict y; auto; fail). + inversion H; subst. clear H. unfold to_bblock in e0. + remember (to_bblock_header (i::c)) as hd. destruct hd as [hb' c1']. + remember (to_bblock_body c1') as bd. destruct bd as [bb' c2']. + remember (to_bblock_exit c2') as be. destruct be as [eb' c3']. + inversion e0. simpl. + inversion H0. subst. + rewrite <- Heqbd in H1. inversion H1. subst. + rewrite <- Heqbe in H2. inversion H2. subst. + auto. +Qed. + +Lemma trans_code_cfi i c cfi: + to_cfi i = Some cfi -> + trans_code (i :: c) = {| header := nil ; body := nil ; exit := Some cfi |} :: trans_code c. +Proof. + intros. rewrite trans_code_equation. remember (to_bblock _) as tb; destruct tb as [b c0]. + destruct i; try (contradict H; discriminate). + all: unfold to_bblock in Heqtb; remember (to_bblock_header _) as tbh; destruct tbh as [h c0']; + remember (to_bblock_body c0') as tbb; destruct tbb as [bdy c1']; + remember (to_bblock_exit c1') as tbe; destruct tbe as [ext c2]; simpl in *; + inversion Heqtbh; subst; inversion Heqtbb; subst; inversion Heqtbe; subst; + inversion Heqtb; subst; rewrite H; auto. +Qed. + +(* à finir pour passer des Mach.function au function, etc. *) +Definition transf_function (f: Mach.function) : function := + {| fn_sig:=Mach.fn_sig f; + fn_code:=trans_code (Mach.fn_code f); + fn_stacksize := Mach.fn_stacksize f; + fn_link_ofs := Mach.fn_link_ofs f; + fn_retaddr_ofs := Mach.fn_retaddr_ofs f + |}. + +Definition transf_fundef (f: Mach.fundef) : fundef := + transf_fundef transf_function f. + +Definition transf_program (src: Mach.program) : program := + transform_program transf_fundef src. diff --git a/mppa_k1c/Machblockgenproof.v b/mppa_k1c/Machblockgenproof.v new file mode 100644 index 00000000..62c1e0ed --- /dev/null +++ b/mppa_k1c/Machblockgenproof.v @@ -0,0 +1,629 @@ +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. +Require Import Machblockgen. +Require Import ForwardSimulationBlock. + +Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := + rao (transf_function f) (trans_code c). + +Definition match_prog (p: Mach.program) (tp: Machblock.program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Definition trans_stackframe (msf: Mach.stackframe) : stackframe := + match msf with + | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c) + end. + +Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := + match mst with + | nil => nil + | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) + end. + +Definition trans_state (ms: Mach.state) : state := + match ms with + | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m + | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m + | Mach.Returnstate s rs m => Returnstate (trans_stack s) rs m + end. + +Section PRESERVATION. + +Local Open Scope nat_scope. + +Variable prog: Mach.program. +Variable tprog: Machblock.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + + +Variable rao: function -> code -> ptrofs -> Prop. + +Definition match_states: Mach.state -> state -> Prop + := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state. + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + apply match_states_trans_state. +Qed. + +Local Hint Resolve match_states_trans_state. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma init_mem_preserved: + forall m, + Genv.init_mem prog = Some m -> + Genv.init_mem tprog = Some m. +Proof (Genv.init_mem_transf TRANSF). + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf. +Proof. + intros. + exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. + destruct H0 as (cunit & tf & A & B & C). + eapply ex_intro. intuition; eauto. subst. eapply A. +Qed. + +Lemma find_function_ptr_same: + forall s rs, + Mach.find_function_ptr ge s rs = find_function_ptr tge s rs. +Proof. + intros. unfold Mach.find_function_ptr. unfold find_function_ptr. + destruct s; auto. + rewrite symbols_preserved; auto. +Qed. + +Lemma find_funct_ptr_same: + forall f f0, + Genv.find_funct_ptr ge f = Some (Internal f0) -> + Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma find_funct_ptr_same_external: + forall f f0, + Genv.find_funct_ptr ge f = Some (External f0) -> + Genv.find_funct_ptr tge f = Some (External f0). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma parent_sp_preserved: + forall s, + Mach.parent_sp s = parent_sp (trans_stack s). +Proof. + unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma parent_ra_preserved: + forall s, + Mach.parent_ra s = parent_ra (trans_stack s). +Proof. + unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma external_call_preserved: + forall ef args m t res m', + external_call ef ge args m t res m' -> + external_call ef tge args m t res m'. +Proof. + intros. eapply external_call_symbols_preserved; eauto. + apply senv_preserved. +Qed. + +Lemma Mach_find_label_split l i c c': + Mach.find_label l (i :: c) = Some c' -> + (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). +Proof. + intros H. + destruct i; try (constructor 2; split; auto; discriminate ). + destruct (peq l0 l) as [P|P]. + - constructor. subst l0; split; auto. + revert H. unfold Mach.find_label. simpl. rewrite peq_true. + intros H; injection H; auto. + - constructor 2. split. + + intro F. injection F. intros. contradict P; auto. + + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. +Qed. + + +Definition concat (h: list label) (c: code): code := + match c with + | nil => {| header := h; body := nil; exit := None |}::nil + | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' + end. + +Lemma to_bblock_start_label i c l b c0: + (b, c0) = to_bblock (i :: c) + -> In l (header b) + -> i <> Mlabel l + -> exists l2, i=Mlabel l2. +Proof. + unfold to_bblock. + remember (to_bblock_header _) as bh; destruct bh as [h c1]. + remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. + remember (to_bblock_exit _) as be; destruct be as [ext c3]. + intros H; inversion H; subst; clear H; simpl. + destruct i; try (simpl in Heqbh; inversion Heqbh; subst; clear Heqbh; simpl; intuition eauto). +Qed. + +Lemma find_label_stop c: + forall l b c0 c', + (b, c0) = to_bblock c + -> Mach.find_label l c = Some c' + -> In l (header b) + -> exists h, In l h /\ Some (b :: trans_code c0) = Some (concat h (trans_code c')). +Proof. + induction c as [ |i c]. + - simpl; intros; discriminate. + - intros l b c0 c' H H1 H2. + exploit Mach_find_label_split; eauto; clear H1. + intros [(X1 & X2) | (X1 & X2)]. + * subst. exploit to_bblock_label; eauto. clear H. + intros (H3 & H4). constructor 1 with (x:=l::nil); simpl; intuition auto. + symmetry. + rewrite trans_code_equation. + destruct c as [ |i c]. + + unfold to_bblock in H4; simpl in H4. + injection H4. clear H4; intros H4 H H0 H1; subst. simpl. + rewrite trans_code_equation; simpl. + rewrite <- H1 in H3; clear H1. + destruct b as [h b e]; simpl in * |- *; subst; auto. + + rewrite H4; clear H4; simpl. rewrite <- H3; clear H3. + destruct b; simpl; auto. + * exploit to_bblock_start_label; eauto. + intros (l' & H'). subst. + assert (X: l' <> l). { intro Z; subst; destruct X1; auto. } + clear X1. + exploit to_bblock_label; eauto. clear H. + intros (H3 & H4). + exploit IHc; eauto. { simpl. rewrite H3 in H2; simpl in H2. destruct H2; subst; tauto. } + intros (h' & H5 & H6). + constructor 1 with (x:=l'::h'); simpl; intuition auto. + destruct b as [h b e]; simpl in * |- *; subst. + remember (tl h) as th. subst h. + remember (trans_code c') as tcc'. + rewrite trans_code_equation in Heqtcc'. + destruct c'; subst; simpl in * |- *. + + inversion H6; subst; auto. + + destruct (to_bblock (i :: c')) as [b1 c1]. simpl in * |- *. + inversion H6; subst; auto. +Qed. + +Lemma to_bblock_header_find_label c l: forall c1 h c', + to_bblock_header c = (h, c1) + -> Mach.find_label l c = Some c' + -> ~ In l h + -> Mach.find_label l c = Mach.find_label l c1. +Proof. + induction c as [|i c]; simpl; auto. + - intros; discriminate. + - destruct i; + try (simpl; intros c1 h c' H1 H2; inversion H1; subst; clear H1; intros; apply refl_equal). + remember (to_bblock_header c) as tbhc. destruct tbhc as [h2 c2]. + intros h c1 c' H1; inversion H1; subst; clear H1. + simpl. destruct (peq _ _). + + subst; tauto. + + intros H1 H2; erewrite IHc; eauto. +Qed. + +Lemma to_bblock_body_find_label c1 l: forall c2 bdy, + (bdy, c2) = to_bblock_body c1 -> + Mach.find_label l c1 = Mach.find_label l c2. +Proof. + induction c1 as [|i c1]. + - intros bdy0 c0 H. simpl in H. inversion H; subst; clear H. auto. + - intros bdy' c2' H. simpl in H. destruct i; try ( + simpl in H; remember (to_bblock_body c1) as tbb; destruct tbb as [p c'']; + inversion H; subst; clear H; simpl; erewrite IHc1; eauto; fail). +Qed. + +Lemma to_bblock_exit_find_label c1 l c2 ext: + (ext, c2) = to_bblock_exit c1 + -> Mach.find_label l c1 = Mach.find_label l c2. +Proof. + intros H. destruct c1 as [|i c1]. + - simpl in H. inversion H; subst; clear H. auto. + - destruct i; try ( + simpl in H; inversion H; subst; clear H; auto; fail). +Qed. + +Lemma find_label_transcode_preserved: + forall l c c', + Mach.find_label l c = Some c' -> + exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). +Proof. + intros l c; induction c, (trans_code c) using trans_code_ind. + - intros c' H; inversion H. + - intros c' H. subst _x. destruct c as [| i c]; try tauto. + unfold to_bblock in * |-. + remember (to_bblock_header _) as bh; destruct bh as [h c1]. + remember (to_bblock_body _) as bb; destruct bb as [bdy c2]. + remember (to_bblock_exit _) as be; destruct be as [ext c3]. + simpl; injection e0; intros; subst; clear e0. + unfold is_label; simpl; destruct (in_dec l h) as [Y|Y]. + + clear IHc0. + eapply find_label_stop; eauto. + unfold to_bblock. + rewrite <- Heqbh, <- Heqbb, <- Heqbe. + auto. + + exploit IHc0; eauto. clear IHc0. + rewrite <- H. + erewrite (to_bblock_header_find_label (i::c) l c1); eauto. + erewrite (to_bblock_body_find_label c1 l c2); eauto. + erewrite (to_bblock_exit_find_label c2 l c0); eauto. +Qed. + + +Lemma find_label_preserved: + forall l f c, + Mach.find_label l (Mach.fn_code f) = Some c -> + exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). +Proof. + intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. + apply find_label_transcode_preserved; auto. +Qed. + +Lemma mem_free_preserved: + forall m stk f, + Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)). +Proof. + intros. auto. +Qed. + +Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated + parent_sp_preserved. + +Definition dist_end_block_code (c: Mach.code) := (size (fst (to_bblock c))-1)%nat. + + +Definition dist_end_block (s: Mach.state): nat := + match s with + | Mach.State _ _ _ c _ _ => dist_end_block_code c + | _ => 0 + end. + +Local Hint Resolve exec_nil_body exec_cons_body. +Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. + +Ltac ExploitDistEndBlockCode := + match goal with + | [ H : dist_end_block_code (Mlabel ?l :: ?c) <> 0%nat |- _ ] => + exploit (to_bblock_size_single_label c (Mlabel l)); eauto + | [ H : dist_end_block_code (?i0 :: ?c) <> 0%nat |- _ ] => + exploit (to_bblock_size_single_basic c i0); eauto + | _ => idtac + end. + +Ltac totologize H := + match type of H with + | ( ?id = _ ) => + let Hassert := fresh "Htoto" in ( + assert (id = id) as Hassert; auto; rewrite H in Hassert at 2; simpl in Hassert; rewrite H in Hassert) + end. + +Lemma dist_end_block_code_simu_mid_block i c: + dist_end_block_code (i::c) <> 0 -> + (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). +Proof. + intros H. + unfold dist_end_block_code. + destruct (get_code_nature (i::c)) eqn:GCNIC. + - apply get_code_nature_empty in GCNIC. discriminate. + - rewrite to_bblock_size_single_label; auto. + destruct c as [|i' c]. + + contradict H. destruct i; simpl; auto. + + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. omega. + - destruct (get_code_nature c) eqn:GCNC. + + apply get_code_nature_empty in GCNC. subst. contradict H. destruct i; simpl; auto. + + contradict H. destruct c as [|i' c]; try discriminate. + destruct i'; try discriminate. + destruct i; try discriminate. all: simpl; auto. + + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. + erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ]. + simpl. destruct c as [|i' c]; try discriminate. + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. + cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))). + unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega. + rewrite to_bblock_noLabel. simpl; auto. + rewrite GCNC. discriminate. + omega. + + destruct (to_basic_inst i) eqn:TBI; [| destruct i; discriminate]. + erewrite to_bblock_basic; eauto; [| rewrite GCNC; discriminate ]. + simpl. destruct c as [|i' c]; try discriminate. + assert (size (fst (to_bblock (i'::c))) <> 0). apply to_bblock_nonil. + cutrewrite (Datatypes.S (size (fst (to_bblock (i'::c))) - 1) = size (fst (to_bblock (i'::c)))). + unfold size. cutrewrite (length (header (fst (to_bblock (i' :: c)))) = 0). simpl. omega. + rewrite to_bblock_noLabel. simpl; auto. + rewrite GCNC. discriminate. + omega. + - contradict H. destruct i; try discriminate. + all: unfold dist_end_block_code; erewrite to_bblock_CFI; eauto; simpl; eauto. +Qed. + +Local Hint Resolve dist_end_block_code_simu_mid_block. + +Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): + to_basic_inst i = Some bi -> + Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. +Proof. + destruct i; simpl in * |-; + (discriminate + || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). + - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. + destruct H3 as (tf & A & B). subst. eapply A. + all: simpl; rewrite <- parent_sp_preserved; auto. + - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto. + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. +Qed. + + +Lemma star_step_simu_body_step s f sp c: + forall (p:bblock_body) c' rs m t s', + to_bblock_body c = (p, c') -> + starN (Mach.step (inv_trans_rao rao)) ge (length p) (Mach.State s f sp c rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp p rs m rs' m'. +Proof. + induction c as [ | i0 c0 Hc0]; simpl; intros p c' rs m t s' H. + * (* nil *) + inversion_clear H; simpl; intros X; inversion_clear X. + eapply ex_intro; eapply ex_intro; intuition eauto. + * (* cons *) + remember (to_basic_inst i0) as o eqn:Ho. + destruct o as [bi |]. + + (* to_basic_inst i0 = Some bi *) + remember (to_bblock_body c0) as r eqn:Hr. + destruct r as [p1 c1]; inversion H; simpl; subst; clear H. + intros X; inversion_clear X. + exploit step_simu_basic_step; eauto. + intros [rs' [m' [H2 [H3 H4]]]]; subst. + exploit Hc0; eauto. + intros [rs'' [m'' [H5 [H6 H7]]]]; subst. + refine (ex_intro _ rs'' (ex_intro _ m'' _)); intuition eauto. + + (* to_basic_inst i0 = None *) + inversion_clear H; simpl. + intros X; inversion_clear X. intuition eauto. +Qed. + +Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit. +Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same. + +Lemma match_states_concat_trans_code st f sp c rs m h: + match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). +Proof. + constructor 1; simpl. + + intros (t0 & s1' & H0) t s'. + rewrite! trans_code_equation. + destruct c as [| i c]. { inversion H0. } + remember (to_bblock (i :: c)) as bic. destruct bic as [b c0]. + simpl. + constructor 1; intros H; inversion H; subst; simpl in * |- *; + eapply exec_bblock; eauto. + - inversion H11; subst; eauto. + inversion H2; subst; eauto. + - inversion H11; subst; simpl; eauto. + inversion H2; subst; simpl; eauto. + + intros H r; constructor 1; intro X; inversion X. +Qed. + +Lemma step_simu_cfi_step: + forall c e c' stk f sp rs m t s' b lb', + to_bblock_exit c = (Some e, c') -> + trans_code c' = lb' -> + Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp c rs m) t s' -> + exists s2, cfi_step rao tge e (State (trans_stack stk) f sp (b::lb') rs m) t s2 /\ match_states s' s2. +Proof. + intros c e c' stk f sp rs m t s' b lb'. + intros Hexit Htc Hstep. + destruct c as [|ei c]; try (contradict Hexit; discriminate). + destruct ei; (contradict Hexit; discriminate) || ( + inversion Hexit; subst; inversion Hstep; subst; simpl + ). + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + apply exec_MBcall with (f := (transf_function f0)); auto. + rewrite find_function_ptr_same in H9; auto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + apply exec_MBtailcall with (f := (transf_function f0)); auto. + rewrite find_function_ptr_same in H9; auto. + rewrite parent_sp_preserved in H11; subst; auto. + rewrite parent_ra_preserved in H12; subst; auto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBbuiltin; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBcond_false; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBreturn; eauto. + rewrite parent_sp_preserved in H8; subst; auto. + rewrite parent_ra_preserved in H9; subst; auto. +Qed. + + + +Lemma step_simu_exit_step c e c' stk f sp rs m t s' b: + to_bblock_exit c = (e, c') -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s' -> + exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::trans_code c') rs m) t s2 /\ match_states s' s2. +Proof. + intros H1 H2; destruct e as [ e |]; inversion_clear H2. + + (* Some *) inversion H0; clear H0; subst. autorewrite with trace_rewrite. + exploit step_simu_cfi_step; eauto. + intros (s2' & H2 & H3); eapply ex_intro; intuition eauto. + + (* None *) + destruct c as [ |i c]; simpl in H1; inversion H1. + - eapply ex_intro; intuition eauto; try eapply match_states_trans_state. + - remember to_cfi as o. destruct o; try discriminate. + inversion_clear H1. + eapply ex_intro; intuition eauto; try eapply match_states_trans_state. +Qed. + +Lemma step_simu_header st f sp rs m s c: forall h c' t, + (h, c') = to_bblock_header c -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> s = Mach.State st f sp c' rs m /\ t = E0. +Proof. + induction c as [ | i c]; simpl; intros h c' t H. + - inversion_clear H. simpl; intros H; inversion H; auto. + - destruct i; try (injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst; auto). + remember (to_bblock_header c) as bhc. destruct bhc as [h0 c0]. + injection H; clear H; intros H H2; subst; simpl; intros H; inversion H; subst. + inversion H1; clear H1; subst; auto. autorewrite with trace_rewrite. + exploit IHc; eauto. +Qed. + +Lemma simu_end_block: + forall s1 t s1', + starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> + exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'. +Proof. + destruct s1; simpl. + + (* State *) + (* c cannot be nil *) + destruct c as [|i c]; simpl; try ( (* nil => absurd *) + unfold dist_end_block_code; simpl; + intros t s1' H; inversion_clear H; + inversion_clear H0; fail + ). + + intros t s1' H. + remember (_::_) as c0. remember (trans_code c0) as tc0. + + (* tc0 cannot be nil *) + destruct tc0; try + ( exploit (trans_code_nonil c0); subst; auto; try discriminate; intro H0; contradict H0 ). + + assert (X: Datatypes.S (dist_end_block_code c0) = (size (fst (to_bblock c0)))). + { + unfold dist_end_block_code. remember (size _) as siz. + assert (siz <> 0%nat). rewrite Heqsiz; subst; apply to_bblock_nonil with (c0 := c) (i := i); auto. + omega. + } + + (* decomposition of starN in 3 parts: header + body + exit *) + rewrite X in H; unfold size in H. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as [t3 [t4 [s1 [H0 [H3 H4]]]]]. + subst t; clear X H. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as [t1 [t2 [s0 [H [H1 H2]]]]]. + subst t3; clear H0. + + unfold to_bblock in * |- *. + (* naming parts of block "b" *) + remember (to_bblock_header c0) as hd. destruct hd as [hb c1]. + remember (to_bblock_body c1) as bb. destruct bb as [bb c2]. + remember (to_bblock_exit c2) as exb. destruct exb as [exb c3]. + simpl in * |- *. + + exploit trans_code_step; eauto. intro EQ. destruct EQ as (EQH & EQB & EQE & EQTB0). + subst hb bb exb. + + (* header opt step *) + exploit step_simu_header; eauto. + intros [X1 X2]; subst s0 t1. + autorewrite with trace_rewrite. + (* body steps *) + exploit (star_step_simu_body_step); eauto. + clear H1; intros [rs' [m' [H0 [H1 H2]]]]. + subst s1 t2. autorewrite with trace_rewrite. + (* exit step *) + subst tc0. + exploit step_simu_exit_step; eauto. clear H3. + intros (s2' & H3 & H4). + eapply ex_intro; intuition eauto. + eapply exec_bblock; eauto. + + (* Callstate *) + intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + - (* function_internal*) + cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. + eapply exec_function_internal; eauto. + rewrite <- parent_sp_preserved; eauto. + rewrite <- parent_ra_preserved; eauto. + - (* function_external *) + autorewrite with trace_rewrite. + eapply exec_function_external; eauto. + apply find_funct_ptr_same_external; auto. + rewrite <- parent_sp_preserved; eauto. + + (* Returnstate *) + intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + eapply exec_return. +Qed. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). +Proof. + apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). +(* simu_mid_block *) + - intros s1 t s1' H1. + destruct H1; simpl; omega || (intuition auto). +(* public_preserved *) + - apply senv_preserved. +(* match_initial_states *) + - intros. simpl. + eapply ex_intro; constructor 1. + eapply match_states_trans_state. + destruct H. split. + apply init_mem_preserved; auto. + rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. +(* match_final_states *) + - intros. simpl. destruct H. split with (r := r); auto. +(* final_states_end_block *) + - intros. simpl in H0. inversion H0. + inversion H; simpl; auto. + (* the remaining instructions cannot lead to a Returnstate *) + all: subst; discriminate. +(* simu_end_block *) + - apply simu_end_block. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v new file mode 100644 index 00000000..bed3c040 --- /dev/null +++ b/mppa_k1c/Machregs.v @@ -0,0 +1,229 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +Require Import String. +Require Import Coqlib. +Require Import Decidableplus. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Op. + +(** ** Machine registers *) + +(** The following type defines the machine registers that can be referenced + as locations. These include: +- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). +- Floating-point registers that can be allocated to RTL pseudo-registers + ([Fxx]). + + The type [mreg] does not include reserved machine registers such as + the zero register (x0), the link register (x1), the stack pointer + (x2), the global pointer (x3), and the thread pointer (x4). + Finally, register x31 is reserved for use as a temporary by the + assembly-code generator [Asmgen]. +*) + +(* FIXME - no R31 *) +Inductive mreg: Type := + (* Allocatable General Purpose regs. *) + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R9 + | R10 (* R11 to R14 res *) | R15 | R16 | R17 | R18 | R19 + | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 + | R30 | R32 | R33 | R34 | R35 | R36 | R37 | R38 | R39 + | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 + | R50 | R51 | R52 | R53 | R54 | R55 | R56 | R57 | R58 | R59 + | R60 | R61 | R62 | R63. + +Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. +Proof. decide equality. Defined. +Global Opaque mreg_eq. + +Definition all_mregs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R9 + :: R10 :: R15 :: R16 :: R17 :: R18 :: R19 + :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 + :: R30 :: R32 :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 + :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 + :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 + :: R60 :: R61 :: R62 :: R63 :: nil. + +Lemma all_mregs_complete: + forall (r: mreg), In r all_mregs. +Proof. + assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity). + intros. specialize (H r). InvBooleans. auto. +Qed. + +Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. + +Instance Finite_mreg : Finite mreg := { + Finite_elements := all_mregs; + Finite_elements_spec := all_mregs_complete +}. + +Definition mreg_type (r: mreg): typ := Tany64. + +Open Scope positive_scope. + +Module IndexedMreg <: INDEXED_TYPE. + Definition t := mreg. + Definition eq := mreg_eq. + Definition index (r: mreg): positive := + match r with + | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 + | R5 => 6 | R6 => 7 | R7 => 8 | R9 => 10 + | R10 => 11 + | R15 => 16 | R16 => 17 | R17 => 18 | R18 => 19 | R19 => 20 + | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 + | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 + | R30 => 31 | R32 => 33 | R33 => 34 | R34 => 35 + | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 + | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 + | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 + | R50 => 51 | R51 => 52 | R52 => 53 | R53 => 54 | R54 => 55 + | R55 => 56 | R56 => 57 | R57 => 58 | R58 => 59 | R59 => 60 + | R60 => 61 | R61 => 62 | R62 => 63 | R63 => 64 + end. + + Lemma index_inj: + forall r1 r2, index r1 = index r2 -> r1 = r2. + Proof. + decide_goal. + Qed. +End IndexedMreg. + +Definition is_stack_reg (r: mreg) : bool := false. + +(** ** Names of registers *) + +Local Open Scope string_scope. + +Definition register_names := + ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) + :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R9" , R9) + :: ("R10", R10) + :: ("R15", R15) :: ("R16", R16) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) + :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) + :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) + :: ("R30", R30) :: ("R32", R32) :: ("R33", R33) :: ("R34", R34) + :: ("R35", R35) :: ("R36", R36) :: ("R37", R37) :: ("R38", R38) :: ("R39", R39) + :: ("R40", R40) :: ("R41", R41) :: ("R42", R42) :: ("R43", R43) :: ("R44", R44) + :: ("R45", R45) :: ("R46", R46) :: ("R47", R47) :: ("R48", R48) :: ("R49", R49) + :: ("R50", R50) :: ("R51", R51) :: ("R52", R52) :: ("R53", R53) :: ("R54", R54) + :: ("R55", R55) :: ("R56", R56) :: ("R57", R57) :: ("R58", R58) :: ("R59", R59) + :: ("R60", R60) :: ("R61", R61) :: ("R62", R62) :: ("R63", R63) :: nil. + +Definition register_by_name (s: string) : option mreg := + let fix assoc (l: list (string * mreg)) : option mreg := + match l with + | nil => None + | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l' + end + in assoc register_names. + +(** ** Destroyed registers, preferred registers *) + +Definition destroyed_by_op (op: operation): list mreg := nil. +(*match op with + | Ointoffloat | Ointuoffloat | Ointofsingle | Ointuofsingle + | Olongoffloat | Olonguoffloat | Olongofsingle | Olonguofsingle + => F6 :: nil + | _ => nil + end. +*) + +Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := nil. + +Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := nil. + +Definition destroyed_by_cond (cond: condition): list mreg := nil. + +(* Definition destroyed_by_jumptable: list mreg := R5 :: nil. *) +Definition destroyed_by_jumptable: list mreg := nil. + +Fixpoint destroyed_by_clobber (cl: list string): list mreg := + match cl with + | nil => nil + | c1 :: cl => + match register_by_name c1 with + | Some r => r :: destroyed_by_clobber cl + | None => destroyed_by_clobber cl + end + end. + +Definition destroyed_by_builtin (ef: external_function): list mreg := + match ef with + | EF_inline_asm txt sg clob => destroyed_by_clobber clob +(*| EF_memcpy sz al => R5 :: R6 :: R7 :: F0 :: nil *) + | _ => nil + end. + +Definition destroyed_by_setstack (ty: typ): list mreg := nil. + +Definition destroyed_at_function_entry: list mreg := R10 :: nil. + +Definition temp_for_parent_frame: mreg := R10. (* FIXME - and R8 ?? *) + +Definition destroyed_at_indirect_call: list mreg := nil. + (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) + +Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). + +Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := (nil, nil). + (* match ef with + | EF_builtin name sg => + if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then + (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) + else + (nil, nil) + | _ => + (nil, nil) + end. *) + +Global Opaque + destroyed_by_op destroyed_by_load destroyed_by_store + destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin + destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame + mregs_for_operation mregs_for_builtin. + +(** Two-address operations. Return [true] if the first argument and + the result must be in the same location *and* are unconstrained + by [mregs_for_operation]. There are two: the pseudo [Ocast32signed], + because it expands to a no-op owing to the representation of 32-bit + integers as their 64-bit sign extension; and [Ocast32unsigned], + because it builds on the same magic no-op. *) + +Definition two_address_op (op: operation) : bool := + match op with + | Ocast32unsigned => true + | _ => false + end. + +(** Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_builtin id sg => nil + | EF_vload _ => OK_addressing :: nil + | EF_vstore _ => OK_addressing :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot kind txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/mppa_k1c/Machregsaux.ml b/mppa_k1c/Machregsaux.ml new file mode 100644 index 00000000..473e0602 --- /dev/null +++ b/mppa_k1c/Machregsaux.ml @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +open Camlcoq +open Machregs + +let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 + +let _ = + List.iter + (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) + Machregs.register_names + +let is_scratch_register r = false + +let name_of_register r = + try Some (Hashtbl.find register_names r) with Not_found -> None + +let register_by_name s = + Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) + +let can_reserve_register r = Conventions1.is_callee_save r diff --git a/mppa_k1c/Machregsaux.mli b/mppa_k1c/Machregsaux.mli new file mode 100644 index 00000000..9404568d --- /dev/null +++ b/mppa_k1c/Machregsaux.mli @@ -0,0 +1,18 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +val name_of_register: Machregs.mreg -> string option +val register_by_name: string -> Machregs.mreg option +val is_scratch_register: string -> bool +val can_reserve_register: Machregs.mreg -> bool diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v new file mode 100644 index 00000000..117bbcb4 --- /dev/null +++ b/mppa_k1c/NeedOp.v @@ -0,0 +1,173 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs. +Require Import Op RTL. +Require Import NeedDomain. + +(** Neededness analysis for RISC-V operators *) + +Definition op1 (nv: nval) := nv :: nil. +Definition op2 (nv: nval) := nv :: nv :: nil. + +Definition needs_of_condition (cond: condition): list nval := nil. + +Definition needs_of_operation (op: operation) (nv: nval): list nval := + match op with + | Omove => op1 nv + | Ointconst n => nil + | Olongconst n => nil + | Ofloatconst n => nil + | Osingleconst n => nil + | Oaddrsymbol id ofs => nil + | Oaddrstack ofs => nil + | Ocast8signed => op1 (sign_ext 8 nv) + | Ocast16signed => op1 (sign_ext 16 nv) + | Oadd => op2 (modarith nv) + | Oaddimm n => op1 (modarith nv) + | Oneg => op1 (modarith nv) + | Osub => op2 (default nv) + | Omul => op2 (modarith nv) + | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) + | Oand => op2 (bitwise nv) + | Oandimm n => op1 (andimm nv n) + | Oor => op2 (bitwise nv) + | Oorimm n => op1 (orimm nv n) + | Oxor => op2 (bitwise nv) + | Oxorimm n => op1 (bitwise nv) + | Oshl | Oshr | Oshru => op2 (default nv) + | Oshlimm n => op1 (shlimm nv n) + | Oshrimm n => op1 (shrimm nv n) + | Oshruimm n => op1 (shruimm nv n) + | Oshrximm n => op1 (default nv) + | Omakelong => op2 (default nv) + | Olowlong | Ohighlong => op1 (default nv) + | Ocast32signed => op1 (default nv) + | Ocast32unsigned => op1 (default nv) + | Oaddl => op2 (default nv) + | Oaddlimm n => op1 (default nv) + | Onegl => op1 (default nv) + | Osubl => op2 (default nv) + | Omull => op2 (default nv) + | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) + | Oandl => op2 (default nv) + | Oandlimm n => op1 (default nv) + | Oorl => op2 (default nv) + | Oorlimm n => op1 (default nv) + | Oxorl => op2 (default nv) + | Oxorlimm n => op1 (default nv) + | Oshll | Oshrl | Oshrlu => op2 (default nv) + | Oshllimm n => op1 (default nv) + | Oshrlimm n => op1 (default nv) + | Oshrluimm n => op1 (default nv) + | Oshrxlimm n => op1 (default nv) + | Onegf | Oabsf => op1 (default nv) + | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) + | Onegfs | Oabsfs => op1 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) + | Ofloatofsingle | Osingleoffloat => op1 (default nv) + | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv) + | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) + | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) + | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) + | Ocmp c => needs_of_condition c + end. + +Definition operation_is_redundant (op: operation) (nv: nval): bool := + match op with + | Ocast8signed => sign_ext_redundant 8 nv + | Ocast16signed => sign_ext_redundant 16 nv + | Oandimm n => andimm_redundant nv n + | Oorimm n => orimm_redundant nv n + | _ => false + end. + +Ltac InvAgree := + match goal with + | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree + | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree + | _ => idtac + end. + +Ltac TrivialExists := + match goal with + | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto + | _ => idtac + end. + +Section SOUNDNESS. + +Variable ge: genv. +Variable sp: block. +Variables m m': mem. +Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p. + +Lemma needs_of_condition_sound: + forall cond args b args', + eval_condition cond args m = Some b -> + vagree_list args args' (needs_of_condition cond) -> + eval_condition cond args' m' = Some b. +Proof. + intros. unfold needs_of_condition in H0. + eapply default_needs_of_condition_sound; eauto. +Qed. + +Lemma needs_of_operation_sound: + forall op args v nv args', + eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v -> + vagree_list args args' (needs_of_operation op nv) -> + nv <> Nothing -> + exists v', + eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v' + /\ vagree v v' nv. +Proof. + unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); + simpl in *; FuncInv; InvAgree; TrivialExists. +- apply sign_ext_sound; auto. compute; auto. +- apply sign_ext_sound; auto. compute; auto. +- apply add_sound; auto. +- apply add_sound; auto with na. +- apply neg_sound; auto. +- apply mul_sound; auto. +- apply and_sound; auto. +- apply andimm_sound; auto. +- apply or_sound; auto. +- apply orimm_sound; auto. +- apply xor_sound; auto. +- apply xor_sound; auto with na. +- apply shlimm_sound; auto. +- apply shrimm_sound; auto. +- apply shruimm_sound; auto. +Qed. + +Lemma operation_is_redundant_sound: + forall op nv arg1 args v arg1' args', + operation_is_redundant op nv = true -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v -> + vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> + vagree v arg1' nv. +Proof. + intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. +- apply sign_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. omega. +- apply andimm_redundant_sound; auto. +- apply orimm_redundant_sound; auto. +Qed. + +End SOUNDNESS. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v new file mode 100644 index 00000000..74101f53 --- /dev/null +++ b/mppa_k1c/Op.v @@ -0,0 +1,1359 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Operators and addressing modes. The abstract syntax and dynamic + semantics for the CminorSel, RTL, LTL and Mach languages depend on the + following types, defined in this library: +- [condition]: boolean conditions for conditional branches; +- [operation]: arithmetic and logical operations; +- [addressing]: addressing modes for load and store operations. + + These types are processor-specific and correspond roughly to what the + processor can compute in one instruction. In other terms, these + types reflect the state of the program after instruction selection. + For a processor-independent set of operations, see the abstract + syntax and dynamic semantics of the Cminor language. +*) + +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. + +Set Implicit Arguments. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Type := + | Ccomp (c: comparison) (**r signed integer comparison *) + | Ccompu (c: comparison) (**r unsigned integer comparison *) + | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *) + | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *) + | Ccompl (c: comparison) (**r signed 64-bit integer comparison *) + | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *) + | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *) + | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *) + | 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 *) + +(** Arithmetic and logical operations. In the descriptions, [rd] is the + result of the operation and [r1], [r2], etc, are the arguments. *) + +Inductive operation : Type := + | Omove (**r [rd = r1] *) + | Ointconst (n: int) (**r [rd] is set to the given integer constant *) + | Olongconst (n: int64) (**r [rd] is set to the given integer constant *) + | Ofloatconst (n: float) (**r [rd] is set to the given float constant *) + | Osingleconst (n: float32)(**r [rd] is set to the given float constant *) + | Oaddrsymbol (id: ident) (ofs: ptrofs) (**r [rd] is set to the address of the symbol plus the given offset *) + | Oaddrstack (ofs: ptrofs) (**r [rd] is set to the stack pointer plus the given offset *) +(*c 32-bit integer arithmetic: *) + | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *) + | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) + | Oadd (**r [rd = r1 + r2] *) + | Oaddimm (n: int) (**r [rd = r1 + n] *) + | Oneg (**r [rd = - r1] *) + | Osub (**r [rd = r1 - r2] *) + | Omul (**r [rd = r1 * r2] *) + | Omulhs (**r [rd = high part of r1 * r2, signed] *) + | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odiv (**r [rd = r1 / r2] (signed) *) + | Odivu (**r [rd = r1 / r2] (unsigned) *) + | Omod (**r [rd = r1 % r2] (signed) *) + | Omodu (**r [rd = r1 % r2] (unsigned) *) + | Oand (**r [rd = r1 & r2] *) + | Oandimm (n: int) (**r [rd = r1 & n] *) + | Oor (**r [rd = r1 | r2] *) + | Oorimm (n: int) (**r [rd = r1 | n] *) + | Oxor (**r [rd = r1 ^ r2] *) + | Oxorimm (n: int) (**r [rd = r1 ^ n] *) + | Oshl (**r [rd = r1 << r2] *) + | Oshlimm (n: int) (**r [rd = r1 << n] *) + | Oshr (**r [rd = r1 >> r2] (signed) *) + | Oshrimm (n: int) (**r [rd = r1 >> n] (signed) *) + | Oshru (**r [rd = r1 >> r2] (unsigned) *) + | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) +(*c 64-bit integer arithmetic: *) + | Omakelong (**r [rd = r1 << 32 | r2] *) + | Olowlong (**r [rd = low-word(r1)] *) + | Ohighlong (**r [rd = high-word(r1)] *) + | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *) + | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) + | Oaddl (**r [rd = r1 + r2] *) + | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Onegl (**r [rd = - r1] *) + | Osubl (**r [rd = r1 - r2] *) + | Omull (**r [rd = r1 * r2] *) + | Omullhs (**r [rd = high part of r1 * r2, signed] *) + | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odivl (**r [rd = r1 / r2] (signed) *) + | Odivlu (**r [rd = r1 / r2] (unsigned) *) + | Omodl (**r [rd = r1 % r2] (signed) *) + | Omodlu (**r [rd = r1 % r2] (unsigned) *) + | Oandl (**r [rd = r1 & r2] *) + | Oandlimm (n: int64) (**r [rd = r1 & n] *) + | Oorl (**r [rd = r1 | r2] *) + | Oorlimm (n: int64) (**r [rd = r1 | n] *) + | Oxorl (**r [rd = r1 ^ r2] *) + | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) + | Oshll (**r [rd = r1 << r2] *) + | Oshllimm (n: int) (**r [rd = r1 << n] *) + | Oshrl (**r [rd = r1 >> r2] (signed) *) + | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *) + | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) + | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) +(*c Floating-point arithmetic: *) + | Onegf (**r [rd = - r1] *) + | Oabsf (**r [rd = abs(r1)] *) + | Oaddf (**r [rd = r1 + r2] *) + | Osubf (**r [rd = r1 - r2] *) + | Omulf (**r [rd = r1 * r2] *) + | Odivf (**r [rd = r1 / r2] *) + | Onegfs (**r [rd = - r1] *) + | Oabsfs (**r [rd = abs(r1)] *) + | Oaddfs (**r [rd = r1 + r2] *) + | Osubfs (**r [rd = r1 - r2] *) + | Omulfs (**r [rd = r1 * r2] *) + | Odivfs (**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: *) + | 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 (**r [rd = float32_of_unsigned_int(r1)] *) +(*c Boolean tests: *) + | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Type := + | Aindexed: ptrofs -> addressing (**r Address is [r1 + offset] *) + | Aglobal: ident -> ptrofs -> addressing (**r Address is global plus offset *) + | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in modules [CSE] and [Allocation]). *) + +Definition eq_condition (x y: condition) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + decide equality. +Defined. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize ident_eq Ptrofs.eq_dec; intros. + decide equality. +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. + decide equality. +Defined. + +(* Alternate definition: +Definition beq_operation: forall (x y: operation), bool. +Proof. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition; boolean_equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + decidable_equality_from beq_operation. +Defined. +*) + +Global Opaque eq_condition eq_addressing eq_operation. + +(** * Evaluation functions *) + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 + | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n) + | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | 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) + | _, _ => None + end. + +Definition eval_operation + (F V: Type) (genv: Genv.t F V) (sp: val) + (op: operation) (vl: list val) (m: mem): option val := + match op, vl with + | Omove, v1::nil => Some v1 + | Ointconst n, nil => Some (Vint n) + | Olongconst n, nil => Some (Vlong n) + | Ofloatconst n, nil => Some (Vfloat n) + | Osingleconst n, nil => Some (Vsingle n) + | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) + | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) + | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) + | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) + | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Oneg, v1 :: nil => Some (Val.neg v1) + | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) + | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) + | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) + | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 + | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 + | Omod, v1 :: v2 :: nil => Val.mods v1 v2 + | Omodu, v1 :: v2 :: nil => Val.modu v1 v2 + | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) + | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) + | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) + | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) + | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) + | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) + | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) + | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) + | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) + | Oshrimm n, v1 :: nil => Some (Val.shr v1 (Vint n)) + | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) + | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) + | Olowlong, v1::nil => Some (Val.loword v1) + | Ohighlong, v1::nil => Some (Val.hiword v1) + | Ocast32signed, v1 :: nil => Some (Val.longofint v1) + | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) + | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) + | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) + | Onegl, v1::nil => Some (Val.negl v1) + | Osubl, v1::v2::nil => Some (Val.subl v1 v2) + | Omull, v1::v2::nil => Some (Val.mull v1 v2) + | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) + | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) + | Odivl, v1::v2::nil => Val.divls v1 v2 + | Odivlu, v1::v2::nil => Val.divlu v1 v2 + | Omodl, v1::v2::nil => Val.modls v1 v2 + | Omodlu, v1::v2::nil => Val.modlu v1 v2 + | Oandl, v1::v2::nil => Some(Val.andl v1 v2) + | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) + | Oorl, v1::v2::nil => Some(Val.orl v1 v2) + | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) + | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) + | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | Oshll, v1::v2::nil => Some (Val.shll v1 v2) + | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) + | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) + | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) + | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) + | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) + | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) + | Onegf, v1::nil => Some (Val.negf v1) + | Oabsf, v1::nil => Some (Val.absf v1) + | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) + | Osubf, v1::v2::nil => Some (Val.subf v1 v2) + | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some (Val.divf v1 v2) + | Onegfs, v1::nil => Some (Val.negfs v1) + | Oabsfs, v1::nil => Some (Val.absfs v1) + | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) + | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) + | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) + | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) + | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) + | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 + | Ointofsingle, v1::nil => Val.intofsingle v1 + | Ointuofsingle, v1::nil => Val.intuofsingle v1 + | Osingleofint, v1::nil => Val.singleofint v1 + | Osingleofintu, v1::nil => Val.singleofintu v1 + | Olongoffloat, v1::nil => Val.longoffloat v1 + | Olonguoffloat, v1::nil => Val.longuoffloat v1 + | Ofloatoflong, v1::nil => Val.floatoflong v1 + | Ofloatoflongu, v1::nil => Val.floatoflongu v1 + | Olongofsingle, v1::nil => Val.longofsingle v1 + | Olonguofsingle, v1::nil => Val.longuofsingle v1 + | Osingleoflong, v1::nil => Val.singleoflong v1 + | Osingleoflongu, v1::nil => Val.singleoflongu v1 + | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) + | _, _ => None + end. + +Definition eval_addressing + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, v1 :: nil => Some (Val.offset_ptr v1 n) + | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Ainstack n, nil => Some (Val.offset_ptr sp n) + | _, _ => None + end. + +Remark eval_addressing_Ainstack: + forall (F V: Type) (genv: Genv.t F V) sp ofs, + eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). +Proof. + intros. reflexivity. +Qed. + +Remark eval_addressing_Ainstack_inv: + forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, + eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. +Proof. + unfold eval_addressing; intros; destruct vl; inv H; auto. +Qed. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; FuncInv + | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => + destruct Archi.ptr64 eqn:?; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | H: (None = Some _) |- _ => + discriminate H + | _ => + idtac + end. + +(** * Static typing of conditions, operators and addressing modes. *) + +Definition type_of_condition (c: condition) : list typ := + match c with + | Ccomp _ => Tint :: Tint :: nil + | Ccompu _ => Tint :: Tint :: nil + | Ccompimm _ _ => Tint :: nil + | Ccompuimm _ _ => Tint :: nil + | Ccompl _ => Tlong :: Tlong :: nil + | Ccomplu _ => Tlong :: Tlong :: nil + | Ccomplimm _ _ => Tlong :: nil + | Ccompluimm _ _ => Tlong :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + | Ccompfs _ => Tsingle :: Tsingle :: nil + | Cnotcompfs _ => Tsingle :: Tsingle :: nil + end. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Olongconst _ => (nil, Tlong) + | Ofloatconst f => (nil, Tfloat) + | Osingleconst f => (nil, Tsingle) + | Oaddrsymbol _ _ => (nil, Tptr) + | Oaddrstack _ => (nil, Tptr) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Oneg => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Omulhs => (Tint :: Tint :: nil, Tint) + | Omulhu => (Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Omod => (Tint :: Tint :: nil, Tint) + | Omodu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshlimm _ => (Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshrimm _ => (Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshruimm _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Omakelong => (Tint :: Tint :: nil, Tlong) + | Olowlong => (Tlong :: nil, Tint) + | Ohighlong => (Tlong :: nil, Tint) + | Ocast32signed => (Tint :: nil, Tlong) + | Ocast32unsigned => (Tint :: nil, Tlong) + | Oaddl => (Tlong :: Tlong :: nil, Tlong) + | Oaddlimm _ => (Tlong :: nil, Tlong) + | Onegl => (Tlong :: nil, Tlong) + | Osubl => (Tlong :: Tlong :: nil, Tlong) + | Omull => (Tlong :: Tlong :: nil, Tlong) + | Omullhs => (Tlong :: Tlong :: nil, Tlong) + | Omullhu => (Tlong :: Tlong :: nil, Tlong) + | Odivl => (Tlong :: Tlong :: nil, Tlong) + | Odivlu => (Tlong :: Tlong :: nil, Tlong) + | Omodl => (Tlong :: Tlong :: nil, Tlong) + | Omodlu => (Tlong :: Tlong :: nil, Tlong) + | Oandl => (Tlong :: Tlong :: nil, Tlong) + | Oandlimm _ => (Tlong :: nil, Tlong) + | Oorl => (Tlong :: Tlong :: nil, Tlong) + | Oorlimm _ => (Tlong :: nil, Tlong) + | Oxorl => (Tlong :: Tlong :: nil, Tlong) + | Oxorlimm _ => (Tlong :: nil, Tlong) + | Oshll => (Tlong :: Tint :: nil, Tlong) + | Oshllimm _ => (Tlong :: nil, Tlong) + | Oshrl => (Tlong :: Tint :: nil, Tlong) + | Oshrlimm _ => (Tlong :: nil, Tlong) + | Oshrlu => (Tlong :: Tint :: nil, Tlong) + | Oshrluimm _ => (Tlong :: nil, Tlong) + | Oshrxlimm _ => (Tlong :: nil, Tlong) + | Onegf => (Tfloat :: nil, Tfloat) + | Oabsf => (Tfloat :: nil, Tfloat) + | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) + | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) + | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) + | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) + | Onegfs => (Tsingle :: nil, Tsingle) + | Oabsfs => (Tsingle :: nil, Tsingle) + | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Osingleoffloat => (Tfloat :: nil, Tsingle) + | Ofloatofsingle => (Tsingle :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) + | Ointofsingle => (Tsingle :: nil, Tint) + | Ointuofsingle => (Tsingle :: nil, Tint) + | Osingleofint => (Tint :: nil, Tsingle) + | Osingleofintu => (Tint :: nil, Tsingle) + | Olongoffloat => (Tfloat :: nil, Tlong) + | Olonguoffloat => (Tfloat :: nil, Tlong) + | Ofloatoflong => (Tlong :: nil, Tfloat) + | Ofloatoflongu => (Tlong :: nil, Tfloat) + | Olongofsingle => (Tsingle :: nil, Tlong) + | Olonguofsingle => (Tsingle :: nil, Tlong) + | Osingleoflong => (Tlong :: nil, Tsingle) + | Osingleoflongu => (Tlong :: nil, Tsingle) + | Ocmp c => (type_of_condition c, Tint) + end. + +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed _ => Tptr :: nil + | Aglobal _ _ => nil + | Ainstack _ => nil + end. + +(** Weak type soundness results for [eval_operation]: + the result values, when defined, are always of the type predicted + by [type_of_operation]. *) + +Section SOUNDNESS. + +Variable A V: Type. +Variable genv: Genv.t A V. + +Remark type_add: + forall v1 v2, Val.has_type (Val.add v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Remark type_addl: + forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Lemma type_of_operation_sound: + forall op vl sp v m, + op <> Omove -> + eval_operation genv sp op vl m = Some v -> + Val.has_type v (snd (type_of_operation op)). +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. + (* intconst, longconst, floatconst, singleconst *) + - exact I. + - exact I. + - exact I. + - exact I. + (* addrsymbol *) + - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)... + (* addrstack *) + - destruct sp... + (* castsigned *) + - destruct v0... + - destruct v0... + (* add, addimm *) + - apply type_add. + - apply type_add. + (* neg, sub *) + - destruct v0... + - unfold Val.sub. destruct v0; destruct v1... + (* mul, mulhs, mulhu *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* div, divu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero); inv H2... + (* mod, modu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero); inv H2... + (* and, andimm *) + - destruct v0; destruct v1... + - destruct v0... + (* or, orimm *) + - destruct v0; destruct v1... + - destruct v0... + (* xor, xorimm *) + - destruct v0; destruct v1... + - destruct v0... + (* shl, shlimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shr, shrimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shru, shruimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shrx *) + - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + (* makelong, lowlong, highlong *) + - destruct v0; destruct v1... + - destruct v0... + - destruct v0... + (* cast32 *) + - destruct v0... + - destruct v0... + (* addl, addlimm *) + - apply type_addl. + - apply type_addl. + (* negl, subl *) + - destruct v0... + - unfold Val.subl. destruct v0; destruct v1... + unfold Val.has_type; destruct Archi.ptr64... + destruct (eq_block b b0)... + (* mull, mullhs, mullhu *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* divl, divlu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero); inv H2... + (* modl, modlu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero); inv H2... + (* andl, andlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* orl, orlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* xorl, xorlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* shll, shllimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shr, shrimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shru, shruimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shrxl *) + - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + (* negf, absf *) + - destruct v0... + - destruct v0... + (* addf, subf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* mulf, divf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* negfs, absfs *) + - destruct v0... + - destruct v0... + (* addfs, subfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* mulfs, divfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* singleoffloat, floatofsingle *) + - destruct v0... + - destruct v0... + (* intoffloat, intuoffloat *) + - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + (* floatofint, floatofintu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* intofsingle, intuofsingle *) + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... + (* singleofint, singleofintu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* longoffloat, longuoffloat *) + - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2... + (* floatoflong, floatoflongu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* longofsingle, longuofsingle *) + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... + - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2... + (* singleoflong, singleoflongu *) + - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl in H0; inv H0... + (* cmp *) + - destruct (eval_condition cond vl m)... destruct b... +Qed. + +End SOUNDNESS. + +(** * Manipulating and transforming operations *) + +(** Recognition of move operations. *) + +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None + end. + +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompl c => Ccompl(negate_comparison c) + | Ccomplu c => Ccomplu(negate_comparison c) + | Ccomplimm c n => Ccomplimm (negate_comparison c) n + | Ccompluimm c n => Ccompluimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Ccompfs c => Cnotcompfs c + | Cnotcompfs c => Ccompfs c + end. + +Lemma eval_negate_condition: + forall cond vl m, + eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). +Proof. + intros. destruct cond; simpl. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). + 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. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: Z) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => addr + end. + +Definition shift_stack_operation (delta: Z) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +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. +Qed. + +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. destruct addr; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + 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. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +(** Offset an addressing mode [addr] by a quantity [delta], so that + it designates the pointer [delta] bytes past the pointer designated + by [addr]. May be undefined, in which case [None] is returned. *) + +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := + match addr with + | Aindexed n => Some(Aindexed (Ptrofs.add n (Ptrofs.repr delta))) + | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta))) + | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) + end. + +Lemma eval_offset_addressing: + forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, + offset_addressing addr delta = Some addr' -> + eval_addressing ge sp addr args = Some v -> + Archi.ptr64 = false -> + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). +Proof. + intros. + assert (A: forall x n, + Val.offset_ptr x (Ptrofs.add n (Ptrofs.repr delta)) = + Val.add (Val.offset_ptr x n) (Vint (Int.repr delta))). + { intros; destruct x; simpl; auto. rewrite H1. + rewrite Ptrofs.add_assoc. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. } + destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. +- rewrite A; auto. +- unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. + simpl. rewrite H1. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. +- rewrite A; auto. +Qed. + +(** Operations that are so cheap to recompute that CSE should not factor them out. *) + +Definition is_trivial_op (op: operation) : bool := + match op with + | Omove => true + | Ointconst n => Int.eq (Int.sign_ext 12 n) n + | Olongconst n => Int64.eq (Int64.sign_ext 12 n) n + | Oaddrstack _ => true + | _ => false + end. + +(** Operations that depend on the memory state. *) + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp (Ccompu _) => negb Archi.ptr64 + | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 + | Ocmp (Ccomplu _) => Archi.ptr64 + | Ocmp (Ccompluimm _ _) => Archi.ptr64 + | _ => false + end. + +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. +Qed. + +(** Global variables mentioned in an operation or addressing mode *) + +Definition globals_addressing (addr: addressing) : list ident := + match addr with + | Aglobal s ofs => s :: nil + | _ => nil + end. + +Definition globals_operation (op: operation) : list ident := + match op with + | Oaddrsymbol s ofs => s :: nil + | _ => nil + end. + +(** * Invariance and compatibility properties. *) + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing; destruct addr; auto. destruct vl; auto. + unfold Genv.symbol_address. rewrite agree_on_symbols; auto. +Qed. + +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. +Proof. + intros. + unfold eval_operation; destruct op; auto. destruct vl; auto. + unfold Genv.symbol_address. rewrite agree_on_symbols; auto. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Variable f: meminj. + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). + +Ltac InvInject := + match goal with + | [ H: Val.inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ nil _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + Val.inject_list f vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. +- 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. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- 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. +- inv H3; inv H2; simpl in H0; inv H0; auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_operation op) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_operation ge1 sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + (* addrsymbol *) + - apply GL; simpl; auto. + (* addrstack *) + - apply Val.offset_ptr_inject; auto. + (* castsigned *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* add, addimm *) + - apply Val.add_inject; auto. + - apply Val.add_inject; auto. + (* neg, sub *) + - inv H4; simpl; auto. + - apply Val.sub_inject; auto. + (* mul, mulhs, mulhu *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* div, divu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + (* mod, modu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + (* and, andimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* or, orimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* xor, xorimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* shl, shlimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shr, shrimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shru, shruimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shrx *) + - inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + (* makelong, highlong, lowlong *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* cast32 *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addl, addlimm *) + - apply Val.addl_inject; auto. + - apply Val.addl_inject; auto. + (* negl, subl *) + - inv H4; simpl; auto. + - apply Val.subl_inject; auto. + (* mull, mullhs, mullhu *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* divl, divlu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + (* modl, modlu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + (* andl, andlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* orl, orlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* xorl, xorlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* shll, shllimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shr, shrimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* 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 *) + - inv H4; simpl in H1; try discriminate. simpl. + destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + (* negf, absf *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addf, subf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulf, divf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* negfs, absfs *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addfs, subfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulfs, divfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* singleoffloat, floatofsingle *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* intoffloat, intuoffloat *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + (* floatofint, floatofintu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* intofsingle, intuofsingle *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. + exists (Vint i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2. + exists (Vint i); auto. + (* singleofint, singleofintu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* longoffloat, longuoffloat *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2. + exists (Vlong i); auto. + (* floatoflong, floatoflongu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* longofsingle, longuofsingle *) + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. + exists (Vlong i); auto. + - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2. + exists (Vlong i); auto. + (* singleoflong, singleoflongu *) + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + (* cmp *) + - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. +Qed. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. + apply Val.offset_ptr_inject; auto. + apply H; simpl; auto. + apply Val.offset_ptr_inject; auto. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_list_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + intros. apply val_inject_lessdef. auto. + apply val_inject_lessdef; auto. + eauto. + auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +End EVAL_INJECT. + +(** * Handling of builtin arguments *) + +Definition builtin_arg_ok_1 + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match c, ba with + | OK_all, _ => true + | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true + | OK_addrstack, BA_addrstack _ => true + | OK_addressing, BA_addrstack _ => true + | OK_addressing, BA_addptr (BA _) (BA_int _) => true + | OK_addressing, BA_addptr (BA _) (BA_long _) => true + | _, _ => false + end. + +Definition builtin_arg_ok + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match ba with + | (BA _ | BA_splitlong (BA _) (BA _)) => true + | _ => builtin_arg_ok_1 ba c + end. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml new file mode 100644 index 00000000..9ec474b3 --- /dev/null +++ b/mppa_k1c/PrintOp.ml @@ -0,0 +1,166 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Pretty-printing of operators, conditions, addressing modes *) + +open Printf +open Camlcoq +open Integers +open Op + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let print_condition reg pp = function + | (Ccomp c, [r1;r2]) -> + fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 + | (Ccompu c, [r1;r2]) -> + fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 + | (Ccompimm(c, n), [r1]) -> + fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompuimm(c, n), [r1]) -> + fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompf c, [r1;r2]) -> + fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 + | (Ccompl c, [r1;r2]) -> + fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 + | (Ccomplu c, [r1;r2]) -> + fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 + | (Ccomplimm(c, n), [r1]) -> + fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Ccompluimm(c, n), [r1]) -> + fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Cnotcompf c, [r1;r2]) -> + fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 + | (Ccompfs c, [r1;r2]) -> + 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 + | _ -> + 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) + | Oaddrsymbol(id, ofs), [] -> + fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) + | Oaddrstack ofs, [] -> + fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) + | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 + | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 + | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Oneg, [r1] -> fprintf pp "-(%a)" reg r1 + | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Omulhs, [r1;r2] -> fprintf pp "%a *hs %a" reg r1 reg r2 + | Omulhu, [r1;r2] -> fprintf pp "%a *hu %a" reg r1 reg r2 + | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 + | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 + | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2 + | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2 + | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 + | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) + | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 + | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) + | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 + | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 + | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) + | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 + | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n) + | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 + | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) + | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + + | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 + | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 + | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 + | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1 + | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 + | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2 + | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n) + | Onegl, [r1] -> fprintf pp "-l (%a)" reg r1 + | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 + | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 + | Omullhs, [r1;r2] -> fprintf pp "%a *lhs %a" reg r1 reg r2 + | Omullhu, [r1;r2] -> fprintf pp "%a *lhu %a" reg r1 reg r2 + | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 + | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2 + | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2 + | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2 + | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 + | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) + | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 + | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) + | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 + | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) + | Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2 + | Oshllimm n, [r1] -> fprintf pp "%a <<l %Ld" reg r1 (camlint64_of_coqint n) + | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2 + | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n) + | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 + | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) + | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + + | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 + | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 + | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 + | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 + | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 + | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 + | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1 + | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1 + | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2 + | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2 + | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2 + | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2 + | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 + | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 + | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 + | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 + | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1 + | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1 + | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 + | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 + | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 + | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 + | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 + | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1 + | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 + | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1 + | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 + | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1 + | 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) + | _ -> fprintf pp "<bad operator>" + +let print_addressing reg pp = function + | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) + | Aglobal(id, ofs), [] -> + fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) + | Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) + | _ -> fprintf pp "<bad addressing>" diff --git a/mppa_k1c/SelectLong.v b/mppa_k1c/SelectLong.v new file mode 100644 index 00000000..f2aa6be2 --- /dev/null +++ b/mppa_k1c/SelectLong.v @@ -0,0 +1,774 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Definition longconst (n: int64) : expr := + if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. + +Definition is_longconst (e: expr) := + if Archi.splitlong then SplitLong.is_longconst e else + match e with + | Eop (Olongconst n) Enil => Some n + | _ => None + end. + +Definition intoflong (e: expr) := + if Archi.splitlong then SplitLong.intoflong e else + match is_longconst e with + | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | None => Eop Olowlong (e ::: Enil) + end. + +Definition longofint (e: expr) := + if Archi.splitlong then SplitLong.longofint e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.signed n)) + | None => Eop Ocast32signed (e ::: Enil) + end. + +Definition longofintu (e: expr) := + if Archi.splitlong then SplitLong.longofintu e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.unsigned n)) + | None => Eop Ocast32unsigned (e ::: Enil) + end. + +(** ** Integer addition and pointer addition *) + +(** Original definition: +<< +Nondetfunction addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else + match e with + | Eop (Olongconst m) Enil => longconst (Int64.add n m) + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | _ => Eop (Oaddlimm n) (e ::: Enil) + end. +>> +*) + +Inductive addlimm_cases: forall (e: expr), Type := + | addlimm_case1: forall m, addlimm_cases (Eop (Olongconst m) Enil) + | addlimm_case2: forall s m, addlimm_cases (Eop (Oaddrsymbol s m) Enil) + | addlimm_case3: forall m, addlimm_cases (Eop (Oaddrstack m) Enil) + | addlimm_case4: forall m t, addlimm_cases (Eop (Oaddlimm m) (t ::: Enil)) + | addlimm_default: forall (e: expr), addlimm_cases e. + +Definition addlimm_match (e: expr) := + match e as zz1 return addlimm_cases zz1 with + | Eop (Olongconst m) Enil => addlimm_case1 m + | Eop (Oaddrsymbol s m) Enil => addlimm_case2 s m + | Eop (Oaddrstack m) Enil => addlimm_case3 m + | Eop (Oaddlimm m) (t ::: Enil) => addlimm_case4 m t + | e => addlimm_default e + end. + +Definition addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else match addlimm_match e with + | addlimm_case1 m => (* Eop (Olongconst m) Enil *) + longconst (Int64.add n m) + | addlimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) + Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | addlimm_case3 m => (* Eop (Oaddrstack m) Enil *) + Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | addlimm_case4 m t => (* Eop (Oaddlimm m) (t ::: Enil) *) + Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | addlimm_default e => + Eop (Oaddlimm n) (e ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | _, _ => Eop Oaddl (e1:::e2:::Enil) + end. +>> +*) + +Inductive addl_cases: forall (e1: expr) (e2: expr), Type := + | addl_case1: forall n1 t2, addl_cases (Eop (Olongconst n1) Enil) (t2) + | addl_case2: forall t1 n2, addl_cases (t1) (Eop (Olongconst n2) Enil) + | addl_case3: forall n1 t1 n2 t2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddlimm n2) (t2:::Enil)) + | addl_case4: forall n1 t1 n2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddrstack n2) Enil) + | addl_case5: forall n1 n2 t2, addl_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddlimm n2) (t2:::Enil)) + | addl_case6: forall n1 t1 t2, addl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (t2) + | addl_case7: forall t1 n2 t2, addl_cases (t1) (Eop (Oaddlimm n2) (t2:::Enil)) + | addl_default: forall (e1: expr) (e2: expr), addl_cases e1 e2. + +Definition addl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return addl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => addl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => addl_case2 t1 n2 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => addl_case3 n1 t1 n2 t2 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => addl_case4 n1 t1 n2 + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => addl_case5 n1 n2 t2 + | Eop (Oaddlimm n1) (t1:::Enil), t2 => addl_case6 n1 t1 t2 + | t1, Eop (Oaddlimm n2) (t2:::Enil) => addl_case7 t1 n2 t2 + | e1, e2 => addl_default e1 e2 + end. + +Definition addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else match addl_match e1 e2 with + | addl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + addlimm n1 t2 + | addl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + addlimm n2 t1 + | addl_case3 n1 t1 n2 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | addl_case4 n1 t1 n2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil *) + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | addl_case5 n1 n2 t2 => (* Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) *) + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | addl_case6 n1 t1 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), t2 *) + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | addl_case7 t1 n2 t2 => (* t1, Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | addl_default e1 e2 => + Eop Oaddl (e1:::e2:::Enil) + end. + + +(** ** Integer and pointer subtraction *) + +(** Original definition: +<< +Nondetfunction subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else + match e1, e2 with + | t1, Eop (Olongconst n2) Enil => + addlimm (Int64.neg n2) t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | _, _ => Eop Osubl (e1:::e2:::Enil) + end. +>> +*) + +Inductive subl_cases: forall (e1: expr) (e2: expr), Type := + | subl_case1: forall t1 n2, subl_cases (t1) (Eop (Olongconst n2) Enil) + | subl_case2: forall n1 t1 n2 t2, subl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (Eop (Oaddlimm n2) (t2:::Enil)) + | subl_case3: forall n1 t1 t2, subl_cases (Eop (Oaddlimm n1) (t1:::Enil)) (t2) + | subl_case4: forall t1 n2 t2, subl_cases (t1) (Eop (Oaddlimm n2) (t2:::Enil)) + | subl_default: forall (e1: expr) (e2: expr), subl_cases e1 e2. + +Definition subl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return subl_cases zz1 zz2 with + | t1, Eop (Olongconst n2) Enil => subl_case1 t1 n2 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => subl_case2 n1 t1 n2 t2 + | Eop (Oaddlimm n1) (t1:::Enil), t2 => subl_case3 n1 t1 t2 + | t1, Eop (Oaddlimm n2) (t2:::Enil) => subl_case4 t1 n2 t2 + | e1, e2 => subl_default e1 e2 + end. + +Definition subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else match subl_match e1 e2 with + | subl_case1 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + addlimm (Int64.neg n2) t1 + | subl_case2 n1 t1 n2 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | subl_case3 n1 t1 t2 => (* Eop (Oaddlimm n1) (t1:::Enil), t2 *) + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | subl_case4 t1 n2 t2 => (* t1, Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | subl_default e1 e2 => + Eop Osubl (e1:::e2:::Enil) + end. + + +Definition negl (e: expr) := + if Archi.splitlong then SplitLong.negl e else + match is_longconst e with + | Some n => longconst (Int64.neg n) + | None => Eop Onegl (e ::: Enil) + end. + +(** ** Immediate shifts *) + +(** Original definition: +<< +Nondetfunction shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int64.iwordsize') then + Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shl' n1 n) + | Eop (Oshllimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | _ => + Eop (Oshllimm n) (e1:::Enil) + end. +>> +*) + +Inductive shllimm_cases: forall (e1: expr) , Type := + | shllimm_case1: forall n1, shllimm_cases (Eop (Olongconst n1) Enil) + | shllimm_case2: forall n1 t1, shllimm_cases (Eop (Oshllimm n1) (t1:::Enil)) + | shllimm_default: forall (e1: expr) , shllimm_cases e1. + +Definition shllimm_match (e1: expr) := + match e1 as zz1 return shllimm_cases zz1 with + | Eop (Olongconst n1) Enil => shllimm_case1 n1 + | Eop (Oshllimm n1) (t1:::Enil) => shllimm_case2 n1 t1 + | e1 => shllimm_default e1 + end. + +Definition shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shllimm_match e1 with + | shllimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + longconst (Int64.shl' n1 n) + | shllimm_case2 n1 t1 => (* Eop (Oshllimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) else Eop (Oshllimm n) (e1:::Enil) + | shllimm_default e1 => + Eop (Oshllimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shru' n1 n) + | Eop (Oshrluimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | _ => + Eop (Oshrluimm n) (e1:::Enil) + end. +>> +*) + +Inductive shrluimm_cases: forall (e1: expr) , Type := + | shrluimm_case1: forall n1, shrluimm_cases (Eop (Olongconst n1) Enil) + | shrluimm_case2: forall n1 t1, shrluimm_cases (Eop (Oshrluimm n1) (t1:::Enil)) + | shrluimm_default: forall (e1: expr) , shrluimm_cases e1. + +Definition shrluimm_match (e1: expr) := + match e1 as zz1 return shrluimm_cases zz1 with + | Eop (Olongconst n1) Enil => shrluimm_case1 n1 + | Eop (Oshrluimm n1) (t1:::Enil) => shrluimm_case2 n1 t1 + | e1 => shrluimm_default e1 + end. + +Definition shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) else match shrluimm_match e1 with + | shrluimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + longconst (Int64.shru' n1 n) + | shrluimm_case2 n1 t1 => (* Eop (Oshrluimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrluimm n) (e1:::Enil) + | shrluimm_default e1 => + Eop (Oshrluimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shr' n1 n) + | Eop (Oshrlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | _ => + Eop (Oshrlimm n) (e1:::Enil) + end. +>> +*) + +Inductive shrlimm_cases: forall (e1: expr) , Type := + | shrlimm_case1: forall n1, shrlimm_cases (Eop (Olongconst n1) Enil) + | shrlimm_case2: forall n1 t1, shrlimm_cases (Eop (Oshrlimm n1) (t1:::Enil)) + | shrlimm_default: forall (e1: expr) , shrlimm_cases e1. + +Definition shrlimm_match (e1: expr) := + match e1 as zz1 return shrlimm_cases zz1 with + | Eop (Olongconst n1) Enil => shrlimm_case1 n1 + | Eop (Oshrlimm n1) (t1:::Enil) => shrlimm_case2 n1 t1 + | e1 => shrlimm_default e1 + end. + +Definition shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int64.iwordsize') then Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) else match shrlimm_match e1 with + | shrlimm_case1 n1 => (* Eop (Olongconst n1) Enil *) + longconst (Int64.shr' n1 n) + | shrlimm_case2 n1 t1 => (* Eop (Oshrlimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int64.iwordsize' then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrlimm n) (e1:::Enil) + | shrlimm_default e1 => + Eop (Oshrlimm n) (e1:::Enil) + end. + + +(** ** General shifts *) + +Definition shll (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shll e1 e2 else + match is_intconst e2 with + | Some n2 => shllimm e1 n2 + | None => Eop Oshll (e1:::e2:::Enil) + end. + +Definition shrl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrl e1 e2 else + match is_intconst e2 with + | Some n2 => shrlimm e1 n2 + | None => Eop Oshrl (e1:::e2:::Enil) + end. + +Definition shrlu (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrlu e1 e2 else + match is_intconst e2 with + | Some n2 => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +(** ** Integer multiply *) + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop Omull (e2 ::: longconst n1 ::: Enil) + end. + +(** Original definition: +<< +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 + else if Int64.eq n1 Int64.zero then longconst Int64.zero + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) + | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | _ => mullimm_base n1 e2 + end. +>> +*) + +Inductive mullimm_cases: forall (e2: expr), Type := + | mullimm_case1: forall n2, mullimm_cases (Eop (Olongconst n2) Enil) + | mullimm_case2: forall n2 t2, mullimm_cases (Eop (Oaddlimm n2) (t2:::Enil)) + | mullimm_default: forall (e2: expr), mullimm_cases e2. + +Definition mullimm_match (e2: expr) := + match e2 as zz1 return mullimm_cases zz1 with + | Eop (Olongconst n2) Enil => mullimm_case1 n2 + | Eop (Oaddlimm n2) (t2:::Enil) => mullimm_case2 n2 t2 + | e2 => mullimm_default e2 + end. + +Definition mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 else if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.one then e2 else match mullimm_match e2 with + | mullimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.mul n1 n2) + | mullimm_case2 n2 t2 => (* Eop (Oaddlimm n2) (t2:::Enil) *) + addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | mullimm_default e2 => + mullimm_base n1 e2 + end. + + +(** Original definition: +<< +Nondetfunction mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 + | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 + | _, _ => Eop Omull (e1:::e2:::Enil) + end. +>> +*) + +Inductive mull_cases: forall (e1: expr) (e2: expr), Type := + | mull_case1: forall n1 t2, mull_cases (Eop (Olongconst n1) Enil) (t2) + | mull_case2: forall t1 n2, mull_cases (t1) (Eop (Olongconst n2) Enil) + | mull_default: forall (e1: expr) (e2: expr), mull_cases e1 e2. + +Definition mull_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return mull_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => mull_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => mull_case2 t1 n2 + | e1, e2 => mull_default e1 e2 + end. + +Definition mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else match mull_match e1 e2 with + | mull_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + mullimm n1 t2 + | mull_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + mullimm n2 t1 + | mull_default e1 e2 => + Eop Omull (e1:::e2:::Enil) + end. + + +Definition mullhu (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhu e1 n2 else + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +Definition mullhs (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhs e1 n2 else + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +(** Original definition: +<< +Nondetfunction andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else + if Int64.eq n1 Int64.mone then e2 else + match e2 with + | Eop (Olongconst n2) Enil => + longconst (Int64.and n1 n2) + | Eop (Oandlimm n2) (t2:::Enil) => + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | _ => + Eop (Oandlimm n1) (e2:::Enil) + end. +>> +*) + +Inductive andlimm_cases: forall (e2: expr), Type := + | andlimm_case1: forall n2, andlimm_cases (Eop (Olongconst n2) Enil) + | andlimm_case2: forall n2 t2, andlimm_cases (Eop (Oandlimm n2) (t2:::Enil)) + | andlimm_default: forall (e2: expr), andlimm_cases e2. + +Definition andlimm_match (e2: expr) := + match e2 as zz1 return andlimm_cases zz1 with + | Eop (Olongconst n2) Enil => andlimm_case1 n2 + | Eop (Oandlimm n2) (t2:::Enil) => andlimm_case2 n2 t2 + | e2 => andlimm_default e2 + end. + +Definition andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else if Int64.eq n1 Int64.mone then e2 else match andlimm_match e2 with + | andlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.and n1 n2) + | andlimm_case2 n2 t2 => (* Eop (Oandlimm n2) (t2:::Enil) *) + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | andlimm_default e2 => + Eop (Oandlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. +>> +*) + +Inductive andl_cases: forall (e1: expr) (e2: expr), Type := + | andl_case1: forall n1 t2, andl_cases (Eop (Olongconst n1) Enil) (t2) + | andl_case2: forall t1 n2, andl_cases (t1) (Eop (Olongconst n2) Enil) + | andl_default: forall (e1: expr) (e2: expr), andl_cases e1 e2. + +Definition andl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return andl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => andl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => andl_case2 t1 n2 + | e1, e2 => andl_default e1 e2 + end. + +Definition andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else match andl_match e1 e2 with + | andl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + andlimm n1 t2 + | andl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + andlimm n2 t1 + | andl_default e1 e2 => + Eop Oandl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then longconst Int64.mone else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. +>> +*) + +Inductive orlimm_cases: forall (e2: expr), Type := + | orlimm_case1: forall n2, orlimm_cases (Eop (Olongconst n2) Enil) + | orlimm_case2: forall n2 t2, orlimm_cases (Eop (Oorlimm n2) (t2:::Enil)) + | orlimm_default: forall (e2: expr), orlimm_cases e2. + +Definition orlimm_match (e2: expr) := + match e2 as zz1 return orlimm_cases zz1 with + | Eop (Olongconst n2) Enil => orlimm_case1 n2 + | Eop (Oorlimm n2) (t2:::Enil) => orlimm_case2 n2 t2 + | e2 => orlimm_default e2 + end. + +Definition orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else if Int64.eq n1 Int64.mone then longconst Int64.mone else match orlimm_match e2 with + | orlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.or n1 n2) + | orlimm_case2 n2 t2 => (* Eop (Oorlimm n2) (t2:::Enil) *) + Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | orlimm_default e2 => + Eop (Oorlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. +>> +*) + +Inductive orl_cases: forall (e1: expr) (e2: expr), Type := + | orl_case1: forall n1 t2, orl_cases (Eop (Olongconst n1) Enil) (t2) + | orl_case2: forall t1 n2, orl_cases (t1) (Eop (Olongconst n2) Enil) + | orl_default: forall (e1: expr) (e2: expr), orl_cases e1 e2. + +Definition orl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return orl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => orl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => orl_case2 t1 n2 + | e1, e2 => orl_default e1 e2 + end. + +Definition orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else match orl_match e1 e2 with + | orl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + orlimm n1 t2 + | orl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + orlimm n2 t1 + | orl_default e1 e2 => + Eop Oorl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) + | Eop (Oxorlimm n2) (t2:::Enil) => + let n := Int64.xor n1 n2 in + if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | _ => Eop (Oxorlimm n1) (e2:::Enil) + end. +>> +*) + +Inductive xorlimm_cases: forall (e2: expr), Type := + | xorlimm_case1: forall n2, xorlimm_cases (Eop (Olongconst n2) Enil) + | xorlimm_case2: forall n2 t2, xorlimm_cases (Eop (Oxorlimm n2) (t2:::Enil)) + | xorlimm_default: forall (e2: expr), xorlimm_cases e2. + +Definition xorlimm_match (e2: expr) := + match e2 as zz1 return xorlimm_cases zz1 with + | Eop (Olongconst n2) Enil => xorlimm_case1 n2 + | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_case2 n2 t2 + | e2 => xorlimm_default e2 + end. + +Definition xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else match xorlimm_match e2 with + | xorlimm_case1 n2 => (* Eop (Olongconst n2) Enil *) + longconst (Int64.xor n1 n2) + | xorlimm_case2 n2 t2 => (* Eop (Oxorlimm n2) (t2:::Enil) *) + let n := Int64.xor n1 n2 in if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | xorlimm_default e2 => + Eop (Oxorlimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. +>> +*) + +Inductive xorl_cases: forall (e1: expr) (e2: expr), Type := + | xorl_case1: forall n1 t2, xorl_cases (Eop (Olongconst n1) Enil) (t2) + | xorl_case2: forall t1 n2, xorl_cases (t1) (Eop (Olongconst n2) Enil) + | xorl_default: forall (e1: expr) (e2: expr), xorl_cases e1 e2. + +Definition xorl_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return xorl_cases zz1 zz2 with + | Eop (Olongconst n1) Enil, t2 => xorl_case1 n1 t2 + | t1, Eop (Olongconst n2) Enil => xorl_case2 t1 n2 + | e1, e2 => xorl_default e1 e2 + end. + +Definition xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else match xorl_match e1 e2 with + | xorl_case1 n1 t2 => (* Eop (Olongconst n1) Enil, t2 *) + xorlimm n1 t2 + | xorl_case2 t1 n2 => (* t1, Eop (Olongconst n2) Enil *) + xorlimm n2 t1 + | xorl_default e1 e2 => + Eop Oxorl (e1:::e2:::Enil) + end. + + +(** ** Integer logical negation *) + +Definition notl (e: expr) := + if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. + +(** ** Integer division and modulus *) + +Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. +Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. +Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. +Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. + +Definition shrxlimm (e: expr) (n: int) := + if Archi.splitlong then SplitLong.shrxlimm e n else + if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). + +(** ** Comparisons *) + +Definition cmplu (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmplu c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +Definition cmpl (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmpl c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +(** ** Floating-point conversions *) + +Definition longoffloat (e: expr) := + if Archi.splitlong then SplitLong.longoffloat e else + Eop Olongoffloat (e:::Enil). + +Definition longuoffloat (e: expr) := + if Archi.splitlong then SplitLong.longuoffloat e else + Eop Olonguoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + if Archi.splitlong then SplitLong.floatoflong e else + Eop Ofloatoflong (e:::Enil). + +Definition floatoflongu (e: expr) := + if Archi.splitlong then SplitLong.floatoflongu e else + Eop Ofloatoflongu (e:::Enil). + +Definition longofsingle (e: expr) := + if Archi.splitlong then SplitLong.longofsingle e else + Eop Olongofsingle (e:::Enil). + +Definition longuofsingle (e: expr) := + if Archi.splitlong then SplitLong.longuofsingle e else + Eop Olonguofsingle (e:::Enil). + +Definition singleoflong (e: expr) := + if Archi.splitlong then SplitLong.singleoflong e else + Eop Osingleoflong (e:::Enil). + +Definition singleoflongu (e: expr) := + if Archi.splitlong then SplitLong.singleoflongu e else + Eop Osingleoflongu (e:::Enil). + +End SELECT. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp new file mode 100644 index 00000000..26735c99 --- /dev/null +++ b/mppa_k1c/SelectLong.vp @@ -0,0 +1,360 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import SelectOp SplitLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Definition longconst (n: int64) : expr := + if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. + +Definition is_longconst (e: expr) := + if Archi.splitlong then SplitLong.is_longconst e else + match e with + | Eop (Olongconst n) Enil => Some n + | _ => None + end. + +Definition intoflong (e: expr) := + if Archi.splitlong then SplitLong.intoflong e else + match is_longconst e with + | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | None => Eop Olowlong (e ::: Enil) + end. + +Definition longofint (e: expr) := + if Archi.splitlong then SplitLong.longofint e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.signed n)) + | None => Eop Ocast32signed (e ::: Enil) + end. + +Definition longofintu (e: expr) := + if Archi.splitlong then SplitLong.longofintu e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.unsigned n)) + | None => Eop Ocast32unsigned (e ::: Enil) + end. + +(** ** Integer addition and pointer addition *) + +Nondetfunction addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else + match e with + | Eop (Olongconst m) Enil => longconst (Int64.add n m) + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | _ => Eop (Oaddlimm n) (e ::: Enil) + end. + +Nondetfunction addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | _, _ => Eop Oaddl (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else + match e1, e2 with + | t1, Eop (Olongconst n2) Enil => + addlimm (Int64.neg n2) t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | _, _ => Eop Osubl (e1:::e2:::Enil) + end. + +Definition negl (e: expr) := + if Archi.splitlong then SplitLong.negl e else + match is_longconst e with + | Some n => longconst (Int64.neg n) + | None => Eop Onegl (e ::: Enil) + end. + +(** ** Immediate shifts *) + +Nondetfunction shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int64.iwordsize') then + Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shl' n1 n) + | Eop (Oshllimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | _ => + Eop (Oshllimm n) (e1:::Enil) + end. + +Nondetfunction shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shru' n1 n) + | Eop (Oshrluimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | _ => + Eop (Oshrluimm n) (e1:::Enil) + end. + +Nondetfunction shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shr' n1 n) + | Eop (Oshrlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | _ => + Eop (Oshrlimm n) (e1:::Enil) + end. + +(** ** General shifts *) + +Definition shll (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shll e1 e2 else + match is_intconst e2 with + | Some n2 => shllimm e1 n2 + | None => Eop Oshll (e1:::e2:::Enil) + end. + +Definition shrl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrl e1 e2 else + match is_intconst e2 with + | Some n2 => shrlimm e1 n2 + | None => Eop Oshrl (e1:::e2:::Enil) + end. + +Definition shrlu (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrlu e1 e2 else + match is_intconst e2 with + | Some n2 => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +(** ** Integer multiply *) + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop Omull (e2 ::: longconst n1 ::: Enil) + end. + +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 + else if Int64.eq n1 Int64.zero then longconst Int64.zero + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) + | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | _ => mullimm_base n1 e2 + end. + +Nondetfunction mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 + | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 + | _, _ => Eop Omull (e1:::e2:::Enil) + end. + +Definition mullhu (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhu e1 n2 else + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +Definition mullhs (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhs e1 n2 else + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +Nondetfunction andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else + if Int64.eq n1 Int64.mone then e2 else + match e2 with + | Eop (Olongconst n2) Enil => + longconst (Int64.and n1 n2) + | Eop (Oandlimm n2) (t2:::Enil) => + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | _ => + Eop (Oandlimm n1) (e2:::Enil) + end. + +Nondetfunction andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. + +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then longconst Int64.mone else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. + +Nondetfunction orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. + +Nondetfunction xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) + | Eop (Oxorlimm n2) (t2:::Enil) => + let n := Int64.xor n1 n2 in + if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | _ => Eop (Oxorlimm n1) (e2:::Enil) + end. + +Nondetfunction xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. + +(** ** Integer logical negation *) + +Definition notl (e: expr) := + if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. + +(** ** Integer division and modulus *) + +Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. +Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. +Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. +Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. + +Definition shrxlimm (e: expr) (n: int) := + if Archi.splitlong then SplitLong.shrxlimm e n else + if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). + +(** ** Comparisons *) + +Definition cmplu (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmplu c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +Definition cmpl (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmpl c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +(** ** Floating-point conversions *) + +Definition longoffloat (e: expr) := + if Archi.splitlong then SplitLong.longoffloat e else + Eop Olongoffloat (e:::Enil). + +Definition longuoffloat (e: expr) := + if Archi.splitlong then SplitLong.longuoffloat e else + Eop Olonguoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + if Archi.splitlong then SplitLong.floatoflong e else + Eop Ofloatoflong (e:::Enil). + +Definition floatoflongu (e: expr) := + if Archi.splitlong then SplitLong.floatoflongu e else + Eop Ofloatoflongu (e:::Enil). + +Definition longofsingle (e: expr) := + if Archi.splitlong then SplitLong.longofsingle e else + Eop Olongofsingle (e:::Enil). + +Definition longuofsingle (e: expr) := + if Archi.splitlong then SplitLong.longuofsingle e else + Eop Olonguofsingle (e:::Enil). + +Definition singleoflong (e: expr) := + if Archi.splitlong then SplitLong.singleoflong e else + Eop Osingleoflong (e:::Enil). + +Definition singleoflongu (e: expr) := + if Archi.splitlong then SplitLong.singleoflongu e else + Eop Osingleoflongu (e:::Enil). + +End SELECT. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v new file mode 100644 index 00000000..d12fb9ae --- /dev/null +++ b/mppa_k1c/SelectLongproof.v @@ -0,0 +1,611 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for 64-bit integer operations *) + +Require Import String Coqlib Maps Integers Floats Errors. +Require Archi. +Require Import AST Values Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof. +Require Import SelectLong. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +(** * Correctness of the instruction selection functions for 64-bit operators *) + +Section CMCONSTR. + +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. +Variable sp: val. +Variable e: env. +Variable m: mem. + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop := + forall le a x y, + eval_expr ge sp e m le a x -> + sem x = Some y -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v. + +Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop := + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + sem x y = Some z -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v. + +Theorem eval_longconst: + forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). +Proof. + unfold longconst; intros; destruct Archi.splitlong. + apply SplitLongproof.eval_longconst. + EvalOp. +Qed. + +Lemma is_longconst_sound: + forall v a n le, + is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. +Proof with (try discriminate). + intros. unfold is_longconst in *. destruct Archi.splitlong. + eapply SplitLongproof.is_longconst_sound; eauto. + assert (a = Eop (Olongconst n) Enil). + { destruct a... destruct o... destruct e0... congruence. } + subst a. InvEval. auto. +Qed. + +Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. +Proof. + unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto. +- TrivialExists. +Qed. + +Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. +Proof. + unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. +Proof. + unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_negl: unary_constructor_sound negl Val.negl. +Proof. + unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- exploit is_longconst_sound; eauto. intros EQ; subst x. + econstructor; split. apply eval_longconst. auto. +- TrivialExists. +Qed. + +Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). +Proof. + unfold addlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + subst. exists x; split; auto. + destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. + destruct (addlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. +- econstructor; split. EvalOp. simpl; eauto. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. + destruct Archi.ptr64; auto. rewrite Ptrofs.add_commut; auto. +- econstructor; split. EvalOp. simpl; eauto. + destruct sp; simpl; auto. destruct Archi.ptr64; auto. + rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. +- subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_addl: binary_constructor_sound addl Val.addl. +Proof. + unfold addl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto. +(* + assert (SF: Archi.ptr64 = true). + { Local Transparent Archi.splitlong. unfold Archi.splitlong in SL. + destruct Archi.ptr64; simpl in *; congruence. } +*) +(* + assert (B: forall id ofs n, + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))). + { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs. + apply Genv.shift_symbol_address_64; auto. } + +*) + red; intros until y. + case (addl_match a b); intros; InvEval. + - rewrite Val.addl_commut. apply eval_addlimm; auto. + - apply eval_addlimm; auto. + - subst. + replace (Val.addl (Val.addl v1 (Vlong n1)) (Val.addl v0 (Vlong n2))) + with (Val.addl (Val.addl v1 v0) (Val.addl (Vlong n1) (Vlong n2))). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. decEq. apply Val.addl_permut. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + rewrite Val.addl_commut. destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. + rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + rewrite Ptrofs.add_commut. auto with ptrofs. + - subst. + replace (Val.addl (Val.addl v1 (Vlong n1)) y) + with (Val.addl (Val.addl v1 y) (Vlong n1)). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. decEq. apply Val.addl_commut. + - subst. + replace (Val.addl x (Val.addl v1 (Vlong n2))) + with (Val.addl (Val.addl x v1) (Vlong n2)). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. reflexivity. + - TrivialExists. +Qed. + +Theorem eval_subl: binary_constructor_sound subl Val.subl. +Proof. + unfold subl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto. + red; intros; destruct (subl_match a b); InvEval. +- rewrite Val.subl_addl_opp. apply eval_addlimm; auto. +- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r. + rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp. + apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_r. + apply eval_addlimm; EvalOp. +- TrivialExists. +Qed. + +Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). +Proof. + intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists. + destruct (shllimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). +Proof. + intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists. + destruct (shrluimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). +Proof. + intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists. + destruct (shrlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shll: binary_constructor_sound shll Val.shll. +Proof. + unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. +Proof. + unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. +Proof. + unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)). +Proof. + intros; unfold mullimm_base. red; intros. + assert (DEFAULT: exists v, + eval_expr ge sp e m le (Eop Omull (a ::: longconst n ::: Enil)) v + /\ Val.lessdef (Val.mull x (Vlong n)) v). + { econstructor; split. EvalOp. constructor. eauto. constructor. apply eval_longconst. constructor. simpl; eauto. + auto. } + generalize (Int64.one_bits'_decomp n); intros D. + destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. +- apply DEFAULT. +- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). + apply eval_shllimm; auto. + simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. + rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib). + rewrite Int64.shl'_mul; auto. +- set (le' := x :: le). + assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity). + exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1). + exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2). + exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3). + exists v3; split. econstructor; eauto. + rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto. + simpl in *. + rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib). + rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). + inv B1; inv B2. simpl in B3; inv B3. + rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. +- apply DEFAULT. +Qed. + +Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). +Proof. + unfold mullimm. intros; red; intros. + destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_mullimm; eauto. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one. + exists x; split; auto. + destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto. + destruct (mullimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto. +- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2). + exploit (eval_addlimm (Int64.mul n n2)). eexact A2. intros (v3 & A3 & B3). + exists v3; split; auto. + subst x. destruct v1; simpl; auto. + simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l. + rewrite (Int64.mul_commut n). auto. +- apply eval_mullimm_base; auto. +Qed. + +Theorem eval_mull: binary_constructor_sound mull Val.mull. +Proof. + unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto. + red; intros; destruct (mull_match a b); InvEval. +- rewrite Val.mull_commut. apply eval_mullimm; auto. +- apply eval_mullimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullhu: + forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). +Proof. + unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_mullhs: + forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). +Proof. + unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)). +Proof. + unfold andlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + exists x; split. assumption. + subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. + destruct (andlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. +- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. +- TrivialExists. +Qed. + +Theorem eval_andl: binary_constructor_sound andl Val.andl. +Proof. + unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. + red; intros. destruct (andl_match a b). +- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. +- InvEval. apply eval_andlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). +Proof. + unfold orlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto. + destruct (orlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. +- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. +- TrivialExists. +Qed. + +Theorem eval_orl: binary_constructor_sound orl Val.orl. +Proof. + unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. + red; intros. + destruct (orl_match a b). +- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. +- InvEval. apply eval_orlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). +Proof. + unfold xorlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. + destruct (xorlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. +- rewrite Val.xorl_assoc. simpl. rewrite (Int64.xor_commut n2). + predSpec Int64.eq Int64.eq_spec (Int64.xor n n2) Int64.zero. ++ rewrite H. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.xor_zero; auto. ++ TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. +Proof. + unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl. + red; intros. destruct (xorl_match a b). +- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto. +- InvEval. apply eval_xorlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_notl: unary_constructor_sound notl Val.notl. +Proof. + unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl. + red; intros. rewrite Val.notl_xorl. apply eval_xorlimm; auto. +Qed. + +Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. +Proof. + unfold divls_base; red; intros. + eapply SplitLongproof.eval_divls_base; eauto. +Qed. + +Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. +Proof. + unfold modls_base; red; intros. + eapply SplitLongproof.eval_modls_base; eauto. +Qed. + +Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. +Proof. + unfold divlu_base; red; intros. + eapply SplitLongproof.eval_divlu_base; eauto. +Qed. + +Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. +Proof. + unfold modlu_base; red; intros. + eapply SplitLongproof.eval_modlu_base; eauto. +Qed. + +Theorem eval_shrxlimm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrxl x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v. +Proof. + unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL. ++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. ++ predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. + change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. +- TrivialExists. +(* + intros. unfold shrxlimm. destruct Archi.splitlong eqn:SL. ++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. ++ destruct x; simpl in H0; try discriminate. + destruct (Int.ltu n (Int.repr 63)) eqn:LTU; inv H0. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. exists (Vlong i); split; auto. rewrite Int64.shrx'_zero. auto. + - assert (NZ: Int.unsigned n <> 0). + { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } + assert (LT: 0 <= Int.unsigned n < 63) by (apply Int.ltu_inv in LTU; assumption). + assert (LTU2: Int.ltu (Int.sub Int64.iwordsize' n) Int64.iwordsize' = true). + { unfold Int.ltu; apply zlt_true. + unfold Int.sub. change (Int.unsigned Int64.iwordsize') with 64. + rewrite Int.unsigned_repr. omega. + assert (64 < Int.max_unsigned) by reflexivity. omega. } + assert (X: eval_expr ge sp e m le + (Eop (Oshrlimm (Int.repr (Int64.zwordsize - 1))) (a ::: Enil)) + (Vlong (Int64.shr' i (Int.repr (Int64.zwordsize - 1))))). + { EvalOp. } + assert (Y: eval_expr ge sp e m le (shrxlimm_inner a n) + (Vlong (Int64.shru' (Int64.shr' i (Int.repr (Int64.zwordsize - 1))) (Int.sub Int64.iwordsize' n)))). + { EvalOp. simpl. rewrite LTU2. auto. } + TrivialExists. + constructor. EvalOp. simpl; eauto. constructor. + simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int64.shrx'_shr_2 by auto. reflexivity. + change (Int.unsigned Int64.iwordsize') with 64; omega. +*) +Qed. + +Theorem eval_cmplu: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmplu (Mem.valid_pointer m) c x y = Some v -> + eval_expr ge sp e m le (cmplu c a b) v. +Proof. + unfold cmplu; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32. + unfold Val.cmplu in H1. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_cmpl: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmpl c x y = Some v -> + eval_expr ge sp e m le (cmpl c a b) v. +Proof. + unfold cmpl; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmpl; eauto. + unfold Val.cmpl in H1. + destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. +Proof. + unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longoffloat; eauto. + TrivialExists. +Qed. + +Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. +Proof. + unfold longuoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longuoffloat; eauto. + TrivialExists. +Qed. + +Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. +Proof. + unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflong; eauto. + TrivialExists. +Qed. + +Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. +Proof. + unfold floatoflongu; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflongu; eauto. + TrivialExists. +Qed. + +Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. +Proof. + unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longofsingle; eauto. + TrivialExists. +Qed. + +Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. +Proof. + unfold longuofsingle; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longuofsingle; eauto. + TrivialExists. +Qed. + +Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. +Proof. + unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_singleoflong; eauto. + TrivialExists. +Qed. + +Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. +Proof. + unfold singleoflongu; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_singleoflongu; eauto. + TrivialExists. +Qed. + +End CMCONSTR. diff --git a/mppa_k1c/SelectOp.v b/mppa_k1c/SelectOp.v new file mode 100644 index 00000000..c42f0340 --- /dev/null +++ b/mppa_k1c/SelectOp.v @@ -0,0 +1,1219 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Archi. +Require Import Coqlib. +Require Import Compopts. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Op. +Require Import CminorSel. + +Local Open Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: ptrofs) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: ptrofs) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer addition and pointer addition *) + +(** Original definition: +<< +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | _ => Eop (Oaddimm n) (e ::: Enil) + end. +>> +*) + +Inductive addimm_cases: forall (e: expr), Type := + | addimm_case1: forall m, addimm_cases (Eop (Ointconst m) Enil) + | addimm_case2: forall s m, addimm_cases (Eop (Oaddrsymbol s m) Enil) + | addimm_case3: forall m, addimm_cases (Eop (Oaddrstack m) Enil) + | addimm_case4: forall m t, addimm_cases (Eop (Oaddimm m) (t ::: Enil)) + | addimm_default: forall (e: expr), addimm_cases e. + +Definition addimm_match (e: expr) := + match e as zz1 return addimm_cases zz1 with + | Eop (Ointconst m) Enil => addimm_case1 m + | Eop (Oaddrsymbol s m) Enil => addimm_case2 s m + | Eop (Oaddrstack m) Enil => addimm_case3 m + | Eop (Oaddimm m) (t ::: Enil) => addimm_case4 m t + | e => addimm_default e + end. + +Definition addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else match addimm_match e with + | addimm_case1 m => (* Eop (Ointconst m) Enil *) + Eop (Ointconst (Int.add n m)) Enil + | addimm_case2 s m => (* Eop (Oaddrsymbol s m) Enil *) + Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | addimm_case3 m => (* Eop (Oaddrstack m) Enil *) + Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | addimm_case4 m t => (* Eop (Oaddimm m) (t ::: Enil) *) + Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | addimm_default e => + Eop (Oaddimm n) (e ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. +>> +*) + +Inductive add_cases: forall (e1: expr) (e2: expr), Type := + | add_case1: forall n1 t2, add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: forall t1 n2, add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case3: forall n1 t1 n2 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case4: forall n1 t1 n2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddrstack n2) Enil) + | add_case5: forall n1 n2 t2, add_cases (Eop (Oaddrstack n1) Enil) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case6: forall n1 t1 t2, add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | add_case7: forall t1 n2 t2, add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_default: forall (e1: expr) (e2: expr), add_cases e1 e2. + +Definition add_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return add_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => add_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => add_case2 t1 n2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => add_case3 n1 t1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => add_case4 n1 t1 n2 + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => add_case5 n1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), t2 => add_case6 n1 t1 t2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => add_case7 t1 n2 t2 + | e1, e2 => add_default e1 e2 + end. + +Definition add (e1: expr) (e2: expr) := + match add_match e1 e2 with + | add_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + addimm n1 t2 + | add_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + addimm n2 t1 + | add_case3 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | add_case4 n1 t1 n2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil *) + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | add_case5 n1 n2 t2 => (* Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) *) + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | add_case6 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | add_case7 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | add_default e1 e2 => + Eop Oadd (e1:::e2:::Enil) + end. + + +(** ** Integer and pointer subtraction *) + +(** Original definition: +<< +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => + addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. +>> +*) + +Inductive sub_cases: forall (e1: expr) (e2: expr), Type := + | sub_case1: forall t1 n2, sub_cases (t1) (Eop (Ointconst n2) Enil) + | sub_case2: forall n1 t1 n2 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case3: forall n1 t1 t2, sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | sub_case4: forall t1 n2 t2, sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_default: forall (e1: expr) (e2: expr), sub_cases e1 e2. + +Definition sub_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return sub_cases zz1 zz2 with + | t1, Eop (Ointconst n2) Enil => sub_case1 t1 n2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => sub_case2 n1 t1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), t2 => sub_case3 n1 t1 t2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => sub_case4 t1 n2 t2 + | e1, e2 => sub_default e1 e2 + end. + +Definition sub (e1: expr) (e2: expr) := + match sub_match e1 e2 with + | sub_case1 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + addimm (Int.neg n2) t1 + | sub_case2 n1 t1 n2 t2 => (* Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | sub_case3 n1 t1 t2 => (* Eop (Oaddimm n1) (t1:::Enil), t2 *) + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | sub_case4 t1 n2 t2 => (* t1, Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | sub_default e1 e2 => + Eop Osub (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | _ => Eop Oneg (e ::: Enil) + end. +>> +*) + +Inductive negint_cases: forall (e: expr), Type := + | negint_case1: forall n, negint_cases (Eop (Ointconst n) Enil) + | negint_default: forall (e: expr), negint_cases e. + +Definition negint_match (e: expr) := + match e as zz1 return negint_cases zz1 with + | Eop (Ointconst n) Enil => negint_case1 n + | e => negint_default e + end. + +Definition negint (e: expr) := + match negint_match e with + | negint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.neg n)) Enil + | negint_default e => + Eop Oneg (e ::: Enil) + end. + + +(** ** Immediate shifts *) + +(** Original definition: +<< +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + Eop (Oshlimm n) (e1:::Enil) + end. +>> +*) + +Inductive shlimm_cases: forall (e1: expr) , Type := + | shlimm_case1: forall n1, shlimm_cases (Eop (Ointconst n1) Enil) + | shlimm_case2: forall n1 t1, shlimm_cases (Eop (Oshlimm n1) (t1:::Enil)) + | shlimm_default: forall (e1: expr) , shlimm_cases e1. + +Definition shlimm_match (e1: expr) := + match e1 as zz1 return shlimm_cases zz1 with + | Eop (Ointconst n1) Enil => shlimm_case1 n1 + | Eop (Oshlimm n1) (t1:::Enil) => shlimm_case2 n1 t1 + | e1 => shlimm_default e1 + end. + +Definition shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shlimm_match e1 with + | shlimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst (Int.shl n1 n)) Enil + | shlimm_case2 n1 t1 => (* Eop (Oshlimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) else Eop (Oshlimm n) (e1:::Enil) + | shlimm_default e1 => + Eop (Oshlimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. +>> +*) + +Inductive shruimm_cases: forall (e1: expr) , Type := + | shruimm_case1: forall n1, shruimm_cases (Eop (Ointconst n1) Enil) + | shruimm_case2: forall n1 t1, shruimm_cases (Eop (Oshruimm n1) (t1:::Enil)) + | shruimm_default: forall (e1: expr) , shruimm_cases e1. + +Definition shruimm_match (e1: expr) := + match e1 as zz1 return shruimm_cases zz1 with + | Eop (Ointconst n1) Enil => shruimm_case1 n1 + | Eop (Oshruimm n1) (t1:::Enil) => shruimm_case2 n1 t1 + | e1 => shruimm_default e1 + end. + +Definition shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shruimm_match e1 with + | shruimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst (Int.shru n1 n)) Enil + | shruimm_case2 n1 t1 => (* Eop (Oshruimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) else Eop (Oshruimm n) (e1:::Enil) + | shruimm_default e1 => + Eop (Oshruimm n) (e1:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. +>> +*) + +Inductive shrimm_cases: forall (e1: expr) , Type := + | shrimm_case1: forall n1, shrimm_cases (Eop (Ointconst n1) Enil) + | shrimm_case2: forall n1 t1, shrimm_cases (Eop (Oshrimm n1) (t1:::Enil)) + | shrimm_default: forall (e1: expr) , shrimm_cases e1. + +Definition shrimm_match (e1: expr) := + match e1 as zz1 return shrimm_cases zz1 with + | Eop (Ointconst n1) Enil => shrimm_case1 n1 + | Eop (Oshrimm n1) (t1:::Enil) => shrimm_case2 n1 t1 + | e1 => shrimm_default e1 + end. + +Definition shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else if negb (Int.ltu n Int.iwordsize) then Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) else match shrimm_match e1 with + | shrimm_case1 n1 => (* Eop (Ointconst n1) Enil *) + Eop (Ointconst (Int.shr n1 n)) Enil + | shrimm_case2 n1 t1 => (* Eop (Oshrimm n1) (t1:::Enil) *) + if Int.ltu (Int.add n n1) Int.iwordsize then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) else Eop (Oshrimm n) (e1:::Enil) + | shrimm_default e1 => + Eop (Oshrimm n) (e1:::Enil) + end. + + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + end. + +(** Original definition: +<< +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. +>> +*) + +Inductive mulimm_cases: forall (e2: expr), Type := + | mulimm_case1: forall n2, mulimm_cases (Eop (Ointconst n2) Enil) + | mulimm_case2: forall n2 t2, mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) + | mulimm_default: forall (e2: expr), mulimm_cases e2. + +Definition mulimm_match (e2: expr) := + match e2 as zz1 return mulimm_cases zz1 with + | Eop (Ointconst n2) Enil => mulimm_case1 n2 + | Eop (Oaddimm n2) (t2:::Enil) => mulimm_case2 n2 t2 + | e2 => mulimm_default e2 + end. + +Definition mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.one then e2 else match mulimm_match e2 with + | mulimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.mul n1 n2)) Enil + | mulimm_case2 n2 t2 => (* Eop (Oaddimm n2) (t2:::Enil) *) + addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | mulimm_default e2 => + mulimm_base n1 e2 + end. + + +(** Original definition: +<< +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. +>> +*) + +Inductive mul_cases: forall (e1: expr) (e2: expr), Type := + | mul_case1: forall n1 t2, mul_cases (Eop (Ointconst n1) Enil) (t2) + | mul_case2: forall t1 n2, mul_cases (t1) (Eop (Ointconst n2) Enil) + | mul_default: forall (e1: expr) (e2: expr), mul_cases e1 e2. + +Definition mul_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return mul_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => mul_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => mul_case2 t1 n2 + | e1, e2 => mul_default e1 e2 + end. + +Definition mul (e1: expr) (e2: expr) := + match mul_match e1 e2 with + | mul_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + mulimm n1 t2 + | mul_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + mulimm n2 t1 + | mul_default e1 e2 => + Eop Omul (e1:::e2:::Enil) + end. + + +Definition mulhs (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrlimm (Int.repr 32)) + (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: + Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhs (e1 ::: e2 ::: Enil). + +Definition mulhu (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrluimm (Int.repr 32)) + (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: + Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +(** Original definition: +<< +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | _ => Eop (Oandimm n1) (e2:::Enil) + end. +>> +*) + +Inductive andimm_cases: forall (e2: expr), Type := + | andimm_case1: forall n2, andimm_cases (Eop (Ointconst n2) Enil) + | andimm_case2: forall n2 t2, andimm_cases (Eop (Oandimm n2) (t2:::Enil)) + | andimm_default: forall (e2: expr), andimm_cases e2. + +Definition andimm_match (e2: expr) := + match e2 as zz1 return andimm_cases zz1 with + | Eop (Ointconst n2) Enil => andimm_case1 n2 + | Eop (Oandimm n2) (t2:::Enil) => andimm_case2 n2 t2 + | e2 => andimm_default e2 + end. + +Definition andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else if Int.eq n1 Int.mone then e2 else match andimm_match e2 with + | andimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.and n1 n2)) Enil + | andimm_case2 n2 t2 => (* Eop (Oandimm n2) (t2:::Enil) *) + Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | andimm_default e2 => + Eop (Oandimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. +>> +*) + +Inductive and_cases: forall (e1: expr) (e2: expr), Type := + | and_case1: forall n1 t2, and_cases (Eop (Ointconst n1) Enil) (t2) + | and_case2: forall t1 n2, and_cases (t1) (Eop (Ointconst n2) Enil) + | and_default: forall (e1: expr) (e2: expr), and_cases e1 e2. + +Definition and_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return and_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => and_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => and_case2 t1 n2 + | e1, e2 => and_default e1 e2 + end. + +Definition and (e1: expr) (e2: expr) := + match and_match e1 e2 with + | and_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + andimm n1 t2 + | and_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + andimm n2 t1 + | and_default e1 e2 => + Eop Oand (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. +>> +*) + +Inductive orimm_cases: forall (e2: expr), Type := + | orimm_case1: forall n2, orimm_cases (Eop (Ointconst n2) Enil) + | orimm_case2: forall n2 t2, orimm_cases (Eop (Oorimm n2) (t2:::Enil)) + | orimm_default: forall (e2: expr), orimm_cases e2. + +Definition orimm_match (e2: expr) := + match e2 as zz1 return orimm_cases zz1 with + | Eop (Ointconst n2) Enil => orimm_case1 n2 + | Eop (Oorimm n2) (t2:::Enil) => orimm_case2 n2 t2 + | e2 => orimm_default e2 + end. + +Definition orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil else match orimm_match e2 with + | orimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.or n1 n2)) Enil + | orimm_case2 n2 t2 => (* Eop (Oorimm n2) (t2:::Enil) *) + Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | orimm_default e2 => + Eop (Oorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | _, _ => Eop Oor (e1:::e2:::Enil) + end. +>> +*) + +Inductive or_cases: forall (e1: expr) (e2: expr), Type := + | or_case1: forall n1 t2, or_cases (Eop (Ointconst n1) Enil) (t2) + | or_case2: forall t1 n2, or_cases (t1) (Eop (Ointconst n2) Enil) + | or_default: forall (e1: expr) (e2: expr), or_cases e1 e2. + +Definition or_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return or_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => or_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => or_case2 t1 n2 + | e1, e2 => or_default e1 e2 + end. + +Definition or (e1: expr) (e2: expr) := + match or_match e1 e2 with + | or_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + orimm n1 t2 + | or_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + orimm n2 t1 + | or_default e1 e2 => + Eop Oor (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + let n := Int.xor n1 n2 in + if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. +>> +*) + +Inductive xorimm_cases: forall (e2: expr), Type := + | xorimm_case1: forall n2, xorimm_cases (Eop (Ointconst n2) Enil) + | xorimm_case2: forall n2 t2, xorimm_cases (Eop (Oxorimm n2) (t2:::Enil)) + | xorimm_default: forall (e2: expr), xorimm_cases e2. + +Definition xorimm_match (e2: expr) := + match e2 as zz1 return xorimm_cases zz1 with + | Eop (Ointconst n2) Enil => xorimm_case1 n2 + | Eop (Oxorimm n2) (t2:::Enil) => xorimm_case2 n2 t2 + | e2 => xorimm_default e2 + end. + +Definition xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else match xorimm_match e2 with + | xorimm_case1 n2 => (* Eop (Ointconst n2) Enil *) + Eop (Ointconst (Int.xor n1 n2)) Enil + | xorimm_case2 n2 t2 => (* Eop (Oxorimm n2) (t2:::Enil) *) + let n := Int.xor n1 n2 in if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | xorimm_default e2 => + Eop (Oxorimm n1) (e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. +>> +*) + +Inductive xor_cases: forall (e1: expr) (e2: expr), Type := + | xor_case1: forall n1 t2, xor_cases (Eop (Ointconst n1) Enil) (t2) + | xor_case2: forall t1 n2, xor_cases (t1) (Eop (Ointconst n2) Enil) + | xor_default: forall (e1: expr) (e2: expr), xor_cases e1 e2. + +Definition xor_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return xor_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => xor_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => xor_case2 t1 n2 + | e1, e2 => xor_default e1 e2 + end. + +Definition xor (e1: expr) (e2: expr) := + match xor_match e1 e2 with + | xor_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + xorimm n1 t2 + | xor_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + xorimm n2 t1 + | xor_default e1 e2 => + Eop Oxor (e1:::e2:::Enil) + end. + + +(** ** Integer logical negation *) + +Definition notint (e: expr) := xorimm Int.mone e. + +(** ** Integer division and modulus *) + +Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). +Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). + +(* Alternate definition, not convenient for strength reduction during constant propagation *) +(* +(* n2 will be less than 31. *) + +Definition shrximm_inner (e1: expr) (n2: int) := + Eop (Oshruimm (Int.sub Int.iwordsize n2)) + ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) + (e1 ::: Enil)) + ::: Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 + else Eop (Oshrimm n2) + ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) + ::: Enil). +*) + +(** ** General shifts *) + +(** Original definition: +<< +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. +>> +*) + +Inductive shl_cases: forall (e2: expr), Type := + | shl_case1: forall n2, shl_cases (Eop (Ointconst n2) Enil) + | shl_default: forall (e2: expr), shl_cases e2. + +Definition shl_match (e2: expr) := + match e2 as zz1 return shl_cases zz1 with + | Eop (Ointconst n2) Enil => shl_case1 n2 + | e2 => shl_default e2 + end. + +Definition shl (e1: expr) (e2: expr) := + match shl_match e2 with + | shl_case1 n2 => (* Eop (Ointconst n2) Enil *) + shlimm e1 n2 + | shl_default e2 => + Eop Oshl (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. +>> +*) + +Inductive shr_cases: forall (e2: expr), Type := + | shr_case1: forall n2, shr_cases (Eop (Ointconst n2) Enil) + | shr_default: forall (e2: expr), shr_cases e2. + +Definition shr_match (e2: expr) := + match e2 as zz1 return shr_cases zz1 with + | Eop (Ointconst n2) Enil => shr_case1 n2 + | e2 => shr_default e2 + end. + +Definition shr (e1: expr) (e2: expr) := + match shr_match e2 with + | shr_case1 n2 => (* Eop (Ointconst n2) Enil *) + shrimm e1 n2 + | shr_default e2 => + Eop Oshr (e1:::e2:::Enil) + end. + + +(** Original definition: +<< +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. +>> +*) + +Inductive shru_cases: forall (e2: expr), Type := + | shru_case1: forall n2, shru_cases (Eop (Ointconst n2) Enil) + | shru_default: forall (e2: expr), shru_cases e2. + +Definition shru_match (e2: expr) := + match e2 as zz1 return shru_cases zz1 with + | Eop (Ointconst n2) Enil => shru_case1 n2 + | e2 => shru_default e2 + end. + +Definition shru (e1: expr) (e2: expr) := + match shru_match e2 with + | shru_case1 n2 => (* Eop (Ointconst n2) Enil *) + shruimm e1 n2 + | shru_default e2 => + Eop Oshru (e1:::e2:::Enil) + end. + + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). + +Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). +Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). +Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). +Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). +Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +(** Original definition: +<< +Nondetfunction compimm (default: comparison -> int -> condition) + (sem: comparison -> int -> int -> bool) + (c: comparison) (e1: expr) (n2: int) := + match c, e1 with + | c, Eop (Ointconst n1) Enil => + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | Ceq, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp (negate_condition c)) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp c) el + else + Eop (Ointconst Int.zero) Enil + | Cne, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp c) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp (negate_condition c)) el + else + Eop (Ointconst Int.one) Enil + | _, _ => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. +>> +*) + +Inductive compimm_cases: forall (c: comparison) (e1: expr) , Type := + | compimm_case1: forall c n1, compimm_cases (c) (Eop (Ointconst n1) Enil) + | compimm_case2: forall c el, compimm_cases (Ceq) (Eop (Ocmp c) el) + | compimm_case3: forall c el, compimm_cases (Cne) (Eop (Ocmp c) el) + | compimm_default: forall (c: comparison) (e1: expr) , compimm_cases c e1. + +Definition compimm_match (c: comparison) (e1: expr) := + match c as zz1, e1 as zz2 return compimm_cases zz1 zz2 with + | c, Eop (Ointconst n1) Enil => compimm_case1 c n1 + | Ceq, Eop (Ocmp c) el => compimm_case2 c el + | Cne, Eop (Ocmp c) el => compimm_case3 c el + | c, e1 => compimm_default c e1 + end. + +Definition compimm (default: comparison -> int -> condition) (sem: comparison -> int -> int -> bool) (c: comparison) (e1: expr) (n2: int) := + match compimm_match c e1 with + | compimm_case1 c n1 => (* c, Eop (Ointconst n1) Enil *) + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | compimm_case2 c el => (* Ceq, Eop (Ocmp c) el *) + if Int.eq_dec n2 Int.zero then Eop (Ocmp (negate_condition c)) el else if Int.eq_dec n2 Int.one then Eop (Ocmp c) el else Eop (Ointconst Int.zero) Enil + | compimm_case3 c el => (* Cne, Eop (Ocmp c) el *) + if Int.eq_dec n2 Int.zero then Eop (Ocmp c) el else if Int.eq_dec n2 Int.one then Eop (Ocmp (negate_condition c)) el else Eop (Ointconst Int.one) Enil + | compimm_default c e1 => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompimm Int.cmp c t1 n2 + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. +>> +*) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Type := + | comp_case1: forall n1 t2, comp_cases (Eop (Ointconst n1) Enil) (t2) + | comp_case2: forall t1 n2, comp_cases (t1) (Eop (Ointconst n2) Enil) + | comp_default: forall (e1: expr) (e2: expr), comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return comp_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => comp_case2 t1 n2 + | e1, e2 => comp_default e1 e2 + end. + +Definition comp (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | comp_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + compimm Ccompimm Int.cmp c t1 n2 + | comp_default e1 e2 => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompuimm Int.cmpu c t1 n2 + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. +>> +*) + +Inductive compu_cases: forall (e1: expr) (e2: expr), Type := + | compu_case1: forall n1 t2, compu_cases (Eop (Ointconst n1) Enil) (t2) + | compu_case2: forall t1 n2, compu_cases (t1) (Eop (Ointconst n2) Enil) + | compu_default: forall (e1: expr) (e2: expr), compu_cases e1 e2. + +Definition compu_match (e1: expr) (e2: expr) := + match e1 as zz1, e2 as zz2 return compu_cases zz1 zz2 with + | Eop (Ointconst n1) Enil, t2 => compu_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => compu_case2 t1 n2 + | e1, e2 => compu_default e1 e2 + end. + +Definition compu (c: comparison) (e1: expr) (e2: expr) := + match compu_match e1 e2 with + | compu_case1 n1 t2 => (* Eop (Ointconst n1) Enil, t2 *) + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | compu_case2 t1 n2 => (* t1, Eop (Ointconst n2) Enil *) + compimm Ccompuimm Int.cmpu c t1 n2 + | compu_default e1 e2 => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +Definition compfs (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +(** Original definition: +<< +Nondetfunction cast8signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil + | _ => Eop Ocast8signed (e ::: Enil) + end. +>> +*) + +Inductive cast8signed_cases: forall (e: expr), Type := + | cast8signed_case1: forall n, cast8signed_cases (Eop (Ointconst n) Enil) + | cast8signed_default: forall (e: expr), cast8signed_cases e. + +Definition cast8signed_match (e: expr) := + match e as zz1 return cast8signed_cases zz1 with + | Eop (Ointconst n) Enil => cast8signed_case1 n + | e => cast8signed_default e + end. + +Definition cast8signed (e: expr) := + match cast8signed_match e with + | cast8signed_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.sign_ext 8 n)) Enil + | cast8signed_default e => + Eop Ocast8signed (e ::: Enil) + end. + + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +(** Original definition: +<< +Nondetfunction cast16signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil + | _ => Eop Ocast16signed (e ::: Enil) + end. +>> +*) + +Inductive cast16signed_cases: forall (e: expr), Type := + | cast16signed_case1: forall n, cast16signed_cases (Eop (Ointconst n) Enil) + | cast16signed_default: forall (e: expr), cast16signed_cases e. + +Definition cast16signed_match (e: expr) := + match e as zz1 return cast16signed_cases zz1 with + | Eop (Ointconst n) Enil => cast16signed_case1 n + | e => cast16signed_default e + end. + +Definition cast16signed (e: expr) := + match cast16signed_match e with + | cast16signed_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ointconst (Int.sign_ext 16 n)) Enil + | cast16signed_default e => + Eop Ocast16signed (e ::: Enil) + end. + + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). + +(** Original definition: +<< +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => Eop Ofloatofintu (e ::: Enil) + end. +>> +*) + +Inductive floatofintu_cases: forall (e: expr), Type := + | floatofintu_case1: forall n, floatofintu_cases (Eop (Ointconst n) Enil) + | floatofintu_default: forall (e: expr), floatofintu_cases e. + +Definition floatofintu_match (e: expr) := + match e as zz1 return floatofintu_cases zz1 with + | Eop (Ointconst n) Enil => floatofintu_case1 n + | e => floatofintu_default e + end. + +Definition floatofintu (e: expr) := + match floatofintu_match e with + | floatofintu_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ofloatconst (Float.of_intu n)) Enil + | floatofintu_default e => + Eop Ofloatofintu (e ::: Enil) + end. + + +(** Original definition: +<< +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatofint (e ::: Enil) + end. +>> +*) + +Inductive floatofint_cases: forall (e: expr), Type := + | floatofint_case1: forall n, floatofint_cases (Eop (Ointconst n) Enil) + | floatofint_default: forall (e: expr), floatofint_cases e. + +Definition floatofint_match (e: expr) := + match e as zz1 return floatofint_cases zz1 with + | Eop (Ointconst n) Enil => floatofint_case1 n + | e => floatofint_default e + end. + +Definition floatofint (e: expr) := + match floatofint_match e with + | floatofint_case1 n => (* Eop (Ointconst n) Enil *) + Eop (Ofloatconst (Float.of_int n)) Enil + | floatofint_default e => + Eop Ofloatofint (e ::: Enil) + end. + + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). +Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). + +Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). +Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). + +(** ** Recognition of addressing modes for load and store operations *) + +(** Original definition: +<< +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code tt then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) + | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) + | _ => (Aindexed Ptrofs.zero, e:::Enil) + end. +>> +*) + +Inductive addressing_cases: forall (e: expr), Type := + | addressing_case1: forall n, addressing_cases (Eop (Oaddrstack n) Enil) + | addressing_case2: forall id ofs, addressing_cases (Eop (Oaddrsymbol id ofs) Enil) + | addressing_case3: forall n e1, addressing_cases (Eop (Oaddimm n) (e1:::Enil)) + | addressing_case4: forall n e1, addressing_cases (Eop (Oaddlimm n) (e1:::Enil)) + | addressing_default: forall (e: expr), addressing_cases e. + +Definition addressing_match (e: expr) := + match e as zz1 return addressing_cases zz1 with + | Eop (Oaddrstack n) Enil => addressing_case1 n + | Eop (Oaddrsymbol id ofs) Enil => addressing_case2 id ofs + | Eop (Oaddimm n) (e1:::Enil) => addressing_case3 n e1 + | Eop (Oaddlimm n) (e1:::Enil) => addressing_case4 n e1 + | e => addressing_default e + end. + +Definition addressing (chunk: memory_chunk) (e: expr) := + match addressing_match e with + | addressing_case1 n => (* Eop (Oaddrstack n) Enil *) + (Ainstack n, Enil) + | addressing_case2 id ofs => (* Eop (Oaddrsymbol id ofs) Enil *) + if Archi.pic_code tt then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil) + | addressing_case3 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) + (Aindexed (Ptrofs.of_int n), e1:::Enil) + | addressing_case4 n e1 => (* Eop (Oaddlimm n) (e1:::Enil) *) + (Aindexed (Ptrofs.of_int64 n), e1:::Enil) + | addressing_default e => + (Aindexed Ptrofs.zero, e:::Enil) + end. + + +(** ** Arguments of builtins *) + +(** Original definition: +<< +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | Eop (Oaddlimm n) (e1:::Enil) => + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | _ => BA e + end. +>> +*) + +Inductive builtin_arg_cases: forall (e: expr), Type := + | builtin_arg_case1: forall n, builtin_arg_cases (Eop (Ointconst n) Enil) + | builtin_arg_case2: forall id ofs, builtin_arg_cases (Eop (Oaddrsymbol id ofs) Enil) + | builtin_arg_case3: forall ofs, builtin_arg_cases (Eop (Oaddrstack ofs) Enil) + | builtin_arg_case4: forall h l, builtin_arg_cases (Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil)) + | builtin_arg_case5: forall h l, builtin_arg_cases (Eop Omakelong (h ::: l ::: Enil)) + | builtin_arg_case6: forall chunk ofs, builtin_arg_cases (Eload chunk (Ainstack ofs) Enil) + | builtin_arg_case7: forall n e1, builtin_arg_cases (Eop (Oaddimm n) (e1:::Enil)) + | builtin_arg_case8: forall n e1, builtin_arg_cases (Eop (Oaddlimm n) (e1:::Enil)) + | builtin_arg_default: forall (e: expr), builtin_arg_cases e. + +Definition builtin_arg_match (e: expr) := + match e as zz1 return builtin_arg_cases zz1 with + | Eop (Ointconst n) Enil => builtin_arg_case1 n + | Eop (Oaddrsymbol id ofs) Enil => builtin_arg_case2 id ofs + | Eop (Oaddrstack ofs) Enil => builtin_arg_case3 ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => builtin_arg_case4 h l + | Eop Omakelong (h ::: l ::: Enil) => builtin_arg_case5 h l + | Eload chunk (Ainstack ofs) Enil => builtin_arg_case6 chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => builtin_arg_case7 n e1 + | Eop (Oaddlimm n) (e1:::Enil) => builtin_arg_case8 n e1 + | e => builtin_arg_default e + end. + +Definition builtin_arg (e: expr) := + match builtin_arg_match e with + | builtin_arg_case1 n => (* Eop (Ointconst n) Enil *) + BA_int n + | builtin_arg_case2 id ofs => (* Eop (Oaddrsymbol id ofs) Enil *) + BA_addrglobal id ofs + | builtin_arg_case3 ofs => (* Eop (Oaddrstack ofs) Enil *) + BA_addrstack ofs + | builtin_arg_case4 h l => (* Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) *) + BA_long (Int64.ofwords h l) + | builtin_arg_case5 h l => (* Eop Omakelong (h ::: l ::: Enil) *) + BA_splitlong (BA h) (BA l) + | builtin_arg_case6 chunk ofs => (* Eload chunk (Ainstack ofs) Enil *) + BA_loadstack chunk ofs + | builtin_arg_case7 n e1 => (* Eop (Oaddimm n) (e1:::Enil) *) + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | builtin_arg_case8 n e1 => (* Eop (Oaddlimm n) (e1:::Enil) *) + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | builtin_arg_default e => + BA e + end. + diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp new file mode 100644 index 00000000..bb8af2ed --- /dev/null +++ b/mppa_k1c/SelectOp.vp @@ -0,0 +1,450 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Archi. +Require Import Coqlib. +Require Import Compopts. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Op. +Require Import CminorSel. + +Local Open Scope cminorsel_scope. + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: ptrofs) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: ptrofs) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer addition and pointer addition *) + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | _ => Eop (Oaddimm n) (e ::: Enil) + end. + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => + addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. + +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | _ => Eop Oneg (e ::: Enil) + end. + +(** ** Immediate shifts *) + +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + Eop (Oshlimm n) (e1:::Enil) + end. + +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. + +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +Definition mulhs (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrlimm (Int.repr 32)) + (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: + Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhs (e1 ::: e2 ::: Enil). + +Definition mulhu (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrluimm (Int.repr 32)) + (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: + Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | _ => Eop (Oandimm n1) (e2:::Enil) + end. + +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. + +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | _, _ => Eop Oor (e1:::e2:::Enil) + end. + +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + let n := Int.xor n1 n2 in + if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. + +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer logical negation *) + +Definition notint (e: expr) := xorimm Int.mone e. + +(** ** Integer division and modulus *) + +Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). +Definition mods_base (e1: expr) (e2: expr) := Eop Omod (e1:::e2:::Enil). +Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil). +Definition modu_base (e1: expr) (e2: expr) := Eop Omodu (e1:::e2:::Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). + +(* Alternate definition, not convenient for strength reduction during constant propagation *) +(* +(* n2 will be less than 31. *) + +Definition shrximm_inner (e1: expr) (n2: int) := + Eop (Oshruimm (Int.sub Int.iwordsize n2)) + ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) + (e1 ::: Enil)) + ::: Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 + else Eop (Oshrimm n2) + ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) + ::: Enil). +*) + +(** ** General shifts *) + +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. + +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. + +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). + +Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). +Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). +Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). +Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). +Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +Nondetfunction compimm (default: comparison -> int -> condition) + (sem: comparison -> int -> int -> bool) + (c: comparison) (e1: expr) (n2: int) := + match c, e1 with + | c, Eop (Ointconst n1) Enil => + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | Ceq, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp (negate_condition c)) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp c) el + else + Eop (Ointconst Int.zero) Enil + | Cne, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp c) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp (negate_condition c)) el + else + Eop (Ointconst Int.one) Enil + | _, _ => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. + +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompimm Int.cmp c t1 n2 + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompuimm Int.cmpu c t1 n2 + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +Definition compfs (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +Nondetfunction cast8signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil + | _ => Eop Ocast8signed (e ::: Enil) + end. + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +Nondetfunction cast16signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil + | _ => Eop Ocast16signed (e ::: Enil) + end. + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). + +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => Eop Ofloatofintu (e ::: Enil) + end. + +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatofint (e ::: Enil) + end. + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). +Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). + +Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). +Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). + +(** ** Recognition of addressing modes for load and store operations *) + +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddrsymbol id ofs) Enil => if Archi.pic_code tt then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) + | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) + | _ => (Aindexed Ptrofs.zero, e:::Enil) + end. + +(** ** Arguments of builtins *) + +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | Eop (Oaddlimm n) (e1:::Enil) => + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | _ => BA e + end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v new file mode 100644 index 00000000..e7577fb5 --- /dev/null +++ b/mppa_k1c/SelectOpproof.v @@ -0,0 +1,912 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** Correctness of instruction selection for operators *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import SelectOp. + +Local Open Scope cminorsel_scope. + +(** * Useful lemmas and tactics *) + +(** The following are trivial lemmas and custom tactics that help + perform backward (inversion) and forward reasoning over the evaluation + of operator applications. *) + +Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. + +Ltac InvEval1 := + match goal with + | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => + inv H; InvEval1 + | _ => + idtac + end. + +Ltac InvEval2 := + match goal with + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => + simpl in H; inv H + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | _ => + idtac + end. + +Ltac InvEval := InvEval1; InvEval2; InvEval2. + +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + +(** * Correctness of the smart constructors *) + +Section CMCONSTR. + +Variable ge: genv. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(** We now show that the code generated by "smart constructor" functions + such as [Selection.notint] behaves as expected. Continuing the + [notint] example, we show that if the expression [e] + evaluates to some integer value [Vint n], then [Selection.notint e] + evaluates to a value [Vint (Int.not n)] which is indeed the integer + negation of the value of [e]. + + All proofs follow a common pattern: +- Reasoning by case over the result of the classification functions + (such as [add_match] for integer addition), gathering additional + information on the shape of the argument expressions in the non-default + cases. +- Inversion of the evaluations of the arguments, exploiting the additional + information thus gathered. +- Equational reasoning over the arithmetic operations performed, + using the lemmas from the [Int] and [Float] modules. +- Construction of an evaluation derivation for the expression returned + by the smart constructor. +*) + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Theorem eval_addrsymbol: + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v. +Proof. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. +Qed. + +Theorem eval_addrstack: + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. +Proof. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. +Qed. + +Theorem eval_addimm: + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. intros. exists x; split; auto. + destruct x; simpl; auto. + rewrite Int.add_zero; auto. + - case (addimm_match a); intros; InvEval; simpl. + + TrivialExists; simpl. rewrite Int.add_commut. auto. + + econstructor; split. EvalOp. simpl; eauto. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. + + econstructor; split. EvalOp. simpl; eauto. + destruct sp; simpl; auto. + + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + TrivialExists. +Qed. + +Theorem eval_add: binary_constructor_sound add Val.add. +Proof. + red; intros until y. + unfold add; case (add_match a b); intros; InvEval. + - rewrite Val.add_commut. apply eval_addimm; auto. + - apply eval_addimm; auto. + - subst. + replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2))) + with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_permut. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + rewrite Val.add_commut. destruct sp; simpl; auto. + destruct v1; simpl; auto. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + destruct sp; simpl; auto. + destruct v1; simpl; auto. + - subst. + replace (Val.add (Val.add v1 (Vint n1)) y) + with (Val.add (Val.add v1 y) (Vint n1)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. + - subst. + replace (Val.add x (Val.add v1 (Vint n2))) + with (Val.add (Val.add x v1) (Vint n2)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. reflexivity. + - TrivialExists. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + - rewrite Val.sub_add_opp. apply eval_addimm; auto. + - subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + apply eval_addimm; EvalOp. + - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. + - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + - TrivialExists. +Qed. + +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). +Proof. + red; intros until x. unfold negint. case (negint_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_shlimm: + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. + red; intros until x. unfold shlimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shlimm_match a); intros; InvEval. + - exists (Vint (Int.shl n1 n)); split. EvalOp. + simpl. rewrite LT. auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + + exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + destruct (Int.ltu n Int.iwordsize) eqn:?; simpl; auto. + rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. + + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Theorem eval_shruimm: + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. + red; intros until x. unfold shruimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shruimm_match a); intros; InvEval. + - exists (Vint (Int.shru n1 n)); split. EvalOp. + simpl. rewrite LT; auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Theorem eval_shrimm: + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). +Proof. + red; intros until x. unfold shrimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shrimm_match a); intros; InvEval. + - exists (Vint (Int.shr n1 n)); split. EvalOp. + simpl. rewrite LT; auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + rewrite LT. + rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Lemma eval_mulimm_base: + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros; unfold mulimm_base. + + assert (DFL: exists v, eval_expr ge sp e m le (Eop Omul (Eop (Ointconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mul x (Vint n)) v). + TrivialExists. econstructor. EvalOp. simpl; eauto. econstructor. eauto. constructor. + rewrite Val.mul_commut. auto. + + generalize (Int.one_bits_decomp n). + generalize (Int.one_bits_range n). + destruct (Int.one_bits n). + - intros. auto. + - destruct l. + + intros. rewrite H1. simpl. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. + + destruct l. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit (eval_add (x :: le)). eexact A1. eexact A2. intros [v [A B]]. + exists v; split. econstructor; eauto. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. eapply Val.lessdef_trans. 2: eauto. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. auto. +Qed. + +Theorem eval_mulimm: + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. + + case (mulimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.mul_commut; auto. + - subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + - apply eval_mulimm_base; auto. +Qed. + +Theorem eval_mul: binary_constructor_sound mul Val.mul. +Proof. + red; intros until y. + unfold mul; case (mul_match a b); intros; InvEval. + rewrite Val.mul_commut. apply eval_mulimm. auto. + apply eval_mulimm. auto. + TrivialExists. +Qed. + +Theorem eval_mulhs: binary_constructor_sound mulhs Val.mulhs. +Proof. + red; intros. unfold mulhs; destruct Archi.ptr64 eqn:SF. +- econstructor; split. + EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. + simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. + destruct x; simpl; auto. destruct y; simpl; auto. + change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. + apply Val.lessdef_same. f_equal. + transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). + unfold Int.mulhs; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + apply Int.same_bits_eq; intros n N. + change Int.zwordsize with 32 in *. + assert (N1: 0 <= n < 64) by omega. + rewrite Int64.bits_loword by auto. + rewrite Int64.bits_shr' by auto. + change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. + rewrite zlt_true by omega. + rewrite Int.testbit_repr by auto. + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)). + rewrite Z.shiftr_spec by omega. auto. + apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. + change Int64.zwordsize with 64; omega. +- TrivialExists. +Qed. + +Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. +Proof. + red; intros. unfold mulhu; destruct Archi.ptr64 eqn:SF. +- econstructor; split. + EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. + simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. + destruct x; simpl; auto. destruct y; simpl; auto. + change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. + apply Val.lessdef_same. f_equal. + transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). + unfold Int.mulhu; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + apply Int.same_bits_eq; intros n N. + change Int.zwordsize with 32 in *. + assert (N1: 0 <= n < 64) by omega. + rewrite Int64.bits_loword by auto. + rewrite Int64.bits_shru' by auto. + change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. + rewrite zlt_true by omega. + rewrite Int.testbit_repr by auto. + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)). + rewrite Z.shiftr_spec by omega. auto. + apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. + change Int64.zwordsize with 64; omega. +- TrivialExists. +Qed. + +Theorem eval_andimm: + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). +Proof. + intros; red; intros until x. unfold andimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. + + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists x; split; auto. + subst. destruct x; simpl; auto. rewrite Int.and_mone; auto. + + case (andimm_match a); intros. + - InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. + - InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + - rewrite Val.and_commut. apply eval_andimm; auto. + - apply eval_andimm; auto. + - TrivialExists. +Qed. + +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). +Proof. + intros; red; intros until x. unfold orimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. subst. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.or_zero; auto. + + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists (Vint Int.mone); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. + + destruct (orimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.or_commut; auto. + - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_or: binary_constructor_sound or Val.or. +Proof. + red; intros until y; unfold or; case (or_match a b); intros; InvEval. + - rewrite Val.or_commut. apply eval_orimm; auto. + - apply eval_orimm; auto. + - TrivialExists. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + + intros. destruct (xorimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.xor_commut; auto. + - subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. + predSpec Int.eq Int.eq_spec (Int.xor n2 n) Int.zero. + + exists v1; split; auto. destruct v1; simpl; auto. rewrite H0, Int.xor_zero; auto. + + TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + - rewrite Val.xor_commut. apply eval_xorimm; auto. + - apply eval_xorimm; auto. + - TrivialExists. +Qed. + +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + unfold notint; red; intros. rewrite Val.not_xor. apply eval_xorimm; auto. +Qed. + +Theorem eval_divs_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold divs_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_mods_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold mods_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_divu_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold divu_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_modu_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. +Proof. + intros. unfold modu_base. exists z; split. EvalOp. auto. +Qed. + +Theorem eval_shrximm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrx x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v. +Proof. + intros. unfold shrximm. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. exists x; split; auto. + destruct x; simpl in H0; try discriminate. + destruct (Int.ltu Int.zero (Int.repr 31)); inv H0. + replace (Int.shrx i Int.zero) with i. auto. + unfold Int.shrx, Int.divs. rewrite Int.shl_zero. + change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. + econstructor; split. EvalOp. auto. +(* + intros. destruct x; simpl in H0; try discriminate. + destruct (Int.ltu n (Int.repr 31)) eqn:LTU; inv H0. + unfold shrximm. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. exists (Vint i); split; auto. + unfold Int.shrx, Int.divs. rewrite Z.quot_1_r. rewrite Int.repr_signed. auto. + - assert (NZ: Int.unsigned n <> 0). + { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } + assert (LT: 0 <= Int.unsigned n < 31) by (apply Int.ltu_inv in LTU; assumption). + assert (LTU2: Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize = true). + { unfold Int.ltu; apply zlt_true. + unfold Int.sub. change (Int.unsigned Int.iwordsize) with 32. + rewrite Int.unsigned_repr. omega. + assert (32 < Int.max_unsigned) by reflexivity. omega. } + assert (X: eval_expr ge sp e m le + (Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) (a ::: Enil)) + (Vint (Int.shr i (Int.repr (Int.zwordsize - 1))))). + { EvalOp. } + assert (Y: eval_expr ge sp e m le (shrximm_inner a n) + (Vint (Int.shru (Int.shr i (Int.repr (Int.zwordsize - 1))) (Int.sub Int.iwordsize n)))). + { EvalOp. simpl. rewrite LTU2. auto. } + TrivialExists. + constructor. EvalOp. simpl; eauto. constructor. + simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int.shrx_shr_2 by auto. reflexivity. + change (Int.unsigned Int.iwordsize) with 32; omega. +*) +Qed. + +Theorem eval_shl: binary_constructor_sound shl Val.shl. +Proof. + red; intros until y; unfold shl; case (shl_match b); intros. + InvEval. apply eval_shlimm; auto. + TrivialExists. +Qed. + +Theorem eval_shr: binary_constructor_sound shr Val.shr. +Proof. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. +Qed. + +Theorem eval_shru: binary_constructor_sound shru Val.shru. +Proof. + red; intros until y; unfold shru; case (shru_match b); intros. + InvEval. apply eval_shruimm; auto. + TrivialExists. +Qed. + +Theorem eval_negf: unary_constructor_sound negf Val.negf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_absf: unary_constructor_sound absf Val.absf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addf: binary_constructor_sound addf Val.addf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_negfs: unary_constructor_sound negfs Val.negfs. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_absfs: unary_constructor_sound absfs Val.absfs. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addfs: binary_constructor_sound addfs Val.addfs. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subfs: binary_constructor_sound subfs Val.subfs. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs. +Proof. + red; intros; TrivialExists. +Qed. + +Section COMP_IMM. + +Variable default: comparison -> int -> condition. +Variable intsem: comparison -> int -> int -> bool. +Variable sem: comparison -> val -> val -> val. + +Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y). +Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef. +Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y). +Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)). +Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m). + +Lemma eval_compimm: + forall le c a n2 x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v + /\ Val.lessdef (sem c x (Vint n2)) v. +Proof. + intros until x. + unfold compimm; case (compimm_match c a); intros. +(* constant *) + - InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. +(* eq cmp *) + - InvEval. inv H. simpl in H5. inv H5. + destruct (Int.eq_dec n2 Int.zero). + + subst n2. TrivialExists. + simpl. rewrite eval_negate_condition. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. + rewrite sem_undef; auto. + + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. + simpl. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. + rewrite sem_undef; auto. + exists (Vint Int.zero); split. EvalOp. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto. + rewrite sem_undef; auto. +(* ne cmp *) + - InvEval. inv H. simpl in H5. inv H5. + destruct (Int.eq_dec n2 Int.zero). + + subst n2. TrivialExists. + simpl. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. + rewrite sem_undef; auto. + + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. + simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. + rewrite sem_undef; auto. + exists (Vint Int.one); split. EvalOp. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto. + rewrite sem_undef; auto. +(* default *) + - TrivialExists. simpl. rewrite sem_default. auto. +Qed. + +Hypothesis sem_swap: + forall c x y, sem (swap_comparison c) x y = sem c y x. + +Lemma eval_compimm_swap: + forall le c a n2 x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v + /\ Val.lessdef (sem c (Vint n2) x) v. +Proof. + intros. rewrite <- sem_swap. eapply eval_compimm; eauto. +Qed. + +End COMP_IMM. + +Theorem eval_comp: + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + eapply eval_compimm_swap; eauto. + intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto. + eapply eval_compimm; eauto. + TrivialExists. +Qed. + +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). +Proof. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + eapply eval_compimm_swap; eauto. + intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto. + eapply eval_compimm; eauto. + TrivialExists. +Qed. + +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. + +Theorem eval_compfs: + forall c, binary_constructor_sound (compfs c) (Val.cmpfs c). +Proof. + intros; red; intros. unfold compfs. TrivialExists. +Qed. + +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros until x. unfold cast8signed. case (cast8signed_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. +Qed. + +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros until x. unfold cast16signed. case (cast16signed_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. +Qed. + +Theorem eval_intoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intoffloat. TrivialExists. +Qed. + +Theorem eval_intuoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuoffloat. TrivialExists. +Qed. + +Theorem eval_floatofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold floatofintu. case (floatofintu_match a); intros. + InvEval. simpl in H0. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_floatofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros until y; unfold floatofint. case (floatofint_match a); intros. + InvEval. simpl in H0. TrivialExists. + TrivialExists. +Qed. + +Theorem eval_intofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. +Proof. + intros; unfold intofsingle. TrivialExists. +Qed. + +Theorem eval_singleofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofint x = Some y -> + exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. +Proof. + intros; unfold singleofint; TrivialExists. +Qed. + +Theorem eval_intuofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuofsingle. TrivialExists. +Qed. + +Theorem eval_singleofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofintu x = Some y -> + exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuofsingle. TrivialExists. +Qed. + +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. + +Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle. +Proof. + red; intros. unfold floatofsingle. TrivialExists. +Qed. + +Theorem eval_addressing: + forall le chunk a v b ofs, + eval_expr ge sp e m le a v -> + v = Vptr b ofs -> + match addressing chunk a with (mode, args) => + exists vl, + eval_exprlist ge sp e m le args vl /\ + eval_addressing ge sp mode vl = Some v + end. +Proof. + intros until v. unfold addressing; case (addressing_match a); intros; InvEval. + - exists (@nil val); split. eauto with evalexpr. simpl. auto. + - destruct (Archi.pic_code tt). + + exists (Vptr b ofs0 :: nil); split. + constructor. EvalOp. simpl. congruence. constructor. simpl. rewrite Ptrofs.add_zero. congruence. + + exists (@nil val); split. constructor. simpl; auto. + - exists (v1 :: nil); split. eauto with evalexpr. simpl. + destruct v1; simpl in H; try discriminate. + - exists (v1 :: nil); split. eauto with evalexpr. simpl. + destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. + simpl. auto. + - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. +Qed. + +Theorem eval_builtin_arg: + forall a v, + eval_expr ge sp e m nil a v -> + CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. +Proof. + intros until v. unfold builtin_arg; case (builtin_arg_match a); intros. +- InvEval. constructor. +- InvEval. constructor. +- InvEval. constructor. +- InvEval. simpl in H5. inv H5. constructor. +- InvEval. subst v. constructor; auto. +- inv H. InvEval. simpl in H6; inv H6. constructor; auto. +- destruct Archi.ptr64 eqn:SF. ++ constructor; auto. ++ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vint n) else Val.add v1 (Vint n)). + repeat constructor; auto. + rewrite SF; auto. +- destruct Archi.ptr64 eqn:SF. ++ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vlong n) else Val.add v1 (Vlong n)). + repeat constructor; auto. ++ constructor; auto. +- constructor; auto. +Qed. + +End CMCONSTR. diff --git a/mppa_k1c/Stacklayout.v b/mppa_k1c/Stacklayout.v new file mode 100644 index 00000000..d0c6a526 --- /dev/null +++ b/mppa_k1c/Stacklayout.v @@ -0,0 +1,147 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import AST Memory Separation. +Require Import Bounds. + +Local Open Scope sep_scope. + +(** The general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- Space for outgoing arguments to function calls. +- Back link to parent frame +- Return address +- Saved values of callee-save registers used by the function. +- Local stack slots. +- Space for the stack-allocated data declared in Cminor. + +The stack pointer is kept 16-aligned. +*) + +Definition fe_ofs_arg := 0. + +Definition make_env (b: bounds) : frame_env := + let w := if Archi.ptr64 then 8 else 4 in + let olink := align (4 * b.(bound_outgoing)) w in (* back link *) + let oretaddr := olink + w in (* return address *) + let ocs := oretaddr + w in (* callee-saves *) + let ol := align (size_callee_save_area b ocs) 8 in (* locals *) + let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) + let sz := align (ostkdata + b.(bound_stack_data)) 16 in + {| fe_size := sz; + fe_ofs_link := olink; + fe_ofs_retaddr := oretaddr; + fe_ofs_local := ol; + fe_ofs_callee_save := ocs; + fe_stack_data := ostkdata; + fe_used_callee_save := b.(used_callee_save) |}. + +Lemma frame_env_separated: + forall b sp m P, + let fe := make_env b in + m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P -> + m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b) + ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b) + ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr) + ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr) + ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe)) + ** P. +Proof. +Local Opaque Z.add Z.mul sepconj range. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). +(* Reorder as: + outgoing + back link + retaddr + callee-save + local *) + rewrite sep_swap12. + rewrite sep_swap23. + rewrite sep_swap34. + rewrite sep_swap45. +(* Apply range_split and range_split2 repeatedly *) + unfold fe_ofs_arg. + apply range_split_2. fold olink; omega. omega. + apply range_split. omega. + apply range_split. omega. + apply range_split_2. fold ol. omega. omega. + apply range_drop_right with ostkdata. omega. + eapply sep_drop2. eexact H. +Qed. + +Lemma frame_env_range: + forall b, + let fe := make_env b in + 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. +Proof. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). + split. omega. apply align_le. omega. +Qed. + +Lemma frame_env_aligned: + forall b, + let fe := make_env b in + (8 | fe_ofs_arg) + /\ (8 | fe_ofs_local fe) + /\ (8 | fe_stack_data fe) + /\ (align_chunk Mptr | fe_ofs_link fe) + /\ (align_chunk Mptr | fe_ofs_retaddr fe). +Proof. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). + split. apply Z.divide_0_r. + split. apply align_divides; omega. + split. apply align_divides; omega. + split. apply align_divides; omega. + apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl. +Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml new file mode 100644 index 00000000..143b7622 --- /dev/null +++ b/mppa_k1c/TargetPrinter.ml @@ -0,0 +1,439 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(* Printing RISC-V assembly code in asm syntax *) + +open Printf +open Camlcoq +open Sections +open AST +open Asm +open PrintAsmaux +open Fileinfo + +(* Module containing the printing functions *) + +module Target : TARGET = + struct + +(* Basic printing functions *) + + let comment = "#" + + let symbol = elf_symbol + let symbol_offset = elf_symbol_offset + let label = elf_label + + let print_label oc lbl = label oc (transl_label lbl) + + let int_reg_name = let open Asmblock in function + | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" + | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" + | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" + | GPR12 -> "$r12" | GPR13 -> "$r13" | GPR14 -> "$r14" | GPR15 -> "$r15" + | GPR16 -> "$r16" | GPR17 -> "$r17" | GPR18 -> "$r18" | GPR19 -> "$r19" + | GPR20 -> "$r20" | GPR21 -> "$r21" | GPR22 -> "$r22" | GPR23 -> "$r23" + | GPR24 -> "$r24" | GPR25 -> "$r25" | GPR26 -> "$r26" | GPR27 -> "$r27" + | GPR28 -> "$r28" | GPR29 -> "$r29" | GPR30 -> "$r30" | GPR31 -> "$r31" + | GPR32 -> "$r32" | GPR33 -> "$r33" | GPR34 -> "$r34" | GPR35 -> "$r35" + | GPR36 -> "$r36" | GPR37 -> "$r37" | GPR38 -> "$r38" | GPR39 -> "$r39" + | GPR40 -> "$r40" | GPR41 -> "$r41" | GPR42 -> "$r42" | GPR43 -> "$r43" + | GPR44 -> "$r44" | GPR45 -> "$r45" | GPR46 -> "$r46" | GPR47 -> "$r47" + | GPR48 -> "$r48" | GPR49 -> "$r49" | GPR50 -> "$r50" | GPR51 -> "$r51" + | GPR52 -> "$r52" | GPR53 -> "$r53" | GPR54 -> "$r54" | GPR55 -> "$r55" + | GPR56 -> "$r56" | GPR57 -> "$r57" | GPR58 -> "$r58" | GPR59 -> "$r59" + | GPR60 -> "$r60" | GPR61 -> "$r61" | GPR62 -> "$r62" | GPR63 -> "$r63" + + let ireg oc r = output_string oc (int_reg_name r) + + let ireg = ireg + + let preg oc = let open Asmblock in function + | IR r -> ireg oc r + | FR r -> ireg oc r + | RA -> output_string oc "$ra" + | _ -> assert false + + let preg_annot = let open Asmblock in function + | IR r -> int_reg_name r + | FR r -> int_reg_name r + | RA -> "$ra" + | _ -> assert false + +(* Names of sections *) + + let name_of_section = function + | Section_text -> ".text" + | Section_data i | Section_small_data i -> + if i then ".data" else "COMM" + | Section_const i | Section_small_const i -> + if i then ".section .rodata" else "COMM" + | Section_string -> ".section .rodata" + | Section_literal -> ".section .rodata" + | Section_jumptable -> ".section .rodata" + | Section_debug_info _ -> ".section .debug_info,\"\",%progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" + | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1" + | Section_user(s, wr, ex) -> + sprintf ".section \"%s\",\"a%s%s\",%%progbits" + s (if wr then "w" else "") (if ex then "x" else "") + | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + + let section oc sec = + fprintf oc " %s\n" (name_of_section sec) + +(* Associate labels to floating-point constants and to symbols. *) + + let emit_constants oc lit = + if exists_constants () then begin + section oc lit; + if Hashtbl.length literal64_labels > 0 then + begin + fprintf oc " .align 3\n"; + Hashtbl.iter + (fun bf lbl -> fprintf oc "%a: .quad 0x%Lx\n" label lbl bf) + literal64_labels + end; + if Hashtbl.length literal32_labels > 0 then + begin + fprintf oc " .align 2\n"; + Hashtbl.iter + (fun bf lbl -> + fprintf oc "%a: .long 0x%lx\n" label lbl bf) + literal32_labels + end; + reset_literals () + end + +(* Generate code to load the address of id + ofs in register r *) + + let loadsymbol oc r id ofs = + if Archi.pic_code () then begin + assert (ofs = Integers.Ptrofs.zero); + fprintf oc " make %a = %s\n;;\n" ireg r (extern_atom id) + end else begin + fprintf oc " make %a = %a\n;;\n" ireg r symbol_offset (id, ofs) + end + +(* Emit .file / .loc debugging directives *) + + let print_file_line oc file line = + print_file_line oc comment file line + +(* + let print_location oc loc = + if loc <> Cutil.no_loc then print_file_line oc (fst loc) (snd loc) +*) + +(* Add "w" suffix to 32-bit instructions if we are in 64-bit mode *) + + (*let w oc = + if Archi.ptr64 then output_string oc "w" + *) +(* Offset part of a load or store *) + + let offset oc = let open Asmblock in function + | Ofsimm n -> ptrofs oc n + | Ofslow(id, ofs) -> fprintf oc "%%lo(%a)" symbol_offset (id, ofs) + + let icond_name = let open Asmblock in function + | ITne | ITneu -> "ne" + | ITeq | ITequ -> "eq" + | ITlt -> "lt" + | ITge -> "ge" + | ITle -> "le" + | ITgt -> "gt" + | ITltu -> "ltu" + | ITgeu -> "geu" + | ITleu -> "leu" + | ITgtu -> "gtu" + | ITall -> "all" + | ITnall -> "nall" + | ITany -> "any" + | ITnone -> "none" + + let icond oc c = fprintf oc "%s" (icond_name c) + + let bcond_name = let open Asmblock in function + | BTwnez -> "wnez" + | BTweqz -> "weqz" + | BTwltz -> "wltz" + | BTwgez -> "wgez" + | BTwlez -> "wlez" + | BTwgtz -> "wgtz" + | BTdnez -> "dnez" + | BTdeqz -> "deqz" + | BTdltz -> "dltz" + | BTdgez -> "dgez" + | BTdlez -> "dlez" + | BTdgtz -> "dgtz" + + let bcond oc c = fprintf oc "%s" (bcond_name c) + +(* Printing of instructions *) + let print_instruction oc = function + (* Pseudo-instructions expanded in Asmexpand *) + | Pallocframe(sz, ofs) -> + assert false + | Pfreeframe(sz, ofs) -> + assert false + + (* Pseudo-instructions that remain *) + | Plabel lbl -> + fprintf oc "%a:\n" print_label lbl + | Ploadsymbol(rd, id, ofs) -> + loadsymbol oc rd id ofs + | Pbuiltin(ef, args, res) -> + begin match ef with + | EF_annot(kind,txt, targs) -> + begin match (P.to_int kind) with + | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in + fprintf oc "%s annotation: %S\n" comment annot + (*| 2 -> let lbl = new_label () in + fprintf oc "%a: " label lbl; + add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args + *)| _ -> assert false + end + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg_annot "sp" oc + (P.to_int kind) (extern_atom txt) args + | EF_inline_asm(txt, sg, clob) -> + fprintf oc "%s begin inline assembly\n\t" comment; + print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + fprintf oc "%s end inline assembly\n" comment + | _ -> + assert false + end + | Pnop -> fprintf oc " nop\n;;\n" + + | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n;;\n" ireg rd ireg rs + | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + + (* Control flow instructions *) + | Pget (rd, rs) -> + fprintf oc " get %a = %a\n;;\n" ireg rd preg rs + | Pset (rd, rs) -> + fprintf oc " set %a = %a\n;;\n" preg rd ireg rs + | Pret -> + fprintf oc " ret \n;;\n" + | Pcall(s) -> + fprintf oc " call %a\n;;\n" symbol s + | Pgoto(s) -> + fprintf oc " goto %a\n;;\n" symbol s + | Pj_l(s) -> + fprintf oc " goto %a\n;;\n" print_label s + | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> + fprintf oc " cb.%a %a?%a\n;;\n" bcond bt ireg r print_label lbl + + (* Load/Store instructions *) + | Plb(rd, ra, ofs) -> + fprintf oc " lbs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plbu(rd, ra, ofs) -> + fprintf oc " lbz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plh(rd, ra, ofs) -> + fprintf oc " lhs %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plhu(rd, ra, ofs) -> + fprintf oc " lhz %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Plw(rd, ra, ofs) | Plw_a(rd, ra, ofs) | Pfls(rd, ra, ofs) -> + fprintf oc " lws %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + | Pld(rd, ra, ofs) | Pfld(rd, ra, ofs) | Pld_a(rd, ra, ofs) -> assert Archi.ptr64; + fprintf oc " ld %a = %a[%a]\n;;\n" ireg rd offset ofs ireg ra + + | Psb(rd, ra, ofs) -> + fprintf oc " sb %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psh(rd, ra, ofs) -> + fprintf oc " sh %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psw(rd, ra, ofs) | Psw_a(rd, ra, ofs) | Pfss(rd, ra, ofs) -> + fprintf oc " sw %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + | Psd(rd, ra, ofs) | Psd_a(rd, ra, ofs) | Pfsd(rd, ra, ofs) -> assert Archi.ptr64; + fprintf oc " sd %a[%a] = %a\n;;\n" offset ofs ireg ra ireg rd + + (* Arith R instructions *) + | Pcvtw2l(rd) -> assert false + + (* Arith RR instructions *) + | Pmv(rd, rs) | Pmvw2l(rd, rs) -> + fprintf oc " addd %a = %a, 0\n;;\n" ireg rd ireg rs + | Pcvtl2w(rd, rs) -> assert false + | Pnegl(rd, rs) -> assert Archi.ptr64; + fprintf oc " negd %a = %a\n;;\n" ireg rd ireg rs + | Pnegw(rd, rs) -> + fprintf oc " negw %a = %a\n;;\n" ireg rd ireg rs + | Pfnegd(rd, rs) -> + fprintf oc " fnegd %a = %a\n;;\n" ireg rs ireg rd + + (* Arith RI32 instructions *) + | Pmake (rd, imm) -> + fprintf oc " make %a, %a\n;;\n" ireg rd coqint imm + + (* Arith RI64 instructions *) + | Pmakel (rd, imm) -> + fprintf oc " make %a, %a\n;;\n" ireg rd coqint64 imm + + (* Arith RRR instructions *) + | Pcompw (it, rd, rs1, rs2) -> + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcompl (it, rd, rs1, rs2) -> + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs1 ireg rs2 + + | Paddw (rd, rs1, rs2) -> + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psubw (rd, rs1, rs2) -> + fprintf oc " sbfw %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + | Pmulw (rd, rs1, rs2) -> + fprintf oc " mulw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pandw (rd, rs1, rs2) -> + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Porw (rd, rs1, rs2) -> + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pxorw (rd, rs1, rs2) -> + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psraw (rd, rs1, rs2) -> + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrlw (rd, rs1, rs2) -> + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psllw (rd, rs1, rs2) -> + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psubl (rd, rs1, rs2) -> + fprintf oc " sbfd %a = %a, %a\n;;\n" ireg rd ireg rs2 ireg rs1 + | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Porl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pmull (rd, rs1, rs2) -> + fprintf oc " muld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Pslll (rd, rs1, rs2) -> + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psrll (rd, rs1, rs2) -> + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + | Psral (rd, rs1, rs2) -> + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs1 ireg rs2 + + (* Arith RRI32 instructions *) + | Pcompiw (it, rd, rs, imm) -> + fprintf oc " compw.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + | Paddiw (rd, rs, imm) -> + fprintf oc " addw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pandiw (rd, rs, imm) -> + fprintf oc " andw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Poriw (rd, rs, imm) -> + fprintf oc " orw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pxoriw (rd, rs, imm) -> + fprintf oc " xorw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psraiw (rd, rs, imm) -> + fprintf oc " sraw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrliw (rd, rs, imm) -> + fprintf oc " srlw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pslliw (rd, rs, imm) -> + fprintf oc " sllw %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psllil (rd, rs, imm) -> + fprintf oc " slld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrlil (rd, rs, imm) -> + fprintf oc " srld %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Psrail (rd, rs, imm) -> + fprintf oc " srad %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + + (* Arith RRI64 instructions *) + | Pcompil (it, rd, rs, imm) -> + fprintf oc " compd.%a %a = %a, %a\n;;\n" icond it ireg rd ireg rs coqint64 imm + | Paddil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pandil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Poril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + | Pxoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n;;\n" ireg rd ireg rs coqint64 imm + + let get_section_names name = + let (text, lit) = + match C2C.atom_sections name with + | t :: l :: _ -> (t, l) + | _ -> (Section_text, Section_literal) in + text,lit,Section_jumptable + + let print_align oc alignment = + fprintf oc " .balign %d\n" alignment + + let print_jumptable oc jmptbl = + let print_tbl oc (lbl, tbl) = + fprintf oc "%a:\n" label lbl; + List.iter + (fun l -> fprintf oc " .long %a - %a\n" + print_label l label lbl) + tbl in + if !jumptables <> [] then + begin + section oc jmptbl; + fprintf oc " .balign 4\n"; + List.iter (print_tbl oc) !jumptables; + jumptables := [] + end + + let print_fun_info = elf_print_fun_info + + let print_optional_fun_info _ = () + + let print_var_info = elf_print_var_info + + let print_comm_symb oc sz name align = + if C2C.atom_is_static name then + fprintf oc " .local %a\n" symbol name; + fprintf oc " .comm %a, %s, %d\n" + symbol name + (Z.to_string sz) + align + + let print_instructions oc fn = + current_function_sig := fn.fn_sig; + List.iter (print_instruction oc) fn.fn_code + + +(* Data *) + + let address = if Archi.ptr64 then ".quad" else ".long" + + let print_prologue oc = + (* fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); *) + if !Clflags.option_g then begin + section oc Section_text; + end + + let print_epilogue oc = + if !Clflags.option_g then begin + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + end + + let default_falignment = 2 + + let cfi_startproc oc = () + let cfi_endproc oc = () + + end + +let sel_target () = + (module Target:TARGET) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v new file mode 100644 index 00000000..5670b5fe --- /dev/null +++ b/mppa_k1c/ValueAOp.v @@ -0,0 +1,218 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib Compopts. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op RTL ValueDomain. + +(** Value analysis for RISC V operators *) + +Definition eval_static_condition (cond: condition) (vl: list aval): abool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2 + | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n) + | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n) + | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2 + | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n) + | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n) + | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 + | 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) + | _, _ => Bnone + end. + +Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := + match addr, vl with + | Aindexed n, v1::nil => offset_ptr v1 n + | Aglobal s ofs, nil => Ptr (Gl s ofs) + | Ainstack ofs, nil => Ptr (Stk ofs) + | _, _ => Vbot + end. + +Definition eval_static_operation (op: operation) (vl: list aval): aval := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Olongconst n, nil => L n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop + | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop + | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs) + | Oaddrstack ofs, nil => Ptr (Stk ofs) + | Ocast8signed, v1 :: nil => sign_ext 8 v1 + | Ocast16signed, v1 :: nil => sign_ext 16 v1 + | Oadd, v1::v2::nil => add v1 v2 + | Oaddimm n, v1::nil => add v1 (I n) + | Oneg, v1::nil => neg v1 + | Osub, v1::v2::nil => sub v1 v2 + | Omul, v1::v2::nil => mul v1 v2 + | Omulhs, v1::v2::nil => mulhs v1 v2 + | Omulhu, v1::v2::nil => mulhu v1 v2 + | Odiv, v1::v2::nil => divs v1 v2 + | Odivu, v1::v2::nil => divu v1 v2 + | Omod, v1::v2::nil => mods v1 v2 + | Omodu, v1::v2::nil => modu v1 v2 + | Oand, v1::v2::nil => and v1 v2 + | Oandimm n, v1::nil => and v1 (I n) + | Oor, v1::v2::nil => or v1 v2 + | Oorimm n, v1::nil => or v1 (I n) + | Oxor, v1::v2::nil => xor v1 v2 + | Oxorimm n, v1::nil => xor v1 (I n) + | Oshl, v1::v2::nil => shl v1 v2 + | Oshlimm n, v1::nil => shl v1 (I n) + | Oshr, v1::v2::nil => shr v1 v2 + | Oshrimm n, v1::nil => shr v1 (I n) + | Oshru, v1::v2::nil => shru v1 v2 + | Oshruimm n, v1::nil => shru v1 (I n) + | Oshrximm n, v1::nil => shrx v1 (I n) + | Omakelong, v1::v2::nil => longofwords v1 v2 + | Olowlong, v1::nil => loword v1 + | Ohighlong, v1::nil => hiword v1 + | Ocast32signed, v1::nil => longofint v1 + | Ocast32unsigned, v1::nil => longofintu v1 + | Oaddl, v1::v2::nil => addl v1 v2 + | Oaddlimm n, v1::nil => addl v1 (L n) + | Onegl, v1::nil => negl v1 + | Osubl, v1::v2::nil => subl v1 v2 + | Omull, v1::v2::nil => mull v1 v2 + | Omullhs, v1::v2::nil => mullhs v1 v2 + | Omullhu, v1::v2::nil => mullhu v1 v2 + | Odivl, v1::v2::nil => divls v1 v2 + | Odivlu, v1::v2::nil => divlu v1 v2 + | Omodl, v1::v2::nil => modls v1 v2 + | Omodlu, v1::v2::nil => modlu v1 v2 + | Oandl, v1::v2::nil => andl v1 v2 + | Oandlimm n, v1::nil => andl v1 (L n) + | Oorl, v1::v2::nil => orl v1 v2 + | Oorlimm n, v1::nil => orl v1 (L n) + | Oxorl, v1::v2::nil => xorl v1 v2 + | Oxorlimm n, v1::nil => xorl v1 (L n) + | Oshll, v1::v2::nil => shll v1 v2 + | Oshllimm n, v1::nil => shll v1 (I n) + | Oshrl, v1::v2::nil => shrl v1 v2 + | Oshrlimm n, v1::nil => shrl v1 (I n) + | Oshrlu, v1::v2::nil => shrlu v1 v2 + | Oshrluimm n, v1::nil => shrlu v1 (I n) + | Oshrxlimm n, v1::nil => shrxl v1 (I n) + | Onegf, v1::nil => negf v1 + | Oabsf, v1::nil => absf v1 + | Oaddf, v1::v2::nil => addf v1 v2 + | Osubf, v1::v2::nil => subf v1 v2 + | Omulf, v1::v2::nil => mulf v1 v2 + | Odivf, v1::v2::nil => divf v1 v2 + | Onegfs, v1::nil => negfs v1 + | Oabsfs, v1::nil => absfs v1 + | Oaddfs, v1::v2::nil => addfs v1 v2 + | Osubfs, v1::v2::nil => subfs v1 v2 + | Omulfs, v1::v2::nil => mulfs v1 v2 + | Odivfs, v1::v2::nil => divfs v1 v2 + | Osingleoffloat, v1::nil => singleoffloat v1 + | Ofloatofsingle, v1::nil => floatofsingle v1 + | Ointoffloat, v1::nil => intoffloat v1 + | Ointuoffloat, v1::nil => intuoffloat v1 + | Ofloatofint, v1::nil => floatofint v1 + | Ofloatofintu, v1::nil => floatofintu v1 + | Ointofsingle, v1::nil => intofsingle v1 + | Ointuofsingle, v1::nil => intuofsingle v1 + | Osingleofint, v1::nil => singleofint v1 + | Osingleofintu, v1::nil => singleofintu v1 + | Olongoffloat, v1::nil => longoffloat v1 + | Olonguoffloat, v1::nil => longuoffloat v1 + | Ofloatoflong, v1::nil => floatoflong v1 + | Ofloatoflongu, v1::nil => floatoflongu v1 + | Olongofsingle, v1::nil => longofsingle v1 + | Olonguofsingle, v1::nil => longuofsingle v1 + | Osingleoflong, v1::nil => singleoflong v1 + | Osingleoflongu, v1::nil => singleoflongu v1 + | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | _, _ => Vbot + end. + +Section SOUNDNESS. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. + +Theorem eval_static_condition_sound: + forall cond vargs m aargs, + list_forall2 (vmatch bc) vargs aargs -> + cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs). +Proof. + intros until aargs; intros VM. inv VM. + destruct cond; auto with va. + inv H0. + destruct cond; simpl; eauto with va. + inv H2. + destruct cond; simpl; eauto with va. + destruct cond; auto with va. +Qed. + +Lemma symbol_address_sound: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). +Proof. + intros; apply symbol_address_sound; apply GENV. +Qed. + +Lemma symbol_address_sound_2: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F. + constructor. constructor. apply GENV; auto. + constructor. +Qed. + +Hint Resolve symbol_address_sound symbol_address_sound_2: va. + +Ltac InvHyps := + match goal with + | [H: None = Some _ |- _ ] => discriminate + | [H: Some _ = Some _ |- _] => inv H + | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ , + H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps + | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps + | _ => idtac + end. + +Theorem eval_static_addressing_sound: + forall addr vargs vres aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_addressing addr aargs). +Proof. + unfold eval_addressing, eval_static_addressing; intros; + destruct addr; InvHyps; eauto with va. + rewrite Ptrofs.add_zero_l; 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 -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_operation op aargs). +Proof. + unfold eval_operation, eval_static_operation; intros; + destruct op; InvHyps; eauto with va. + destruct (propagate_float_constants tt); constructor. + destruct (propagate_float_constants tt); constructor. + rewrite Ptrofs.add_zero_l; eauto with va. + apply of_optbool_sound. eapply eval_static_condition_sound; eauto. +Qed. + +End SOUNDNESS. + diff --git a/mppa_k1c/extractionMachdep.v b/mppa_k1c/extractionMachdep.v new file mode 100644 index 00000000..e70f51de --- /dev/null +++ b/mppa_k1c/extractionMachdep.v @@ -0,0 +1,29 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Additional extraction directives specific to the RISC-V port *) + +Require Archi Asm. + +(* Archi *) + +Extract Constant Archi.ptr64 => " Configuration.model = ""64"" ". +Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) + +(* Asm *) +(* +Extract Constant Asm.low_half => "fun _ _ _ -> assert false". +Extract Constant Asm.high_half => "fun _ _ _ -> assert false". +*) diff --git a/runtime/Makefile b/runtime/Makefile index 27ad6e8c..30c1fc83 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -22,6 +22,9 @@ ifeq ($(ARCH),x86_64) OBJS=i64_dtou.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),powerpc64) OBJS=i64_dtou.o i64_stof.o i64_utod.o i64_utof.o vararg.o +else ifeq ($(ARCH),mppa_k1c) +OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o +DOMAKE:=$(shell (cd mppa_k1c && make)) else OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \ i64_shr.o i64_smod.o i64_stod.o i64_stof.o \ diff --git a/runtime/mppa_k1c/Makefile b/runtime/mppa_k1c/Makefile new file mode 100644 index 00000000..e10c5086 --- /dev/null +++ b/runtime/mppa_k1c/Makefile @@ -0,0 +1,14 @@ +CCOMP ?= ccomp +CFLAGS ?= -O2 -D__K1_TINYK1__ + +CFILES=$(wildcard *.c) +SFILES=$(subst .c,.s,$(CFILES)) + +CCOMPPATH=$(shell which $(CCOMP)) + +all: $(SFILES) + +.SECONDARY: +%.s: %.c $(CCOMPPATH) + $(CCOMP) $(CFLAGS) -S $< -o $@ + sed -i -e 's/i64_/__compcert_i64_/g' $@ diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c new file mode 100644 index 00000000..9ef1a25c --- /dev/null +++ b/runtime/mppa_k1c/i64_sdiv.c @@ -0,0 +1,29 @@ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted); + +long long +i64_sdiv (long long a, long long b) +{ + int neg = 0; + long long res; + + if (a < 0) + { + a = -a; + neg = !neg; + } + + if (b < 0) + { + b = -b; + neg = !neg; + } + + res = udivmoddi4 (a, b, 0); + + if (neg) + res = -res; + + return res; +} + diff --git a/runtime/mppa_k1c/i64_smod.c b/runtime/mppa_k1c/i64_smod.c new file mode 100644 index 00000000..010edd85 --- /dev/null +++ b/runtime/mppa_k1c/i64_smod.c @@ -0,0 +1,25 @@ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted); + +long long +i64_smod (long long a, long long b) +{ + int neg = 0; + long long res; + + if (a < 0) + { + a = -a; + neg = 1; + } + + if (b < 0) + b = -b; + + res = udivmoddi4 (a, b, 1); + + if (neg) + res = -res; + + return res; +} diff --git a/runtime/mppa_k1c/i64_udiv.c b/runtime/mppa_k1c/i64_udiv.c new file mode 100644 index 00000000..2a8dcbf5 --- /dev/null +++ b/runtime/mppa_k1c/i64_udiv.c @@ -0,0 +1,8 @@ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted); + +unsigned long long i64_udiv (unsigned long long a, unsigned long long b) +{ + return udivmoddi4 (a, b, 0); +} + diff --git a/runtime/mppa_k1c/i64_udivmod.c b/runtime/mppa_k1c/i64_udivmod.c new file mode 100644 index 00000000..20d8c976 --- /dev/null +++ b/runtime/mppa_k1c/i64_udivmod.c @@ -0,0 +1,58 @@ +#ifdef __K1_TINYK1__ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted) +{ + unsigned long long bit = 1; + unsigned long long res = 0; + + while (den < num && bit && !(den & (1L<<31))) + { + den <<=1; + bit <<=1; + } + while (bit) + { + if (num >= den) + { + num -= den; + res |= bit; + } + bit >>=1; + den >>=1; + } + if (modwanted) return num; + return res; +} + +#else + +/* THIS IS THE PREVIOUS VERSION, USED ON BOSTAN AND ANDEY */ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted) +{ + unsigned long long r = num, q = 0; + + if(den <= r) { + unsigned k = __builtin_clzll (den) - __builtin_clzll (r); + den = den << k; + if(r >= den) { + r = r - den; + q = 1LL << k; + } + if(k != 0) { + unsigned i = k; + den = den >> 1; + do { + r = __builtin_k1_stsud (den, r); + i--; + } while (i!= 0); + q = q + r; + r = r >> k; + q = q - (r << k); + } + } + + return modwanted ? r : q; +} +#endif /* __K1_TINYK1__ */ + diff --git a/runtime/mppa_k1c/i64_umod.c b/runtime/mppa_k1c/i64_umod.c new file mode 100644 index 00000000..fc0872bb --- /dev/null +++ b/runtime/mppa_k1c/i64_umod.c @@ -0,0 +1,9 @@ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted); + +unsigned long long +i64_umod (unsigned long long a, unsigned long long b) +{ + return udivmoddi4 (a, b, 1); +} + diff --git a/test/mppa/.gitignore b/test/mppa/.gitignore new file mode 100644 index 00000000..e8ebeff8 --- /dev/null +++ b/test/mppa/.gitignore @@ -0,0 +1,20 @@ +check +asm_coverage +instr/Makefile +mmult/Makefile +prng/Makefile +sort/Makefile +prng/.zero +sort/.zero +sort/insertion-ccomp-k1c +sort/insertion-gcc-k1c +sort/insertion-gcc-x86 +sort/main-ccomp-k1c +sort/main-gcc-k1c +sort/main-gcc-x86 +sort/merge-ccomp-k1c +sort/merge-gcc-k1c +sort/merge-gcc-x86 +sort/selection-ccomp-k1c +sort/selection-gcc-k1c +sort/selection-gcc-x86 diff --git a/test/mppa/asm_coverage b/test/mppa/asm_coverage new file mode 160000 +Subproject a9c62b61552a9e9fd0ebf43df5ee0d5b88bb094 diff --git a/test/mppa/builtins/clzll.c b/test/mppa/builtins/clzll.c new file mode 100644 index 00000000..13905cba --- /dev/null +++ b/test/mppa/builtins/clzll.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = __builtin_clzll(a); +} +END_TEST() diff --git a/test/mppa/builtins/stsud.c b/test/mppa/builtins/stsud.c new file mode 100644 index 00000000..fb07b94f --- /dev/null +++ b/test/mppa/builtins/stsud.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_k1_stsud(t[0], t[1]); +} +END_TEST() diff --git a/test/mppa/check.sh b/test/mppa/check.sh new file mode 100755 index 00000000..8db50f1b --- /dev/null +++ b/test/mppa/check.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the execution of the binaries produced by CompCert + +source do_test.sh + +do_test check diff --git a/test/mppa/coverage.sh b/test/mppa/coverage.sh new file mode 100644 index 00000000..0a057ff9 --- /dev/null +++ b/test/mppa/coverage.sh @@ -0,0 +1,17 @@ +asmdir=$1 +to_cover_raw=/tmp/to_cover_raw +to_cover=/tmp/to_cover +covered_raw=/tmp/covered_raw +covered=/tmp/covered + +sed -n "s/^.*fprintf oc \" \(.*\) .*/\1/p" ../../mppa_k1c/TargetPrinter.ml > $to_cover_raw +sed -n "s/^.*fprintf oc \" \(.*\)\\n.*/\1/p" ../../mppa_k1c/TargetPrinter.ml >> $to_cover_raw +python2.7 coverage_helper.py $to_cover_raw > $to_cover + +rm -f $covered_raw +for asm in $(ls $asmdir/*.s); do + bash asm_coverage/asm-coverage.sh $asm >> $covered_raw +done +python2.7 coverage_helper.py $covered_raw > $covered + +vimdiff $to_cover $covered diff --git a/test/mppa/coverage_helper.py b/test/mppa/coverage_helper.py new file mode 100644 index 00000000..b086aca9 --- /dev/null +++ b/test/mppa/coverage_helper.py @@ -0,0 +1,35 @@ +import fileinput + +occurs = {} + +for line in fileinput.input(): + line_noc = line.replace('\n', '') + if line_noc not in occurs: + occurs[line_noc] = 0 + occurs[line_noc] += 1 + +# HACK: Removing all the instructions with "%a", replacing them with all their variations +# Also removing all instructions starting with '.' +pruned_occurs = dict(occurs) +for inst in occurs: + if inst[0] == '.': + del pruned_occurs[inst] + if "%a" not in inst: + continue + inst_no_a = inst.replace(".%a", "") + if inst_no_a in ("compw", "compd"): + del pruned_occurs[inst] + for mod in ("ne", "eq", "lt", "gt", "le", "ge", "ltu", "leu", "geu", + "gtu", "all", "any", "nall", "none"): + pruned_occurs[inst_no_a + "." + mod] = 1 + elif inst_no_a in ("cb"): + del pruned_occurs[inst] + for mod in ("wnez", "weqz", "wltz", "wgez", "wlez", "wgtz", "deqz", "dnez", + "dltz", "dgez", "dlez", "dgtz"): + pruned_occurs[inst_no_a + "." + mod] = 1 + else: + assert False, "Found instruction with %a: " + inst +occurs = pruned_occurs + +for inst in sorted(occurs): + print inst diff --git a/test/mppa/do_test.sh b/test/mppa/do_test.sh new file mode 100644 index 00000000..ee7cbcf7 --- /dev/null +++ b/test/mppa/do_test.sh @@ -0,0 +1,33 @@ +do_test () { +cat << EOF + +## +# PRNG tests +## +EOF +(cd prng && make $1 -j8) + +cat << EOF + +## +# Matrix Multiplication tests +## +EOF +(cd mmult && make $1 -j8) + +cat << EOF + +## +# List sort tests +## +EOF +(cd sort && make $1 -j8) + +cat << EOF + +## +# Instruction unit tests +## +EOF +(cd instr && make $1 -j8) +} diff --git a/test/mppa/general/clzd.c b/test/mppa/general/clzd.c new file mode 100644 index 00000000..4bedab97 --- /dev/null +++ b/test/mppa/general/clzd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_k1_clzd(t[0]); +} +END_TEST() diff --git a/test/mppa/general/clzw.c b/test/mppa/general/clzw.c new file mode 100644 index 00000000..361492f2 --- /dev/null +++ b/test/mppa/general/clzw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_k1_clzw(t[0]); +} +END_TEST() diff --git a/test/mppa/general/ctzd.c b/test/mppa/general/ctzd.c new file mode 100644 index 00000000..6f6586ad --- /dev/null +++ b/test/mppa/general/ctzd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_k1_ctzd(t[0]); +} +END_TEST() diff --git a/test/mppa/general/ctzw.c b/test/mppa/general/ctzw.c new file mode 100644 index 00000000..b0f2c937 --- /dev/null +++ b/test/mppa/general/ctzw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_k1_ctzw(t[0]); +} +END_TEST() diff --git a/test/mppa/general/satd.c b/test/mppa/general/satd.c new file mode 100644 index 00000000..d8d0d256 --- /dev/null +++ b/test/mppa/general/satd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_k1_satd(t[0], t[1]); +} +END_TEST() diff --git a/test/mppa/general/sbmm8.c b/test/mppa/general/sbmm8.c new file mode 100644 index 00000000..beced8fc --- /dev/null +++ b/test/mppa/general/sbmm8.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_k1_sbmm8(t[0], t[1]); +} +END_TEST() diff --git a/test/mppa/general/sbmmt8.c b/test/mppa/general/sbmmt8.c new file mode 100644 index 00000000..8a64e7e7 --- /dev/null +++ b/test/mppa/general/sbmmt8.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_k1_sbmmt8(t[0], t[1]); +} +END_TEST() diff --git a/test/mppa/instr/.gitignore b/test/mppa/instr/.gitignore new file mode 100644 index 00000000..ea1472ec --- /dev/null +++ b/test/mppa/instr/.gitignore @@ -0,0 +1 @@ +output/ diff --git a/test/mppa/instr/Makefile b/test/mppa/instr/Makefile new file mode 100644 index 00000000..89ff9a73 --- /dev/null +++ b/test/mppa/instr/Makefile @@ -0,0 +1,111 @@ +K1CC ?= k1-mbr-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-cluster +TIMEOUT ?= 10s + +DIR=./ +SRCDIR=$(DIR) +OUTDIR=$(DIR)/out +BINDIR=$(DIR)/bin +ASMDIR=$(DIR)/asm + +## +# Intended flow : .c -> .gcc.s -> .gcc.bin -> .gcc.out +# -> .ccomp.s -> .ccomp.bin -> .ccomp.out +## + +K1CCPATH=$(shell which $(K1CC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +TESTNAMES=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c))) +X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) +GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES))) +CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.out,$(TESTNAMES))) + +OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT) +BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES))) + +## +# Targets +## + +all: $(BIN) + +.PHONY: +test: $(X86_GCC_OUT) $(GCC_OUT) + @echo "Comparing x86 gcc output to k1 gcc.." + @for test in $(TESTNAMES); do\ + x86out=$(OUTDIR)/$$test.x86-gcc.out;\ + gccout=$(OUTDIR)/$$test.gcc.out;\ + if ! diff $$x86out $$gccout; then\ + >&2 echo "ERROR: $$x86out and $$gccout differ";\ + else\ + echo "GOOD: $$x86out and $$gccout concur";\ + fi;\ + done + +.PHONY: +check: $(GCC_OUT) $(CCOMP_OUT) + @echo "Comparing k1 gcc output to ccomp.." + @for test in $(TESTNAMES); do\ + gccout=$(OUTDIR)/$$test.gcc.out;\ + ccompout=$(OUTDIR)/$$test.ccomp.out;\ + if ! diff $$ccompout $$gccout; then\ + >&2 echo "ERROR: $$ccompout and $$gccout differ";\ + else\ + echo "GOOD: $$ccompout and $$gccout concur";\ + fi;\ + done + +## +# Rules +## + +.SECONDARY: +# Generating output + +$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +# Assembly to binary + +$(BINDIR)/%.x86-gcc.bin: $(ASMDIR)/%.x86-gcc.s $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $< -o $@ + +$(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1CCPATH) + @mkdir -p $(@D) + $(K1CC) $(CFLAGS) $< -o $@ + +$(BINDIR)/%.ccomp.bin: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $< -o $@ + +# Source to assembly + +$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(K1CCPATH) + @mkdir -p $(@D) + $(K1CC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) -S $< -o $@ diff --git a/test/mppa/instr/addw.c b/test/mppa/instr/addw.c new file mode 100644 index 00000000..be8afc67 --- /dev/null +++ b/test/mppa/instr/addw.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(int) + c = a+b; +END_TEST() diff --git a/test/mppa/instr/andd.c b/test/mppa/instr/andd.c new file mode 100644 index 00000000..4f503764 --- /dev/null +++ b/test/mppa/instr/andd.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(long long) + return a&b; +END_TEST() diff --git a/test/mppa/instr/andw.c b/test/mppa/instr/andw.c new file mode 100644 index 00000000..99de0049 --- /dev/null +++ b/test/mppa/instr/andw.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(int) + c = a&b; +END_TEST() diff --git a/test/mppa/instr/branch.c b/test/mppa/instr/branch.c new file mode 100644 index 00000000..72e7e20e --- /dev/null +++ b/test/mppa/instr/branch.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if ((a & 0x1) == 1) + c = 0; + else + c = 1; +} +END_TEST() diff --git a/test/mppa/instr/branchz.c b/test/mppa/instr/branchz.c new file mode 100644 index 00000000..fb86d357 --- /dev/null +++ b/test/mppa/instr/branchz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if (a & 0x1 == 0) + c = 0; + else + c = 1; +} +END_TEST() diff --git a/test/mppa/instr/branchzu.c b/test/mppa/instr/branchzu.c new file mode 100644 index 00000000..97adb605 --- /dev/null +++ b/test/mppa/instr/branchzu.c @@ -0,0 +1,11 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + b = !(a & 0x01); + if (!b) + c = 0; + else + c = 1; +} +END_TEST() diff --git a/test/mppa/instr/call.c b/test/mppa/instr/call.c new file mode 100644 index 00000000..727cef63 --- /dev/null +++ b/test/mppa/instr/call.c @@ -0,0 +1,16 @@ +#include "framework.h" + +int sum(int a, int b){ + return a+b; +} + +int make(int a){ + return a; +} + +BEGIN_TEST(int) +{ + c = sum(make(a), make(b)); +} +END_TEST() +/* RETURN VALUE: 60 */ diff --git a/test/mppa/instr/cb.deqz.c b/test/mppa/instr/cb.deqz.c new file mode 100644 index 00000000..c56733f0 --- /dev/null +++ b/test/mppa/instr/cb.deqz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 != (a & 0x1LL)) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.dgez.c b/test/mppa/instr/cb.dgez.c new file mode 100644 index 00000000..abb6ec57 --- /dev/null +++ b/test/mppa/instr/cb.dgez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 > (a & 0x1LL)) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.dgtz.c b/test/mppa/instr/cb.dgtz.c new file mode 100644 index 00000000..d4271845 --- /dev/null +++ b/test/mppa/instr/cb.dgtz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 >= (a & 0x1LL) - 1) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.dlez.c b/test/mppa/instr/cb.dlez.c new file mode 100644 index 00000000..18e67f06 --- /dev/null +++ b/test/mppa/instr/cb.dlez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (a & 0x1LL > 0) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.dltz.c b/test/mppa/instr/cb.dltz.c new file mode 100644 index 00000000..366aea49 --- /dev/null +++ b/test/mppa/instr/cb.dltz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if ((a & 0x1LL) - 1 >= 0) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.dnez.c b/test/mppa/instr/cb.dnez.c new file mode 100644 index 00000000..81c2cd29 --- /dev/null +++ b/test/mppa/instr/cb.dnez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 == (a & 0x1LL)) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.wgez.c b/test/mppa/instr/cb.wgez.c new file mode 100644 index 00000000..477f4bc6 --- /dev/null +++ b/test/mppa/instr/cb.wgez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if (0 > (a & 0x1) - 1) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.wgtz.c b/test/mppa/instr/cb.wgtz.c new file mode 100644 index 00000000..c9ab9a06 --- /dev/null +++ b/test/mppa/instr/cb.wgtz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if (0 >= (a & 0x1)) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.wlez.c b/test/mppa/instr/cb.wlez.c new file mode 100644 index 00000000..c3069fda --- /dev/null +++ b/test/mppa/instr/cb.wlez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if ((a & 0x1) > 0) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/cb.wltz.c b/test/mppa/instr/cb.wltz.c new file mode 100644 index 00000000..6cf5fcf0 --- /dev/null +++ b/test/mppa/instr/cb.wltz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if ((a & 0x1) - 1 >= 0) + c = 1; + else + c = 0; +} +END_TEST() diff --git a/test/mppa/instr/compd.eq.c b/test/mppa/instr/compd.eq.c new file mode 100644 index 00000000..d19a4d20 --- /dev/null +++ b/test/mppa/instr/compd.eq.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = ((a & 0x1LL) == (b & 0x1LL)); +} +END_TEST() diff --git a/test/mppa/instr/compd.geu.c b/test/mppa/instr/compd.geu.c new file mode 100644 index 00000000..edc31183 --- /dev/null +++ b/test/mppa/instr/compd.geu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a >= b); +} +END_TEST() diff --git a/test/mppa/instr/compd.gt.c b/test/mppa/instr/compd.gt.c new file mode 100644 index 00000000..24147779 --- /dev/null +++ b/test/mppa/instr/compd.gt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (a > b); +} +END_TEST() diff --git a/test/mppa/instr/compd.gtu.c b/test/mppa/instr/compd.gtu.c new file mode 100644 index 00000000..5ce82569 --- /dev/null +++ b/test/mppa/instr/compd.gtu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a > b); +} +END_TEST() diff --git a/test/mppa/instr/compd.le.c b/test/mppa/instr/compd.le.c new file mode 100644 index 00000000..a84aad97 --- /dev/null +++ b/test/mppa/instr/compd.le.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (a <= b); +} +END_TEST() diff --git a/test/mppa/instr/compd.leu.c b/test/mppa/instr/compd.leu.c new file mode 100644 index 00000000..e386bc27 --- /dev/null +++ b/test/mppa/instr/compd.leu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a <= b); +} +END_TEST() diff --git a/test/mppa/instr/compd.lt.c b/test/mppa/instr/compd.lt.c new file mode 100644 index 00000000..df07a708 --- /dev/null +++ b/test/mppa/instr/compd.lt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (a < b); +} +END_TEST() diff --git a/test/mppa/instr/compd.ltu.c b/test/mppa/instr/compd.ltu.c new file mode 100644 index 00000000..dfaa8921 --- /dev/null +++ b/test/mppa/instr/compd.ltu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a < b); +} +END_TEST() diff --git a/test/mppa/instr/compd.ne.c b/test/mppa/instr/compd.ne.c new file mode 100644 index 00000000..19ce0a69 --- /dev/null +++ b/test/mppa/instr/compd.ne.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = ((a & 0x1ULL) != (b & 0x1ULL)); +} +END_TEST() diff --git a/test/mppa/instr/compw.eq.c b/test/mppa/instr/compw.eq.c new file mode 100644 index 00000000..dc7a3ab1 --- /dev/null +++ b/test/mppa/instr/compw.eq.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = ((a & 0x1) == (b & 0x1)); +} +END_TEST() diff --git a/test/mppa/instr/compw.geu.c b/test/mppa/instr/compw.geu.c new file mode 100644 index 00000000..d72ca56c --- /dev/null +++ b/test/mppa/instr/compw.geu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a >= b); +} +END_TEST() diff --git a/test/mppa/instr/compw.gt.c b/test/mppa/instr/compw.gt.c new file mode 100644 index 00000000..9ad02610 --- /dev/null +++ b/test/mppa/instr/compw.gt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a > b); +} +END_TEST() diff --git a/test/mppa/instr/compw.gtu.c b/test/mppa/instr/compw.gtu.c new file mode 100644 index 00000000..77f04989 --- /dev/null +++ b/test/mppa/instr/compw.gtu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a > b); +} +END_TEST() diff --git a/test/mppa/instr/compw.le.c b/test/mppa/instr/compw.le.c new file mode 100644 index 00000000..b7a7a432 --- /dev/null +++ b/test/mppa/instr/compw.le.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a <= b); +} +END_TEST() diff --git a/test/mppa/instr/compw.leu.c b/test/mppa/instr/compw.leu.c new file mode 100644 index 00000000..4892f06c --- /dev/null +++ b/test/mppa/instr/compw.leu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a <= b); +} +END_TEST() diff --git a/test/mppa/instr/compw.lt.c b/test/mppa/instr/compw.lt.c new file mode 100644 index 00000000..2cc151bf --- /dev/null +++ b/test/mppa/instr/compw.lt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a < b); +} +END_TEST() diff --git a/test/mppa/instr/compw.ltu.c b/test/mppa/instr/compw.ltu.c new file mode 100644 index 00000000..b524127f --- /dev/null +++ b/test/mppa/instr/compw.ltu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a < b); +} +END_TEST() diff --git a/test/mppa/instr/compw.ne.c b/test/mppa/instr/compw.ne.c new file mode 100644 index 00000000..433b0b86 --- /dev/null +++ b/test/mppa/instr/compw.ne.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = ((a & 0x1U) != (b & 0x1U)); +} +END_TEST() diff --git a/test/mppa/instr/div2.c b/test/mppa/instr/div2.c new file mode 100644 index 00000000..01a4b575 --- /dev/null +++ b/test/mppa/instr/div2.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a + b) / 2; +} +END_TEST() diff --git a/test/mppa/instr/for.c b/test/mppa/instr/for.c new file mode 100644 index 00000000..d6870afb --- /dev/null +++ b/test/mppa/instr/for.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + int j; + for (j = 0 ; j < 10 ; j++) + c += a; +} +END_TEST() diff --git a/test/mppa/instr/forvar.c b/test/mppa/instr/forvar.c new file mode 100644 index 00000000..57548274 --- /dev/null +++ b/test/mppa/instr/forvar.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + int j; + for (j = 0 ; j < (b & 0x8) ; j++) + c += a; +} +END_TEST() diff --git a/test/mppa/instr/forvarl.c b/test/mppa/instr/forvarl.c new file mode 100644 index 00000000..30717a51 --- /dev/null +++ b/test/mppa/instr/forvarl.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long int) +{ + int j; + + for (j = 0 ; j < (b & 0x8LL) ; j++) + c += a; +} +END_TEST() diff --git a/test/mppa/instr/framework.h b/test/mppa/instr/framework.h new file mode 100644 index 00000000..52ba97bc --- /dev/null +++ b/test/mppa/instr/framework.h @@ -0,0 +1,37 @@ +#ifndef __FRAMEWORK_H__ +#define __FRAMEWORK_H__ + +#include "../prng/prng.c" + +#define BEGIN_TEST_N(type, N)\ + int main(void){\ + type t[N], c, i, j, S;\ + srand(0);\ + S = 0;\ + for (i = 0 ; i < 100 ; i++){\ + c = randlong();\ + for (j = 0 ; j < N ; j++)\ + t[j] = randlong();\ + /* END BEGIN_TEST_N */ + +#define BEGIN_TEST(type)\ + int main(void){\ + type a, b, c, i, S;\ + srand(0);\ + S = 0;\ + for (i = 0 ; i < 100 ; i++){\ + c = randlong();\ + a = randlong();\ + b = randlong(); + /* END BEGIN_TEST */ + +/* In between BEGIN_TEST and END_TEST : definition of c */ + +#define END_TEST()\ + S += c;\ + }\ + return S;\ + } + /* END END_TEST */ + +#endif diff --git a/test/mppa/instr/lbs.c b/test/mppa/instr/lbs.c new file mode 100644 index 00000000..f104d62b --- /dev/null +++ b/test/mppa/instr/lbs.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + char s[] = "Tome and Cherry at the playa\n"; + + c = s[(a & (sizeof(s)-1))]; +} +END_TEST() diff --git a/test/mppa/instr/lbz.c b/test/mppa/instr/lbz.c new file mode 100644 index 00000000..2deeaebe --- /dev/null +++ b/test/mppa/instr/lbz.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + unsigned char s[] = "Tim is sorry at the playa\n"; + + c = s[a & (sizeof(s) - 1)]; +} +END_TEST() diff --git a/test/mppa/instr/muld.c b/test/mppa/instr/muld.c new file mode 100644 index 00000000..9a40f389 --- /dev/null +++ b/test/mppa/instr/muld.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a*b; +} +END_TEST() diff --git a/test/mppa/instr/mulw.c b/test/mppa/instr/mulw.c new file mode 100644 index 00000000..bf517ce8 --- /dev/null +++ b/test/mppa/instr/mulw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a * b; +} +END_TEST() diff --git a/test/mppa/instr/negd.c b/test/mppa/instr/negd.c new file mode 100644 index 00000000..a8e8ff45 --- /dev/null +++ b/test/mppa/instr/negd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = -a; +} +END_TEST() diff --git a/test/mppa/instr/ord.c b/test/mppa/instr/ord.c new file mode 100644 index 00000000..eaedcb28 --- /dev/null +++ b/test/mppa/instr/ord.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a | b; +} +END_TEST() diff --git a/test/mppa/instr/sbfd.c b/test/mppa/instr/sbfd.c new file mode 100644 index 00000000..912f1fdb --- /dev/null +++ b/test/mppa/instr/sbfd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a-b; +} +END_TEST() diff --git a/test/mppa/instr/sbfw.c b/test/mppa/instr/sbfw.c new file mode 100644 index 00000000..feffd497 --- /dev/null +++ b/test/mppa/instr/sbfw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a-b; +} +END_TEST() diff --git a/test/mppa/instr/simple.c b/test/mppa/instr/simple.c new file mode 100644 index 00000000..89bba27e --- /dev/null +++ b/test/mppa/instr/simple.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a+b; +} +END_TEST() diff --git a/test/mppa/instr/sllw.c b/test/mppa/instr/sllw.c new file mode 100644 index 00000000..df55c9e8 --- /dev/null +++ b/test/mppa/instr/sllw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a << (b & 0x8); +} +END_TEST() diff --git a/test/mppa/instr/srad.c b/test/mppa/instr/srad.c new file mode 100644 index 00000000..b4047bc7 --- /dev/null +++ b/test/mppa/instr/srad.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a >> (b & 0x8LL); +} +END_TEST() diff --git a/test/mppa/instr/srld.c b/test/mppa/instr/srld.c new file mode 100644 index 00000000..71e82b2a --- /dev/null +++ b/test/mppa/instr/srld.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = a >> (b & 0x8ULL); +} +END_TEST() diff --git a/test/mppa/instr/udivd.c b/test/mppa/instr/udivd.c new file mode 100644 index 00000000..52e0d412 --- /dev/null +++ b/test/mppa/instr/udivd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = a/b; +} +END_TEST() diff --git a/test/mppa/instr/umodd.c b/test/mppa/instr/umodd.c new file mode 100644 index 00000000..e7dd506f --- /dev/null +++ b/test/mppa/instr/umodd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = a%b; +} +END_TEST() diff --git a/test/mppa/instr/xord.c b/test/mppa/instr/xord.c new file mode 100644 index 00000000..b9d86f06 --- /dev/null +++ b/test/mppa/instr/xord.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a^b; +} +END_TEST() diff --git a/test/mppa/mmult/.gitignore b/test/mppa/mmult/.gitignore new file mode 100644 index 00000000..c9cd4c65 --- /dev/null +++ b/test/mppa/mmult/.gitignore @@ -0,0 +1,4 @@ +mmult-test-ccomp-k1c +mmult-test-gcc-k1c +mmult-test-gcc-x86 +.zero diff --git a/test/mppa/mmult/Makefile b/test/mppa/mmult/Makefile new file mode 100644 index 00000000..cf82e359 --- /dev/null +++ b/test/mppa/mmult/Makefile @@ -0,0 +1,67 @@ +K1CC ?= k1-mbr-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-cluster +TIMEOUT ?= 10s + +K1CCPATH=$(shell which $(K1CC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +PRNG=../prng/prng.c + +ALL= mmult-test-gcc-x86 mmult-test-gcc-k1c mmult-test-ccomp-k1c +CCOMP_OUT= mmult-test-ccomp-k1c.out +GCC_OUT= mmult-test-gcc-k1c.out +X86_GCC_OUT= mmult-test-gcc-x86.out +STUB_OUT=.zero + +all: $(ALL) + +mmult-test-gcc-x86: mmult.c $(PRNG) $(CCPATH) + $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +mmult-test-gcc-k1c: mmult.c $(PRNG) $(K1CCPATH) + $(K1CC) $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@ + +mmult-test-ccomp-k1c: mmult.c $(PRNG) $(CCOMPPATH) + $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +.SECONDARY: +%k1c.out: %k1c $(SIMUPATH) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +%x86.out: %x86 + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +.zero: + @echo "0" > $@ + +.PHONY: +test: test-x86 test-k1c + +.PHONY: +test-x86: $(X86_GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR x86: $< failed";\ + else\ + echo "GOOD x86: $< succeeded";\ + fi + +.PHONY: +test-k1c: $(GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR k1c: $< failed";\ + else\ + echo "GOOD k1c: $< succeeded";\ + fi + +.PHONY: +check: $(CCOMP_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR k1c: $< failed";\ + else\ + echo "GOOD k1c: $< succeeded";\ + fi diff --git a/test/mppa/mmult/README.md b/test/mppa/mmult/README.md new file mode 100644 index 00000000..ef2bff7e --- /dev/null +++ b/test/mppa/mmult/README.md @@ -0,0 +1,17 @@ +MMULT +===== + +Examples of matrix multiplication using different methods. + +We compute matrix multiplication using column-based matrix multiplication, then row-based, and finally block based. + +The test verifies that the result is the same on the three methods. If it is the same, 0 will be returned. + +The following commands can be run inside the folder: + +- `make`: produces the unitary test binaries + - `mmult-test-gcc-x86` : binary from gcc on x86 + - `mmult-test-k1c-x86` : binary from gcc on k1c + - `mmult-test-ccomp-x86` : binary from ccomp on k1c +- `make test`: tests the return value of the binaries produced by gcc. +- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/mmult/mmult.c b/test/mppa/mmult/mmult.c new file mode 100644 index 00000000..aeb91d48 --- /dev/null +++ b/test/mppa/mmult/mmult.c @@ -0,0 +1,146 @@ +#include "../prng/types.h" +#include "../prng/prng.h" + +#define __UNIT_TEST_MMULT__ + +#ifdef __UNIT_TEST_MMULT__ +#define SIZE 10 +#else +#include "test.h" +#endif + +void mmult_row(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ + int i, j, k; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + C[i][j] = 0; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + for (k = 0 ; k < SIZE ; k++) + C[i][j] += A[i][k] * B[k][j]; +} + +void mmult_col(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ + int i, j, k; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + C[i][j] = 0; + + for (k = 0 ; k < SIZE ; k++) + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + C[i][j] += A[i][k] * B[k][j]; +} + +typedef struct mblock { + int imin, imax, jmin, jmax; + uint64_t *mat; +} mblock; + +#define MAT_XY(mat, x, y) (mat)[(x)*SIZE + (y)] +#define MAT_IJ(block, i, j) MAT_XY((block)->mat, (block)->imin + (i), block->jmin + (j)) + +void divac_mul(mblock *C, const mblock *A, const mblock *B){ + const int size = C->imax - C->imin; + int i, j, k; + + for (i = 0 ; i < size ; i++) + for (j = 0 ; j < size ; j++) + for (k = 0 ; k < size ; k++) + MAT_IJ(C, i, j) += MAT_IJ(A, i, k) * MAT_IJ(B, k, j); +} + +#define BLOCK_X_MID(block) ((block)->imin + (block)->imax) / 2 +#define BLOCK_Y_MID(block) ((block)->jmin + (block)->jmax) / 2 + +#define MAKE_MBLOCK(newb, block, I, J) \ + mblock newb = {.mat=(block)->mat};\ + if ((I) == 0){\ + newb.imin = (block)->imin;\ + newb.imax = BLOCK_X_MID((block));\ + } else {\ + newb.imin = BLOCK_X_MID((block));\ + newb.imax = (block)->imax;\ + } if ((J) == 0){\ + newb.jmin = (block)->jmin;\ + newb.jmax = BLOCK_Y_MID((block));\ + } else {\ + newb.jmin = BLOCK_Y_MID((block));\ + newb.jmax = (block)->jmax;\ + } + +void divac_part(mblock *C, const mblock *A, const mblock *B); + +void divac_wrap(mblock *C , char IC, char JC, + const mblock *A, char IA, char JA, + const mblock *B, char IB, char JB){ + MAKE_MBLOCK(Cb, C, IC, JC); + MAKE_MBLOCK(Ab, A, IA, JA); + MAKE_MBLOCK(Bb, B, IB, JB); + + divac_part(&Cb, &Ab, &Bb); +} + + +void divac_part(mblock *C, const mblock *A, const mblock *B){ + const int size = C->imax - C->imin; + + if (size % 2 == 1) + divac_mul(C, A, B); + else{ + /* C_00 = A_00 B_00 + A_01 B_10 */ + divac_wrap(C, 0, 0, A, 0, 0, B, 0, 0); + divac_wrap(C, 0, 0, A, 0, 1, B, 1, 0); + + /* C_10 = A_10 B_00 + A_11 B_10 */ + divac_wrap(C, 1, 0, A, 1, 0, B, 0, 0); + divac_wrap(C, 1, 0, A, 1, 1, B, 1, 0); + + /* C_01 = A_00 B_01 + A_01 B_11 */ + divac_wrap(C, 0, 1, A, 0, 0, B, 0, 1); + divac_wrap(C, 0, 1, A, 0, 1, B, 1, 1); + + /* C_11 = A_10 B_01 + A_11 B_11 */ + divac_wrap(C, 1, 1, A, 1, 0, B, 0, 1); + divac_wrap(C, 1, 1, A, 1, 1, B, 1, 1); + } + +} + +void mmult_divac(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ + mblock Cb = {.mat = (uint64_t *) C, .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; + mblock Ab = {.mat = (uint64_t *) A , .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; + mblock Bb = {.mat = (uint64_t *) B , .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; + + divac_part(&Cb, &Ab, &Bb); +} + +#ifdef __UNIT_TEST_MMULT__ +static uint64_t C1[SIZE][SIZE], C2[SIZE][SIZE], C3[SIZE][SIZE]; +static uint64_t A[SIZE][SIZE], B[SIZE][SIZE]; + +int main(void){ + srand(42); + int i, j; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++){ + A[i][j] = randlong(); + B[i][j] = randlong(); + } + + mmult_row(C1, A, B); + mmult_col(C2, A, B); + mmult_divac(C3, A, B); + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + if (!(C1[i][j] == C2[i][j] && C1[i][j] == C3[i][j])) + return -1; + + return 0; +} +#endif /* __UNIT_TEST_MMULT__ */ diff --git a/test/mppa/mmult/mmult.h b/test/mppa/mmult/mmult.h new file mode 100644 index 00000000..3721784a --- /dev/null +++ b/test/mppa/mmult/mmult.h @@ -0,0 +1,10 @@ +#ifndef __MMULT_H__ +#define __MMULT_H__ + +#include "../lib/types.h" + +void mmult_row(uint64_t *A, const uint64_t *B, const uint64_t *C); +void mmult_column(uint64_t *A, const uint64_t *B, const uint64_t *C); +void mmult_strassen(uint64_t *A, const uint64_t *B, const uint64_t *C); + +#endif /* __MMULT_H__ */ diff --git a/test/mppa/prng/.gitignore b/test/mppa/prng/.gitignore new file mode 100644 index 00000000..0792a78b --- /dev/null +++ b/test/mppa/prng/.gitignore @@ -0,0 +1,3 @@ +prng-test-ccomp-k1c +prng-test-gcc-x86 +prng-test-gcc-k1c diff --git a/test/mppa/prng/Makefile b/test/mppa/prng/Makefile new file mode 100644 index 00000000..5580cd8e --- /dev/null +++ b/test/mppa/prng/Makefile @@ -0,0 +1,69 @@ +K1CC ?= k1-mbr-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-cluster +TIMEOUT ?= 10s + +K1CCPATH=$(shell which $(K1CC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +ALL= prng-test-gcc-x86 prng-test-gcc-k1c prng-test-ccomp-k1c +CCOMP_OUT= prng-test-ccomp-k1c.out +GCC_OUT= prng-test-gcc-k1c.out +X86_GCC_OUT= prng-test-gcc-x86.out +STUB_OUT=.zero + +all: $(ALL) + +prng-test-gcc-x86: prng.c $(CCPATH) + $(CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ + +prng-test-gcc-k1c: prng.c $(K1CCPATH) + $(K1CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ + +prng-test-ccomp-k1c: prng.c $(CCOMPPATH) + $(CCOMP) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ + +.SECONDARY: +%k1c.out: %k1c $(SIMUPATH) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +%x86.out: %x86 + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +.zero: + @echo "0" > $@ + +.PHONY: +test: test-x86 test-k1c + +.PHONY: +test-x86: $(X86_GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR x86: $< failed";\ + else\ + echo "GOOD x86: $< succeeded";\ + fi + +.PHONY: +test-k1c: $(GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR k1c: $< failed";\ + else\ + echo "GOOD k1c: $< succeeded";\ + fi + +.PHONY: +check: $(CCOMP_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR k1c: $< failed";\ + else\ + echo "GOOD k1c: $< succeeded";\ + fi + +.PHONY: +clean: + rm -f prng-test-gcc-x86 prng-test-gcc-k1c prng-test-ccomp-k1c diff --git a/test/mppa/prng/README.md b/test/mppa/prng/README.md new file mode 100644 index 00000000..b4c2279b --- /dev/null +++ b/test/mppa/prng/README.md @@ -0,0 +1,17 @@ +PRNG +==== + +This is a simple Pseudo Random Number Generator. + +`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum" +of 1000 generated numbers to a hardcoded result, that is the one obtained with +`gcc -O2` on a x86 processor, and returns 0 if the result is correct. + +The following commands can be run inside that folder: + +- `make`: produces the unitary test binaries + - `prng-test-gcc-x86` : binary from gcc on x86 + - `prng-test-k1c-x86` : binary from gcc on k1c + - `prng-test-ccomp-x86` : binary from ccomp on k1c +- `make test`: tests the return value of the binaries produced by gcc. +- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/prng/prng.c b/test/mppa/prng/prng.c new file mode 100644 index 00000000..71de1dc3 --- /dev/null +++ b/test/mppa/prng/prng.c @@ -0,0 +1,41 @@ +// https://en.wikipedia.org/wiki/Linear_congruential_generator -> MMIX Donald Knuth +// modulo 2^64 = no need to do it explicitly + +#include "types.h" + +#define MULTIPLIER 6364136223846793005LL +#define INCREMENT 1442695040888963407LL + +static uint64_t current; + +void srand(uint64_t seed){ + current = seed; +} + +uint64_t randlong(void){ + return (current = MULTIPLIER * current + INCREMENT); +} + +#ifdef __UNIT_TEST_PRNG__ +char bytewise_sum(uint64_t to_check){ + char sum = 0; + int i; + + for (i = 0 ; i < 8 ; i++) + sum += (to_check & (uint64_t)(0xFFULL << i*8)) >> i*8; + + return sum; +} + +int main(void){ + srand(42); + int i; + + for (i = 0 ; i < 1000 ; i++) + randlong(); + + uint64_t last = randlong(); + + return !((unsigned char)bytewise_sum(last) == 155); +} +#endif // __UNIT_TEST_PRNG__ diff --git a/test/mppa/prng/prng.h b/test/mppa/prng/prng.h new file mode 100644 index 00000000..6abdb45a --- /dev/null +++ b/test/mppa/prng/prng.h @@ -0,0 +1,10 @@ +#ifndef __PRNG_H__ +#define __PRNG_H__ + +#include "types.h" + +void srand(uint64_t seed); + +uint64_t randlong(void); + +#endif // __PRNG_H__ diff --git a/test/mppa/prng/types.h b/test/mppa/prng/types.h new file mode 100644 index 00000000..584023e3 --- /dev/null +++ b/test/mppa/prng/types.h @@ -0,0 +1,7 @@ +#ifndef __TYPES_H__ +#define __TYPES_H__ + +#define uint64_t unsigned long long +#define int64_t signed long long + +#endif // __TYPES_H__ diff --git a/test/mppa/sort/.gitignore b/test/mppa/sort/.gitignore new file mode 100644 index 00000000..a8d6921c --- /dev/null +++ b/test/mppa/sort/.gitignore @@ -0,0 +1,9 @@ +main-test-ccomp-k1c +main-test-gcc-k1c +main-test-gcc-x86 +merge-test-gcc-k1c +merge-test-gcc-x86 +selection-test-gcc-k1c +selection-test-gcc-x86 +insertion-test-gcc-k1c +insertion-test-gcc-x86 diff --git a/test/mppa/sort/Makefile b/test/mppa/sort/Makefile new file mode 100644 index 00000000..ebbad5b5 --- /dev/null +++ b/test/mppa/sort/Makefile @@ -0,0 +1,91 @@ +K1CC ?= k1-mbr-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-cluster +TIMEOUT ?= 10s + +K1CCPATH=$(shell which $(K1CC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +PRNG=../prng/prng.c + +CFILES=insertion.c merge.c selection.c main.c + +ALL= insertion-gcc-x86 insertion-gcc-k1c insertion-ccomp-k1c\ + selection-gcc-x86 selection-gcc-k1c selection-ccomp-k1c\ + merge-gcc-x86 merge-gcc-k1c merge-ccomp-k1c\ + main-gcc-x86 main-gcc-k1c main-ccomp-k1c + +CCOMP_OUT= insertion-ccomp-k1c.out selection-ccomp-k1c.out merge-ccomp-k1c.out\ + main-ccomp-k1c.out +GCC_OUT= insertion-gcc-k1c.out selection-gcc-k1c.out merge-gcc-k1c.out\ + main-gcc-k1c.out +X86_GCC_OUT= insertion-gcc-x86.out selection-gcc-x86.out merge-gcc-x86.out\ + main-gcc-x86.out +STUB_OUT= .zero + +all: $(ALL) + +main-gcc-x86: $(CFILES) $(PRNG) $(CCPATH) + $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +%-gcc-x86: %.c $(PRNG) $(CCPATH) + $(CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +main-gcc-k1c: $(CFILES) $(PRNG) $(CCPATH) + $(K1CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +%-gcc-k1c: %.c $(PRNG) $(K1CCPATH) + $(K1CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@ + +main-ccomp-k1c: $(CFILES) $(PRNG) $(CCOMPPATH) + $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +%-ccomp-k1c: %.c $(PRNG) $(CCOMPPATH) + $(CCOMP) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +.SECONDARY: +%x86.out: %x86 + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +%k1c.out: %k1c $(SIMUPATH) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +.zero: + @echo "0" > $@ + +.PHONY: +test-x86: $(STUB_OUT) $(X86_GCC_OUT) + @for test in $(wordlist 2,100,$^); do\ + if ! diff $$test $(STUB_OUT); then\ + >&2 echo "ERROR x86: $$test failed";\ + else\ + echo "GOOD x86: $$test succeeded";\ + fi;\ + done + +.PHONY: +test-k1c: $(STUB_OUT) $(GCC_OUT) + @for test in $(wordlist 2,100,$^); do\ + if ! diff $$test $(STUB_OUT); then\ + >&2 echo "ERROR k1c: $$test failed";\ + else\ + echo "GOOD k1c: $$test succeeded";\ + fi;\ + done + +.PHONY: +test: test-x86 test-k1c + +.PHONY: +check: $(STUB_OUT) $(CCOMP_OUT) + @for test in $(wordlist 2,100,$^); do\ + if ! diff $$test $(STUB_OUT); then\ + >&2 echo "ERROR k1c: $$test failed";\ + else\ + echo "GOOD k1c: $$test succeeded";\ + fi;\ + done diff --git a/test/mppa/sort/README.md b/test/mppa/sort/README.md new file mode 100644 index 00000000..b4c2279b --- /dev/null +++ b/test/mppa/sort/README.md @@ -0,0 +1,17 @@ +PRNG +==== + +This is a simple Pseudo Random Number Generator. + +`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum" +of 1000 generated numbers to a hardcoded result, that is the one obtained with +`gcc -O2` on a x86 processor, and returns 0 if the result is correct. + +The following commands can be run inside that folder: + +- `make`: produces the unitary test binaries + - `prng-test-gcc-x86` : binary from gcc on x86 + - `prng-test-k1c-x86` : binary from gcc on k1c + - `prng-test-ccomp-x86` : binary from ccomp on k1c +- `make test`: tests the return value of the binaries produced by gcc. +- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/sort/insertion.c b/test/mppa/sort/insertion.c new file mode 100644 index 00000000..bca09599 --- /dev/null +++ b/test/mppa/sort/insertion.c @@ -0,0 +1,59 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +#ifdef __UNIT_TEST_INSERTION__ +#define SIZE 100 +#else +#include "test.h" +#endif + +void swap_ins(uint64_t *a, uint64_t *b){ + uint64_t tmp = *a; + *a = *b; + *b = tmp; +} + +int insert_sort(uint64_t *res, const uint64_t *T){ + int i, j; + + if (SIZE <= 0) + return -1; + + for (i = 0 ; i < SIZE ; i++) + res[i] = T[i]; + + for (i = 0 ; i < SIZE-1 ; i++){ + if (res[i] > res[i+1]){ + swap_ins(&res[i], &res[i+1]); + for (j = i ; j > 0 ; j--) + if (res[j-1] > res[j]) + swap_ins(&res[j-1], &res[j]); + } + } + + return 0; +} + +#ifdef __UNIT_TEST_INSERTION__ +int main(void){ + uint64_t T[SIZE]; + uint64_t res[SIZE]; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* Sorting the table */ + if (insert_sort(res, T) < 0) return -1; + + /* Computing max(T) */ + uint64_t max = T[0]; + for (i = 1 ; i < SIZE ; i++) + if (T[i] > max) + max = T[i]; + + /* We should have: max(T) == res[SIZE] */ + return !(max == res[SIZE-1]); +} +#endif // __UNIT_TEST_INSERTION__ diff --git a/test/mppa/sort/insertion.h b/test/mppa/sort/insertion.h new file mode 100644 index 00000000..6e37c5fe --- /dev/null +++ b/test/mppa/sort/insertion.h @@ -0,0 +1,6 @@ +#ifndef __INSERTION_H__ +#define __INSERTION_H__ + +int insert_sort(uint64_t *res, const uint64_t *T); + +#endif // __INSERTION_H__ diff --git a/test/mppa/sort/main.c b/test/mppa/sort/main.c new file mode 100644 index 00000000..aef419aa --- /dev/null +++ b/test/mppa/sort/main.c @@ -0,0 +1,34 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +#include "test.h" +#include "insertion.h" +#include "selection.h" +#include "merge.h" + +int main(void){ + uint64_t T[SIZE]; + uint64_t res1[SIZE], res2[SIZE], res3[SIZE]; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* insertion sort */ + if (insert_sort(res1, T) < 0) return -1; + + /* selection sort */ + if (select_sort(res2, T) < 0) return -2; + + /* merge sort */ + if (merge_sort(res3, T) < 0) return -3; + + /* We should have: res1[i] == res2[i] == res3[i] */ + for (i = 0 ; i < SIZE ; i++){ + if (!(res1[i] == res2[i] && res2[i] == res3[i])) + return -4; + } + + return 0; +} diff --git a/test/mppa/sort/merge.c b/test/mppa/sort/merge.c new file mode 100644 index 00000000..99f8ba85 --- /dev/null +++ b/test/mppa/sort/merge.c @@ -0,0 +1,92 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +//https://en.wikipedia.org/wiki/Merge_sort + +#ifdef __UNIT_TEST_MERGE__ +#define SIZE 100 +#else +#include "test.h" +#endif + +int min(int a, int b){ + return (a < b)?a:b; +} + +void BottomUpMerge(const uint64_t *A, int iLeft, int iRight, int iEnd, uint64_t *B) +{ + int i = iLeft, j = iRight, k; + for (k = iLeft; k < iEnd; k++) { + if (i < iRight && (j >= iEnd || A[i] <= A[j])) { + B[k] = A[i]; + i = i + 1; + } else { + B[k] = A[j]; + j = j + 1; + } + } +} + +void CopyArray(uint64_t *to, const uint64_t *from) +{ + const int n = SIZE; + int i; + + for(i = 0; i < n; i++) + to[i] = from[i]; +} + +void BottomUpMergeSort(uint64_t *A, uint64_t *B) +{ + const int n = SIZE; + int width, i; + + for (width = 1; width < n; width = 2 * width) + { + for (i = 0; i < n; i = i + 2 * width) + { + BottomUpMerge(A, i, min(i+width, n), min(i+2*width, n), B); + } + CopyArray(A, B); + } +} + +int merge_sort(uint64_t *res, const uint64_t *T){ + int i; + + if (SIZE <= 0) + return -1; + + uint64_t B[SIZE]; + uint64_t *A = res; + for (i = 0 ; i < SIZE ; i++) + A[i] = T[i]; + + BottomUpMergeSort(A, B); + + return 0; +} + +#ifdef __UNIT_TEST_MERGE__ +int main(void){ + uint64_t T[SIZE]; + uint64_t res[SIZE]; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* Sorting the table */ + if (merge_sort(res, T) < 0) return -1; + + /* Computing max(T) */ + uint64_t max = T[0]; + for (i = 1 ; i < SIZE ; i++) + if (T[i] > max) + max = T[i]; + + /* We should have: max(T) == res[SIZE] */ + return !(max == res[SIZE-1]); +} +#endif // __UNIT_TEST_MERGE__ diff --git a/test/mppa/sort/merge.h b/test/mppa/sort/merge.h new file mode 100644 index 00000000..439ce64a --- /dev/null +++ b/test/mppa/sort/merge.h @@ -0,0 +1,7 @@ +#ifndef __MERGE_H__ +#define __MERGE_H__ + +int merge_sort(uint64_t *res, const uint64_t *T); + +#endif // __MERGE_H__ + diff --git a/test/mppa/sort/selection.c b/test/mppa/sort/selection.c new file mode 100644 index 00000000..df4be04f --- /dev/null +++ b/test/mppa/sort/selection.c @@ -0,0 +1,62 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +#ifdef __UNIT_TEST_SELECTION__ +#define SIZE 100 +#else +#include "test.h" +#endif + +void swap_sel(uint64_t *a, uint64_t *b){ + uint64_t tmp = *a; + *a = *b; + *b = tmp; +} + +int select_sort(uint64_t *res, const uint64_t *T){ + int i, j, iMin; + + if (SIZE <= 0) + return -1; + + for (i = 0 ; i < SIZE ; i++) + res[i] = T[i]; + + for (j = 0 ; j < SIZE ; j++){ + iMin = j; + for (i = j+1 ; i < SIZE ; i++) + if (res[i] < res[iMin]) + iMin = i; + + if (iMin != j) + swap_sel (&res[j], &res[iMin]); + } + + return 0; +} + +#ifdef __UNIT_TEST_SELECTION__ +int main(void){ + uint64_t T[SIZE]; + uint64_t res[SIZE]; + uint64_t max; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* Sorting the table */ + if (select_sort(res, T) < 0) return -1; + + /* Computing max(T) */ + max = T[0]; + for (i = 1 ; i < SIZE ; i++) + if (T[i] > max) + max = T[i]; + + /* We should have: max(T) == res[SIZE] */ + return !(max == res[SIZE-1]); +} +#endif // __UNIT_TEST_SELECTION__ + diff --git a/test/mppa/sort/selection.h b/test/mppa/sort/selection.h new file mode 100644 index 00000000..92a6b461 --- /dev/null +++ b/test/mppa/sort/selection.h @@ -0,0 +1,6 @@ +#ifndef __SELECTION_H__ +#define __SELECTION_H__ + +int select_sort(uint64_t *res, const uint64_t *T); + +#endif // __SELECTION_H__ diff --git a/test/mppa/sort/test.h b/test/mppa/sort/test.h new file mode 100644 index 00000000..4501ee38 --- /dev/null +++ b/test/mppa/sort/test.h @@ -0,0 +1,6 @@ +#ifndef __TEST_H__ +#define __TEST_H__ + +#define SIZE 100 + +#endif diff --git a/test/mppa/test.sh b/test/mppa/test.sh new file mode 100755 index 00000000..dfeb153a --- /dev/null +++ b/test/mppa/test.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the validity of the tests + +source do_test.sh + +do_test test |