From 1003cb19f2bfd50d8a832af431b0ac6b09b65050 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 29 Jun 2020 10:14:44 +0100 Subject: Remove checks for translate_eff_addressing --- src/translation/HTLgen.v | 20 +++++--------------- src/translation/HTLgenproof.v | 4 ++-- src/translation/Veriloggenproof.v | 2 ++ 3 files changed, 9 insertions(+), 17 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index a75ef5c..35b815e 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -292,26 +292,16 @@ Definition check_address_parameter_unsigned (p : Z) : bool := Definition translate_eff_addressing (a: Op.addressing) (args: list reg) : mon expr := match a, args with (* TODO: We should be more methodical here; what are the possibilities?*) | Op.Aindexed off, r1::nil => - if (check_address_parameter_signed off) - then ret (boplitz Vadd r1 off) - else error (Errors.msg "Veriloggen: translate_eff_addressing address misaligned") + ret (boplitz Vadd r1 off) | Op.Ascaled scale offset, r1::nil => - if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue 32 offset))) - else error (Errors.msg "Veriloggen: translate_eff_addressing address misaligned") + ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue 32 offset))) | Op.Aindexed2 offset, r1::r2::nil => - if (check_address_parameter_signed offset) - then ret (Vbinop Vadd (Vvar r1) (boplitz Vadd r2 offset)) - else error (Errors.msg "Veriloggen: translate_eff_addressing address misaligned") + ret (Vbinop Vadd (Vvar r1) (boplitz Vadd r2 offset)) | Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) - if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) - else error (Errors.msg "Veriloggen: translate_eff_addressing address misaligned") + ret (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) let a := Integers.Ptrofs.unsigned a in - if (check_address_parameter_unsigned a) - then ret (Vlit (ZToValue 32 a)) - else error (Errors.msg "Veriloggen: translate_eff_addressing address misaligned") + ret (Vlit (ZToValue 32 a)) | _, _ => error (Errors.msg "Veriloggen: translate_eff_addressing unsuported addressing") end. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 2f296f2..3665775 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -420,7 +420,7 @@ Section CORRECTNESS. match_states S1 R1 -> exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states S2 R2. Proof. - induction 1; intros R1 MSTATE; try inv_state. +(* induction 1; intros R1 MSTATE; try inv_state. - (* Inop *) unfold match_prog in TRANSL. econstructor. @@ -2112,7 +2112,7 @@ Section CORRECTNESS. (* exact (AssocMap.empty value). *) (* exact (AssocMap.empty value). *) (* exact (AssocMap.empty value). *) - (* exact (AssocMap.empty value). *) + (* exact (AssocMap.empty value). *)*) Admitted. Hint Resolve transl_step_correct : htlproof. diff --git a/src/translation/Veriloggenproof.v b/src/translation/Veriloggenproof.v index db96949..518fe3a 100644 --- a/src/translation/Veriloggenproof.v +++ b/src/translation/Veriloggenproof.v @@ -72,9 +72,11 @@ Section CORRECTNESS. induction 1; intros R1 MSTATE; inv MSTATE; econstructor; split. - apply Smallstep.plus_one. econstructor. eassumption. trivial. * econstructor. econstructor. + Admitted. Theorem transf_program_correct: forward_simulation (HTL.semantics prog) (Verilog.semantics tprog). + Admitted. End CORRECTNESS. -- cgit From 89bc64204b4d99cb7dc9eacb1ecdf26b30dc26a0 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 2 Jul 2020 01:57:46 +0100 Subject: Fix spec by adding details about reg vals --- src/translation/HTLgenproof.v | 15 +--- src/translation/HTLgenspec.v | 203 +++++++++++++++++++++++++++++++++++++----- 2 files changed, 182 insertions(+), 36 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 6e470d5..5b393a0 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -86,18 +86,6 @@ Definition stack_bounds (sp : Values.val) (hi : Z) (m : mem) : Prop := Inductive match_frames : list RTL.stackframe -> list HTL.stackframe -> Prop := | match_frames_nil : match_frames nil nil. -(* | match_frames_cons : *) -(* forall cs lr r f sp sp' pc rs m asr asa *) -(* (TF : tr_module f m) *) -(* (ST: match_frames mem cs lr) *) -(* (MA: match_assocmaps f rs asr) *) -(* (MARR : match_arrs m f sp mem asa) *) -(* (SP : sp = Values.Vptr sp' (Integers.Ptrofs.repr 0)) *) -(* (RSBP: reg_stack_based_pointers sp' rs) *) -(* (ASBP: arr_stack_based_pointers sp' mem (f.(RTL.fn_stacksize)) sp) *) -(* (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem), *) -(* match_frames mem (RTL.Stackframe r f sp pc rs :: cs) *) -(* (HTL.Stackframe r m pc asr asa :: lr). *) Inductive match_states : RTL.state -> HTL.state -> Prop := | match_state : forall asa asr sf f sp sp' rs mem m st res @@ -2098,7 +2086,6 @@ Section CORRECTNESS. trivial. symmetry; eapply Linking.match_program_main; eauto. Qed. - (* Had to admit proof because currently there is no way to force main to be Internal. *) Lemma transl_initial_states : forall s1 : Smallstep.state (RTL.semantics prog), Smallstep.initial_state (RTL.semantics prog) s1 -> @@ -2119,7 +2106,7 @@ Section CORRECTNESS. repeat (unfold_match B). inversion B. subst. exploit main_tprog_internal; eauto; intros. rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - apply Heqo. symmetry; eapply Linking.match_program_main; eauto. + Apply Heqo. symmetry; eapply Linking.match_program_main; eauto. inversion H5. econstructor; split. econstructor. apply (Genv.init_mem_transf_partial TRANSL'); eauto. diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index 0cdecba..d2bd5af 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -19,6 +19,7 @@ From compcert Require RTL Op Maps Errors. From compcert Require Import Maps. From coqup Require Import Coquplib Verilog Value HTL HTLgen AssocMap. +Require Import Lia. Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. Hint Resolve Maps.PTree.elements_correct : htlspec. @@ -161,16 +162,23 @@ Hint Constructors tr_code : htlspec. Inductive tr_module (f : RTL.function) : module -> Prop := tr_module_intro : forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls, - (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> - tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> - stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> - Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> - 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> m = (mkmodule f.(RTL.fn_params) data control f.(RTL.fn_entrypoint) st stk stk_len fin rtrn start rst clk scldecls arrdecls) -> + (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> + tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> + stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> + Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> + 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> + st = ((RTL.max_reg_function f) + 1)%positive -> + fin = ((RTL.max_reg_function f) + 2)%positive -> + rtrn = ((RTL.max_reg_function f) + 3)%positive -> + stk = ((RTL.max_reg_function f) + 4)%positive -> + start = ((RTL.max_reg_function f) + 5)%positive -> + rst = ((RTL.max_reg_function f) + 6)%positive -> + clk = ((RTL.max_reg_function f) + 7)%positive -> tr_module f m. Hint Constructors tr_module : htlspec. @@ -202,6 +210,13 @@ Lemma declare_reg_controllogic_trans : Proof. intros. monadInv H. trivial. Qed. Hint Resolve create_reg_controllogic_trans : htlspec. +Lemma declare_reg_freshreg_trans : + forall sz s s' x i iop r, + declare_reg iop r sz s = OK x s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. inversion 1; auto. Qed. +Hint Resolve declare_reg_freshreg_trans : htlspec. + Lemma create_arr_datapath_trans : forall sz ln s s' x i iop, create_arr iop sz ln s = OK x s' i -> @@ -268,6 +283,16 @@ Proof. - apply H in EQ. rewrite EQ. eauto. Qed. +Lemma collect_freshreg_trans : + forall A f l cs cs' ci, + (forall s s' x i y, f y s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg)) -> + @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_freshreg) = cs'.(st_freshreg). +Proof. + induction l; intros; monadInv H0. + - trivial. + - apply H in EQ. rewrite EQ. eauto. +Qed. + Lemma collect_declare_controllogic_trans : forall io n l s s' i, HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> @@ -286,6 +311,130 @@ Proof. intros. eapply declare_reg_datapath_trans. simpl in H0. eassumption. Qed. +Lemma collect_declare_freshreg_trans : + forall io n l s s' i, + HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. eapply collect_freshreg_trans; try eassumption. + inversion 1. auto. +Qed. + +Ltac unfold_match H := + match type of H with + | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate + end. + +Lemma translate_eff_addressing_freshreg_trans : + forall op args s r s' i, + translate_eff_addressing op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. + +Lemma translate_comparison_freshreg_trans : + forall op args s r s' i, + translate_comparison op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_comparison_freshreg_trans : htlspec. + +Lemma translate_comparison_imm_freshreg_trans : + forall op args s r s' i n, + translate_comparison_imm op args n s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. + +Lemma translate_condition_freshreg_trans : + forall op args s r s' i, + translate_condition op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. +Qed. +Hint Resolve translate_condition_freshreg_trans : htlspec. + +Lemma translate_instr_freshreg_trans : + forall op args s r s' i, + translate_instr op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. + monadInv H1. eauto with htlspec. +Qed. +Hint Resolve translate_instr_freshreg_trans : htlspec. + +Lemma translate_arr_access_freshreg_trans : + forall mem addr args st s r s' i, + translate_arr_access mem addr args st s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. +Qed. +Hint Resolve translate_arr_access_freshreg_trans : htlspec. + +Lemma add_instr_freshreg_trans : + forall n n' st s r s' i, + add_instr n n' st s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_instr_freshreg_trans : htlspec. + +Lemma add_branch_instr_freshreg_trans : + forall n n0 n1 e s r s' i, + add_branch_instr e n n0 n1 s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_branch_instr_freshreg_trans : htlspec. + +Lemma add_node_skip_freshreg_trans : + forall n1 n2 s r s' i, + add_node_skip n1 n2 s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_node_skip_freshreg_trans : htlspec. + +Lemma add_instr_skip_freshreg_trans : + forall n1 n2 s r s' i, + add_instr_skip n1 n2 s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_instr_skip_freshreg_trans : htlspec. + +Lemma transf_instr_freshreg_trans : + forall fin ret st instr s v s' i, + transf_instr fin ret st instr s = OK v s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. destruct instr eqn:?. subst. unfold transf_instr in H. + destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. + - apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. + apply declare_reg_freshreg_trans in EQ1. congruence. + - apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. + apply declare_reg_freshreg_trans in EQ1. congruence. + - apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. + - apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. + congruence. + - inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence. +Qed. +Hint Resolve transf_instr_freshreg_trans : htlspec. + +Lemma collect_trans_instr_freshreg_trans : + forall fin ret st l s s' i, + HTLMonadExtra.collectlist (transf_instr fin ret st) l s = OK tt s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. eapply collect_freshreg_trans; try eassumption. + eauto with htlspec. +Qed. + Ltac rewrite_states := match goal with | [ H: ?x ?s = ?x ?s' |- _ ] => @@ -294,11 +443,6 @@ Ltac rewrite_states := remember (?x ?s) as c1; remember (?x ?s') as c2; try subst end. -Ltac unfold_match H := - match type of H with - | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate - end. - Ltac inv_add_instr' H := match type of H with | ?f _ _ _ = OK _ _ _ => unfold f in H @@ -405,9 +549,17 @@ Qed. Hint Resolve iter_expand_instr_spec : htlspec. Lemma create_arr_inv : forall w x y z a b c d, - create_arr w x y z = OK (a, b) c d -> y = b. + create_arr w x y z = OK (a, b) c d -> + y = b /\ a = z.(st_freshreg) /\ c.(st_freshreg) = Pos.succ (z.(st_freshreg)). +Proof. + inversion 1; split; auto. +Qed. + +Lemma create_reg_inv : forall a b s r s' i, + create_reg a b s = OK r s' i -> + r = s.(st_freshreg) /\ s'.(st_freshreg) = Pos.succ (s.(st_freshreg)). Proof. - inversion 1. reflexivity. + inversion 1; auto. Qed. Theorem transl_module_correct : @@ -430,20 +582,27 @@ Proof. monadInv Heqr. (* TODO: We should be able to fold this into the automation. *) - pose proof (create_arr_inv _ _ _ _ _ _ _ _ EQ0) as STK_LEN. - rewrite <- STK_LEN. - - econstructor; simpl; auto. - intros. + pose proof (create_arr_inv _ _ _ _ _ _ _ _ EQ0) as STK_LEN. inv STK_LEN. inv H5. + pose proof (create_reg_inv _ _ _ _ _ _ EQ) as FIN_VAL. inv FIN_VAL. + pose proof (create_reg_inv _ _ _ _ _ _ EQ1) as RET_VAL. inv RET_VAL. + destruct x3. destruct x4. + pose proof (collect_trans_instr_freshreg_trans _ _ _ _ _ _ _ EQ2) as TR_INSTR. + pose proof (collect_declare_freshreg_trans _ _ _ _ _ _ EQ3) as TR_DEC. + pose proof (create_reg_inv _ _ _ _ _ _ EQ4) as START_VAL. inv START_VAL. + pose proof (create_reg_inv _ _ _ _ _ _ EQ5) as RESET_VAL. inv RESET_VAL. + pose proof (create_reg_inv _ _ _ _ _ _ EQ6) as CLK_VAL. inv CLK_VAL. + simpl. + rewrite H9 in *. rewrite H8 in *. replace (st_freshreg s4) with (st_freshreg s2) in * by congruence. + rewrite H6 in *. rewrite H7 in *. rewrite H5 in *. simpl in *. inv_incr. + econstructor; simpl; auto; try lia. + intros. assert (EQ3D := EQ3). - destruct x4. apply collect_declare_datapath_trans in EQ3. apply collect_declare_controllogic_trans in EQ3D. - assert (STC: st_controllogic s10 = st_controllogic s3) by congruence. - assert (STD: st_datapath s10 = st_datapath s3) by congruence. - assert (STST: st_st s10 = st_st s3) by congruence. - rewrite STC. rewrite STD. rewrite STST. + replace (st_controllogic s10) with (st_controllogic s3) by congruence. + replace (st_datapath s10) with (st_datapath s3) by congruence. + replace (st_st s10) with (st_st s3) by congruence. eapply iter_expand_instr_spec; eauto with htlspec. apply PTree.elements_complete. Qed. -- cgit From 9412c0cc838f736fc5d5bea12b027048868a48fb Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 2 Jul 2020 02:34:28 +0100 Subject: Remove all <> Admitted --- src/common/ZExtra.v | 15 +++++++++++++++ src/translation/HTLgenproof.v | 35 ++++++++++++----------------------- 2 files changed, 27 insertions(+), 23 deletions(-) diff --git a/src/common/ZExtra.v b/src/common/ZExtra.v index a0dd717..519ee7c 100644 --- a/src/common/ZExtra.v +++ b/src/common/ZExtra.v @@ -31,4 +31,19 @@ Module ZExtra. apply Zmult_gt_reg_r in g; lia. Qed. + Lemma Ple_not_eq : + forall x y, + (x < y)%positive -> x <> y. + Proof. lia. Qed. + + Lemma Pge_not_eq : + forall x y, + (y < x)%positive -> x <> y. + Proof. lia. Qed. + + Lemma Ple_Plt_Succ : + forall x y n, + (x <= y)%positive -> (x < y + n)%positive. + Proof. lia. Qed. + End ZExtra. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 5b393a0..12a857c 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -260,26 +260,6 @@ Lemma assumption_32bit : valueToPos (posToValue 32 v) = v. Admitted. -Lemma st_greater_than_res : - forall m res : positive, - m <> res. -Admitted. - -Lemma finish_not_return : - forall r f : positive, - r <> f. -Admitted. - -Lemma finish_not_res : - forall f r : positive, - f <> r. -Admitted. - -Lemma greater_than_max_func : - forall f st, - Plt (RTL.max_reg_function f) st. -Proof. Admitted. - Ltac inv_state := match goal with MSTATE : match_states _ _ |- _ => @@ -445,7 +425,7 @@ Section CORRECTNESS. | [ |- context[match_states _ _] ] => econstructor; auto | [ |- match_arrs _ _ _ _ _ ] => econstructor; auto | [ |- match_assocmaps _ _ _ # _ <- (posToValue 32 _) ] => - apply regs_lessdef_add_greater; [> apply greater_than_max_func | assumption] + apply regs_lessdef_add_greater; [> unfold Plt; lia | assumption] | [ H : ?asa ! ?r = Some _ |- Verilog.arr_assocmap_lookup ?asa ?r _ = Some _ ] => unfold Verilog.arr_assocmap_lookup; setoid_rewrite H; f_equal @@ -717,8 +697,17 @@ Section CORRECTNESS. all: big_tac. - 1: { apply st_greater_than_res. } - 2: { apply st_greater_than_res. } + 1: { + assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + } + + 2: { + assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. -- cgit From e568448eeddb13f8da8583f18e8e8f35956e6896 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 2 Jul 2020 16:13:37 +0100 Subject: Push current state --- src/translation/HTLgenproof.v | 70 +++++++++++++++++++++++++++---------------- src/verilog/Value.v | 2 ++ 2 files changed, 46 insertions(+), 26 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 12a857c..ac96cf6 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -767,9 +767,9 @@ Section CORRECTNESS. apply H6 in HPler0. apply H8 in HPler1. invert HPler0; invert HPler1; try congruence. - rewrite EQr0 in H10. - rewrite EQr1 in H12. - invert H10. invert H12. + rewrite EQr0 in H9. + rewrite EQr1 in H11. + invert H9. invert H11. clear H0. clear H6. clear H8. unfold check_address_parameter_signed in *; @@ -849,8 +849,16 @@ Section CORRECTNESS. all: big_tac. - 1: { apply st_greater_than_res. } - 2: { apply st_greater_than_res. } + 1: { + assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + } + 2: { + assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. @@ -944,8 +952,16 @@ Section CORRECTNESS. all: big_tac. - 1: { apply st_greater_than_res. } - 2: { apply st_greater_than_res. } + 1: { + assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + } + 2: { + assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. + } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. @@ -1072,7 +1088,8 @@ Section CORRECTNESS. (** Match assocmaps *) unfold Verilog.merge_regs. crush. unfold_merge. - apply regs_lessdef_add_greater. apply greater_than_max_func. + apply regs_lessdef_add_greater. + unfold Plt; lia. assumption. (** States well formed *) @@ -1168,9 +1185,9 @@ Section CORRECTNESS. right. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H19; try lia. - apply Zmult_lt_compat_r with (p := 4) in H19; try lia. - rewrite ZLib.div_mul_undo in H19; try lia. + rewrite Z2Nat.id in H15; try lia. + apply Zmult_lt_compat_r with (p := 4) in H15; try lia. + rewrite ZLib.div_mul_undo in H15; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1292,9 +1309,9 @@ Section CORRECTNESS. apply H6 in HPler0. apply H8 in HPler1. invert HPler0; invert HPler1; try congruence. - rewrite EQr0 in H10. - rewrite EQr1 in H12. - invert H10. invert H12. + rewrite EQr0 in H9. + rewrite EQr1 in H11. + invert H9. invert H11. clear H0. clear H6. clear H8. unfold check_address_parameter_signed in *; @@ -1362,7 +1379,8 @@ Section CORRECTNESS. (** Match assocmaps *) unfold Verilog.merge_regs. crush. unfold_merge. - apply regs_lessdef_add_greater. apply greater_than_max_func. + apply regs_lessdef_add_greater. + unfold Plt; lia. assumption. (** States well formed *) @@ -1429,19 +1447,19 @@ Section CORRECTNESS. simpl. assert (Ple src (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H0 in H20. - destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H20; eauto. + apply H0 in H16. + destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H16; eauto. rewrite <- array_set_len. unfold arr_repeat. crush. rewrite list_repeat_len. auto. assert (4 * ptr / 4 = Integers.Ptrofs.unsigned OFFSET / 4) by (f_equal; assumption). - rewrite Z.mul_comm in H20. - rewrite Z_div_mult in H20; try lia. - replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H20 by reflexivity. - rewrite <- PtrofsExtra.divu_unsigned in H20; unfold_constants; try lia. - rewrite H20. rewrite EXPR_OK. + rewrite Z.mul_comm in H16. + rewrite Z_div_mult in H16; try lia. + replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H16 by reflexivity. + rewrite <- PtrofsExtra.divu_unsigned in H16; unfold_constants; try lia. + rewrite H16. rewrite EXPR_OK. rewrite array_get_error_set_bound. reflexivity. unfold arr_length, arr_repeat. simpl. @@ -1458,9 +1476,9 @@ Section CORRECTNESS. right. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H22; try lia. - apply Zmult_lt_compat_r with (p := 4) in H22; try lia. - rewrite ZLib.div_mul_undo in H22; try lia. + rewrite Z2Nat.id in H18; try lia. + apply Zmult_lt_compat_r with (p := 4) in H18; try lia. + rewrite ZLib.div_mul_undo in H18; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1484,7 +1502,7 @@ Section CORRECTNESS. lia. unfold_constants. intro. - apply Z2Nat.inj_iff in H20; try lia. + apply Z2Nat.inj_iff in H13; try lia. apply Z.div_pos; try lia. apply Integers.Ptrofs.unsigned_range. diff --git a/src/verilog/Value.v b/src/verilog/Value.v index 8ba5138..dc163de 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -39,6 +39,8 @@ Record value : Type := vword: word vsize }. +Search N.of_nat. + (** ** Value conversions Various conversions to different number types such as [N], [Z], [positive] and -- cgit From fc51e46012219e9410931820ef7c0612734620aa Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 2 Jul 2020 16:32:17 +0100 Subject: Stuck in Callstate proof --- src/translation/HTLgenproof.v | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index ac96cf6..9b61b27 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -1502,7 +1502,7 @@ Section CORRECTNESS. lia. unfold_constants. intro. - apply Z2Nat.inj_iff in H13; try lia. + apply Z2Nat.inj_iff in H16; try lia. apply Z.div_pos; try lia. apply Integers.Ptrofs.unsigned_range. @@ -1538,8 +1538,8 @@ Section CORRECTNESS. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. invert H0. - apply Zmult_lt_compat_r with (p := 4) in H21; try lia. - rewrite ZLib.div_mul_undo in H21; try lia. + apply Zmult_lt_compat_r with (p := 4) in H17; try lia. + rewrite ZLib.div_mul_undo in H17; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1622,7 +1622,8 @@ Section CORRECTNESS. (** Match assocmaps *) unfold Verilog.merge_regs. crush. unfold_merge. - apply regs_lessdef_add_greater. apply greater_than_max_func. + apply regs_lessdef_add_greater. + unfold Plt; lia. assumption. (** States well formed *) @@ -1713,9 +1714,9 @@ Section CORRECTNESS. right. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H12; try lia. - apply Zmult_lt_compat_r with (p := 4) in H12; try lia. - rewrite ZLib.div_mul_undo in H12; try lia. + rewrite Z2Nat.id in H11; try lia. + apply Zmult_lt_compat_r with (p := 4) in H11; try lia. + rewrite ZLib.div_mul_undo in H11; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1775,8 +1776,8 @@ Section CORRECTNESS. apply ZExtra.mod_0_bounds; try lia. apply ZLib.Z_mod_mult'. invert H0. - apply Zmult_lt_compat_r with (p := 4) in H10; try lia. - rewrite ZLib.div_mul_undo in H10; try lia. + apply Zmult_lt_compat_r with (p := 4) in H9; try lia. + rewrite ZLib.div_mul_undo in H9; try lia. split; try lia. apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. } @@ -1901,15 +1902,12 @@ Section CORRECTNESS. constructor. constructor. unfold state_st_wf in WF; big_tac; eauto. - apply st_greater_than_res. - apply st_greater_than_res. apply HTL.step_finish. unfold Verilog.merge_regs. unfold_merge; simpl. rewrite AssocMap.gso. - apply AssocMap.gss. - apply finish_not_return. + apply AssocMap.gss. lia. apply AssocMap.gss. rewrite Events.E0_left. reflexivity. @@ -1928,15 +1926,12 @@ Section CORRECTNESS. constructor. constructor. constructor. unfold state_st_wf in WF; big_tac; eauto. - apply st_greater_than_res. - apply st_greater_than_res. apply HTL.step_finish. unfold Verilog.merge_regs. unfold_merge. rewrite AssocMap.gso. - apply AssocMap.gss. - apply finish_not_return. + apply AssocMap.gss. simpl; lia. apply AssocMap.gss. rewrite Events.E0_left. trivial. @@ -1945,7 +1940,9 @@ Section CORRECTNESS. simpl. inversion MASSOC. subst. unfold find_assocmap, AssocMapExt.get_default. rewrite AssocMap.gso. apply H1. eapply RTL.max_reg_function_use. eauto. simpl; tauto. - apply st_greater_than_res. + assert (HPle : Ple r (RTL.max_reg_function f)). + eapply RTL.max_reg_function_use. eassumption. simpl; auto. + apply ZExtra.Ple_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. Unshelve. all: constructor. @@ -1975,7 +1972,7 @@ Section CORRECTNESS. all: big_tac. apply regs_lessdef_add_greater. - apply greater_than_max_func. + unfold Plt; lia. apply init_reg_assoc_empty. constructor. @@ -2030,7 +2027,7 @@ Section CORRECTNESS. unfold Mem.perm in H3. crush. unfold Mem.perm_order' in H3. small_tac. - exploit (H3 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. + exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. rewrite Maps.PMap.gss in H8. match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. crush. -- cgit From cf19dd40f466691d28f4dfd86211724b700aa217 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Thu, 2 Jul 2020 16:38:23 +0100 Subject: Fix callstate proof. --- src/translation/HTLgenproof.v | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 9b61b27..e4bbb8f 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -2023,9 +2023,9 @@ Section CORRECTNESS. unfold Mem.load. intros. match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H3. - unfold Mem.perm in H3. crush. - unfold Mem.perm_order' in H3. + invert v0. unfold Mem.range_perm in H4. + unfold Mem.perm in H4. crush. + unfold Mem.perm_order' in H4. small_tac. exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. rewrite Maps.PMap.gss in H8. @@ -2039,11 +2039,11 @@ Section CORRECTNESS. unfold Mem.store. intros. match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H3. - unfold Mem.perm in H3. crush. - unfold Mem.perm_order' in H3. + invert v0. unfold Mem.range_perm in H4. + unfold Mem.perm in H4. crush. + unfold Mem.perm_order' in H4. small_tac. - exploit (H3 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. + exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. rewrite Maps.PMap.gss in H8. match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. crush. -- cgit From 3d1aa19a70e00dfcb4733b8b478d4865c86e7cd9 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 2 Jul 2020 16:49:16 +0100 Subject: Typo fix --- src/translation/HTLgenproof.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index e4bbb8f..aec765c 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -2110,7 +2110,7 @@ Section CORRECTNESS. repeat (unfold_match B). inversion B. subst. exploit main_tprog_internal; eauto; intros. rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - Apply Heqo. symmetry; eapply Linking.match_program_main; eauto. + apply Heqo. symmetry; eapply Linking.match_program_main; eauto. inversion H5. econstructor; split. econstructor. apply (Genv.init_mem_transf_partial TRANSL'); eauto. -- cgit From 74819dfa35ee60feb81811247d59775bd66630d0 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Thu, 2 Jul 2020 17:00:14 +0100 Subject: Complete ZToValue_valueToNat. --- src/translation/HTLgenproof.v | 38 ++++++++++++++++---------------------- src/verilog/Value.v | 27 ++++++++++++++++++--------- 2 files changed, 34 insertions(+), 31 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index e4bbb8f..38fe27a 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -849,16 +849,13 @@ Section CORRECTNESS. all: big_tac. - 1: { - assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - } - 2: { - assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - } + 1: { assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } + + 2: { assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. @@ -952,22 +949,19 @@ Section CORRECTNESS. all: big_tac. - 1: { - assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - } - 2: { - assert (HPle : Ple dst (RTL.max_reg_function f)). - eapply RTL.max_reg_function_def. eassumption. auto. - apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - } + 1: { assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } + + 2: { assert (HPle : Ple dst (RTL.max_reg_function f)). + eapply RTL.max_reg_function_def. eassumption. auto. + apply ZExtra.Pge_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. } (** Match assocmaps *) apply regs_lessdef_add_match; big_tac. (** Equality proof *) - match goal with + match goal with (* Prevents issues with evars *) | [ |- context [valueToNat ?x] ] => assert (Z.to_nat (Integers.Ptrofs.unsigned @@ -2110,7 +2104,7 @@ Section CORRECTNESS. repeat (unfold_match B). inversion B. subst. exploit main_tprog_internal; eauto; intros. rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - Apply Heqo. symmetry; eapply Linking.match_program_main; eauto. + apply Heqo. symmetry; eapply Linking.match_program_main; eauto. inversion H5. econstructor; split. econstructor. apply (Genv.init_mem_transf_partial TRANSL'); eauto. diff --git a/src/verilog/Value.v b/src/verilog/Value.v index dc163de..116986b 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -21,6 +21,7 @@ From bbv Require Import Word. From bbv Require HexNotation WordScope. From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia. From compcert Require Import lib.Integers common.Values. +From coqup Require Import Coquplib. (* end hide *) (** * Value @@ -454,17 +455,25 @@ Proof. unfold wordBin. repeat (rewrite wordToN_NToWord_2); auto. Qed. -(*Lemma ZToValue_valueToNat : +Lemma ZToValue_valueToNat : forall x sz, - sz > 0 -> - (x < 2^(Z.of_nat sz))%Z -> + (sz > 0)%nat -> + (0 <= x < 2^(Z.of_nat sz))%Z -> valueToNat (ZToValue sz x) = Z.to_nat x. Proof. - destruct x; intros; unfold ZToValue, valueToNat; simpl. + destruct x; intros; unfold ZToValue, valueToNat; crush. - rewrite wzero'_def. apply wordToNat_wzero. - rewrite posToWord_nat. rewrite wordToNat_natToWord_2. trivial. - unfold Z.of_nat in *. destruct sz eqn:?. omega. simpl in H0. - rewrite <- Pos2Z.inj_pow_pos in H0. Search (Z.pos _ < Z.pos _)%Z. - Search Pos.to_nat (_ < _). (* Pos2Nat.inj_lt *) - Search "inj" positive nat. -*) + clear H1. + lazymatch goal with + | [ H : context[(_ < ?x)%Z] |- _ ] => replace x with (Z.of_nat (Z.to_nat x)) in H + end. + 2: { apply Z2Nat.id; apply Z.pow_nonneg; lia. } + + rewrite Z2Nat.inj_pow in H2; crush. + replace (Pos.to_nat 2) with 2%nat in H2 by reflexivity. + rewrite Nat2Z.id in H2. + rewrite <- positive_nat_Z in H2. + apply Nat2Z.inj_lt in H2. + assumption. +Qed. -- cgit From 1d8afa5949cd192620e4649ae32df49bca4da3f8 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Thu, 2 Jul 2020 21:57:03 +0100 Subject: Switch to uvalueToZ in lessdef. --- src/common/Coquplib.v | 26 +++++++++++++---- src/common/IntegerExtra.v | 57 +++++++++++++++++++++--------------- src/translation/HTLgenproof.v | 67 ++++++++++++++++++++----------------------- src/verilog/Value.v | 4 +-- 4 files changed, 87 insertions(+), 67 deletions(-) diff --git a/src/common/Coquplib.v b/src/common/Coquplib.v index c9361c2..8ad557b 100644 --- a/src/common/Coquplib.v +++ b/src/common/Coquplib.v @@ -32,6 +32,8 @@ From coqup Require Import Show. From compcert.lib Require Export Coqlib. From compcert Require Import Integers. +Local Open Scope Z_scope. + Ltac unfold_rec c := unfold c; fold c. Ltac solve_by_inverts n := @@ -129,16 +131,28 @@ Ltac unfold_constants := end end. -Ltac crush := intros; unfold_constants; simpl in *; - repeat (clear_obvious; nicify_goals; kill_bools); - simpl in *; try discriminate; try congruence; try lia; try assumption. - -Global Opaque Nat.div. -Global Opaque Z.mul. +Ltac simplify := intros; unfold_constants; simpl in *; + repeat (clear_obvious; nicify_goals; kill_bools); + simpl in *. Infix "==nat" := eq_nat_dec (no associativity, at level 50). Infix "==Z" := Z.eq_dec (no associativity, at level 50). +Ltac liapp := + match goal with + | [ |- (?x | ?y) ] => + match (eval compute in (Z.rem y x ==Z 0)) with + | left _ => let q := (eval compute in (Z.div y x)) in exists q; reflexivity + | _ => idtac + end + | _ => idtac + end. + +Ltac crush := simplify; try discriminate; try congruence; try lia; liapp; try assumption. + +Global Opaque Nat.div. +Global Opaque Z.mul. + (* Definition const (A B : Type) (a : A) (b : B) : A := a. Definition compose (A B C : Type) (f : B -> C) (g : A -> B) (x : A) : C := f (g x). *) diff --git a/src/common/IntegerExtra.v b/src/common/IntegerExtra.v index 6bac18d..dcaf3a1 100644 --- a/src/common/IntegerExtra.v +++ b/src/common/IntegerExtra.v @@ -70,22 +70,21 @@ Module PtrofsExtra. Lemma of_int_mod : forall x m, - Int.signed x mod m = 0 -> - Ptrofs.signed (Ptrofs.of_int x) mod m = 0. + Int.unsigned x mod m = 0 -> + Ptrofs.unsigned (Ptrofs.of_int x) mod m = 0. Proof. intros. - pose proof (Integers.Ptrofs.agree32_of_int eq_refl x) as A. - pose proof Ptrofs.agree32_signed. - apply H0 in A; try reflexivity. - rewrite A. assumption. + unfold Ptrofs.of_int. + rewrite Ptrofs.unsigned_repr; crush; + apply Int.unsigned_range_2. Qed. Lemma mul_mod : forall x y m, 0 < m -> (m | Ptrofs.modulus) -> - Ptrofs.signed x mod m = 0 -> - Ptrofs.signed y mod m = 0 -> + Ptrofs.unsigned x mod m = 0 -> + Ptrofs.unsigned y mod m = 0 -> (Ptrofs.signed (Ptrofs.mul x y)) mod m = 0. Proof. intros. unfold Ptrofs.mul. @@ -95,7 +94,6 @@ Module PtrofsExtra. | [ _ : _ |- context[if ?x then _ else _] ] => destruct x | [ _ : _ |- context[_ mod Ptrofs.modulus mod m] ] => rewrite <- Zmod_div_mod; try lia; try assumption - | [ _ : _ |- context[Ptrofs.unsigned _] ] => rewrite Ptrofs.unsigned_signed end; try(crush; lia); ptrofs_mod_tac m. Qed. @@ -103,8 +101,8 @@ Module PtrofsExtra. forall x y m, 0 < m -> (m | Ptrofs.modulus) -> - Ptrofs.signed x mod m = 0 -> - Ptrofs.signed y mod m = 0 -> + Ptrofs.unsigned x mod m = 0 -> + Ptrofs.unsigned y mod m = 0 -> (Ptrofs.unsigned (Ptrofs.add x y)) mod m = 0. Proof. intros. unfold Ptrofs.add. @@ -114,7 +112,6 @@ Module PtrofsExtra. | [ _ : _ |- context[if ?x then _ else _] ] => destruct x | [ _ : _ |- context[_ mod Ptrofs.modulus mod m] ] => rewrite <- Zmod_div_mod; try lia; try assumption - | [ _ : _ |- context[Ptrofs.unsigned _] ] => rewrite Ptrofs.unsigned_signed end; try (crush; lia); ptrofs_mod_tac m. Qed. @@ -243,22 +240,37 @@ Module IntExtra. Ltac int_mod_tac m := repeat (int_mod_match m); lia. - Lemma mul_mod : + Lemma mul_mod1 : + forall x y m, + 0 < m -> + (m | Int.modulus) -> + Int.unsigned x mod m = 0 -> + (Int.unsigned (Int.mul x y)) mod m = 0. + Proof. + intros. unfold Int.mul. + rewrite Int.unsigned_repr_eq. + + repeat match goal with + | [ _ : _ |- context[if ?x then _ else _] ] => destruct x + | [ _ : _ |- context[_ mod Int.modulus mod m] ] => + rewrite <- Zmod_div_mod; try lia; try assumption + end; try (crush; lia); int_mod_tac m. + Qed. + + Lemma mul_mod2 : forall x y m, 0 < m -> (m | Int.modulus) -> - Int.signed x mod m = 0 -> - Int.signed y mod m = 0 -> - (Int.signed (Int.mul x y)) mod m = 0. + Int.unsigned y mod m = 0 -> + (Int.unsigned (Int.mul x y)) mod m = 0. Proof. intros. unfold Int.mul. - rewrite Int.signed_repr_eq. + rewrite Int.unsigned_repr_eq. repeat match goal with | [ _ : _ |- context[if ?x then _ else _] ] => destruct x | [ _ : _ |- context[_ mod Int.modulus mod m] ] => rewrite <- Zmod_div_mod; try lia; try assumption - | [ _ : _ |- context[Int.unsigned _] ] => rewrite Int.unsigned_signed end; try (crush; lia); int_mod_tac m. Qed. @@ -266,18 +278,17 @@ Module IntExtra. forall x y m, 0 < m -> (m | Int.modulus) -> - Int.signed x mod m = 0 -> - Int.signed y mod m = 0 -> - (Int.signed (Int.add x y)) mod m = 0. + Int.unsigned x mod m = 0 -> + Int.unsigned y mod m = 0 -> + (Int.unsigned (Int.add x y)) mod m = 0. Proof. intros. unfold Int.add. - rewrite Int.signed_repr_eq. + rewrite Int.unsigned_repr_eq. repeat match goal with | [ _ : _ |- context[if ?x then _ else _] ] => destruct x | [ _ : _ |- context[_ mod Int.modulus mod m] ] => rewrite <- Zmod_div_mod; try lia; try assumption - | [ _ : _ |- context[Int.unsigned _] ] => rewrite Int.unsigned_signed end; try (crush; lia); int_mod_tac m. Qed. End IntExtra. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 38fe27a..07417a7 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -635,18 +635,18 @@ Section CORRECTNESS. unfold check_address_parameter_signed in *; unfold check_address_parameter_unsigned in *; crush. - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (valueToZ asr # r0)) + remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. (** Modular preservation proof *) assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - rewrite Integers.Ptrofs.signed_repr; try assumption. - admit. (* FIXME: Register bounds. *) + apply PtrofsExtra.add_mod; crush. + rewrite Integers.Ptrofs.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. apply PtrofsExtra.of_int_mod. - rewrite Integers.Int.signed_repr; crush. } + rewrite Integers.Int.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. } (** Read bounds proof *) assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. @@ -775,7 +775,7 @@ Section CORRECTNESS. unfold check_address_parameter_signed in *; unfold check_address_parameter_unsigned in *; crush. - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (valueToZ asr # r0)) + remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) (Integers.Int.repr z0)))) as OFFSET. @@ -784,17 +784,15 @@ Section CORRECTNESS. assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. { rewrite HeqOFFSET. apply PtrofsExtra.add_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - rewrite Integers.Ptrofs.signed_repr; try assumption. - admit. (* FIXME: Register bounds. *) + rewrite Integers.Ptrofs.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. apply PtrofsExtra.of_int_mod. - apply IntExtra.add_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - apply IntExtra.mul_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - admit. (* FIXME: Register bounds. *) - rewrite Integers.Int.signed_repr; crush. - rewrite Integers.Int.signed_repr; crush. } + apply IntExtra.add_mod; crush. + apply IntExtra.mul_mod2; crush. + rewrite Integers.Int.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. + rewrite Integers.Int.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. } (** Read bounds proof *) assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. @@ -1033,18 +1031,18 @@ Section CORRECTNESS. unfold check_address_parameter_unsigned in *; unfold check_address_parameter_signed in *; crush. - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (valueToZ asr # r0)) + remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. (** Modular preservation proof *) assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. { rewrite HeqOFFSET. apply PtrofsExtra.add_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - rewrite Integers.Ptrofs.signed_repr; try assumption. - admit. (* FIXME: Register bounds. *) + rewrite Integers.Ptrofs.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. apply PtrofsExtra.of_int_mod. - rewrite Integers.Int.signed_repr; crush. } + rewrite Integers.Int.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. } (** Write bounds proof *) assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. @@ -1133,7 +1131,7 @@ Section CORRECTNESS. rewrite list_repeat_len. rewrite H4. reflexivity. - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (valueToZ asr # r0)) + remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). @@ -1311,7 +1309,7 @@ Section CORRECTNESS. unfold check_address_parameter_signed in *; unfold check_address_parameter_unsigned in *; crush. - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (valueToZ asr # r0)) + remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) (Integers.Int.repr z0)))) as OFFSET. @@ -1320,18 +1318,15 @@ Section CORRECTNESS. assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. { rewrite HeqOFFSET. apply PtrofsExtra.add_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - rewrite Integers.Ptrofs.signed_repr; try assumption. - admit. (* FIXME: Register bounds. *) + rewrite Integers.Ptrofs.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. apply PtrofsExtra.of_int_mod. - apply IntExtra.add_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - apply IntExtra.mul_mod; crush; try lia. - exists 1073741824. reflexivity. (* FIXME: This is sadness inducing. *) - admit. (* FIXME: Register bounds. *) - rewrite Integers.Int.signed_repr; crush; try split; try assumption. - rewrite Integers.Int.signed_repr; crush; try split; try assumption. - } + apply IntExtra.add_mod; crush. + apply IntExtra.mul_mod2; crush. + rewrite Integers.Int.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. + rewrite Integers.Int.unsigned_repr_eq. + rewrite <- Zmod_div_mod; crush. } (** Write bounds proof *) assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. @@ -1423,7 +1418,7 @@ Section CORRECTNESS. rewrite list_repeat_len. rewrite H4. reflexivity. - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (valueToZ asr # r0)) + remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) (Integers.Ptrofs.of_int (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) (Integers.Int.repr z0)))) as OFFSET. diff --git a/src/verilog/Value.v b/src/verilog/Value.v index 116986b..acabcf2 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -304,8 +304,8 @@ Inductive val_value_lessdef: val -> value -> Prop := val_value_lessdef (Vint i) v' | val_value_lessdef_ptr: forall b off v', - off = Ptrofs.repr (valueToZ v') -> - (Z.modulo (valueToZ v') 4) = 0%Z -> + off = Ptrofs.repr (uvalueToZ v') -> + (Z.modulo (uvalueToZ v') 4) = 0%Z -> val_value_lessdef (Vptr b off) v' | lessdef_undef: forall v, val_value_lessdef Vundef v. -- cgit From 0b480d489a91f0d418523933b5e35288fcec65b1 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 3 Jul 2020 12:14:39 +0100 Subject: Updates to Iop proof --- src/translation/HTLgen.v | 2 - src/translation/HTLgenproof.v | 190 ++++++++++++++++++++++-------------------- src/verilog/Value.v | 79 +++++++++++++++++- 3 files changed, 179 insertions(+), 92 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index b32ed9d..a2b77e6 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -353,8 +353,6 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr := do tc <- translate_condition c rl; ret (Vternary tc (Vvar r1) (Vvar r2)) | Op.Olea a, _ => translate_eff_addressing a args - | Op.Oleal a, _ => translate_eff_addressing a args (* FIXME: Need to be careful here; large arrays might fail? *) - | Op.Ocast32signed, r::nil => ret (Vvar r) (* FIXME: Don't need to sign extend for now since everything is 32 bit? *) | _, _ => error (Errors.msg "Htlgen: Instruction not implemented: other") end. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 07417a7..956c3ed 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -359,22 +359,35 @@ Section CORRECTNESS. Hint Resolve senv_preserved : htlproof. Lemma eval_correct : - forall sp op rs args m v v' e asr asa f s s' i, + forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, + match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> + (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> Op.eval_operation ge sp op -(List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> + (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> translate_instr op args s = OK e s' i -> - val_value_lessdef v v' -> - Verilog.expr_runp f asr asa e v'. - Admitted. + exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. + Proof. + intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. + inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; + unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); simplify. + - inv Heql. + assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + apply H in HPle. eexists. split; try constructor; eauto. + - eexists. split. constructor. constructor. symmetry. apply valueToInt_intToValue. + - inv Heql. + assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + apply H in HPle. + eexists. split. econstructor; eauto. constructor. trivial. + unfold Verilog.unop_run. Lemma eval_cond_correct : forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, - translate_condition cond args s1 = OK c s' i -> - Op.eval_condition - cond - (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) - m = Some b -> - Verilog.expr_runp f asr asa c (boolToValue 32 b). + translate_condition cond args s1 = OK c s' i -> + Op.eval_condition + cond + (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) + m = Some b -> + Verilog.expr_runp f asr asa c (boolToValue 32 b). Admitted. (** The proof of semantic preservation for the translation of instructions @@ -489,84 +502,83 @@ Section CORRECTNESS. Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. Proof. - intros s f sp pc rs m op args res0 pc' v H H0. - - (* Iop *) - (* destruct v eqn:?; *) - (* try ( *) - (* destruct op eqn:?; inversion H21; simpl in H0; repeat (unfold_match H0); *) - (* inversion H0; subst; simpl in *; try (unfold_func H4); try (unfold_func H5); *) - (* try (unfold_func H6); *) - (* try (unfold Op.eval_addressing32 in H6; repeat (unfold_match H6); inversion H6; *) - (* unfold_func H3); *) - - (* inversion Heql; inversion MASSOC; subst; *) - (* assert (HPle : Ple r (RTL.max_reg_function f)) *) - (* by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) - (* apply H1 in HPle; inversion HPle; *) - (* rewrite H2 in *; discriminate *) - (* ). *) - - (* + econstructor. split. *) - (* apply Smallstep.plus_one. *) - (* eapply HTL.step_module; eauto. *) - (* econstructor; simpl; trivial. *) - (* constructor; trivial. *) - (* econstructor; simpl; eauto. *) - (* eapply eval_correct; eauto. constructor. *) - (* unfold_merge. simpl. *) - (* rewrite AssocMap.gso. *) - (* apply AssocMap.gss. *) - (* apply st_greater_than_res. *) - - (* (* match_states *) *) - (* assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. *) - (* rewrite <- H1. *) - (* constructor; auto. *) - (* unfold_merge. *) - (* apply regs_lessdef_add_match. *) - (* constructor. *) - (* apply regs_lessdef_add_greater. *) - (* apply greater_than_max_func. *) - (* assumption. *) - - (* unfold state_st_wf. intros. inversion H2. subst. *) - (* unfold_merge. *) - (* rewrite AssocMap.gso. *) - (* apply AssocMap.gss. *) - (* apply st_greater_than_res. *) - - (* + econstructor. split. *) - (* apply Smallstep.plus_one. *) - (* eapply HTL.step_module; eauto. *) - (* econstructor; simpl; trivial. *) - (* constructor; trivial. *) - (* econstructor; simpl; eauto. *) - (* eapply eval_correct; eauto. *) - (* constructor. rewrite valueToInt_intToValue. trivial. *) - (* unfold_merge. simpl. *) - (* rewrite AssocMap.gso. *) - (* apply AssocMap.gss. *) - (* apply st_greater_than_res. *) - - (* (* match_states *) *) - (* assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. *) - (* rewrite <- H1. *) - (* constructor. *) - (* unfold_merge. *) - (* apply regs_lessdef_add_match. *) - (* constructor. *) - (* symmetry. apply valueToInt_intToValue. *) - (* apply regs_lessdef_add_greater. *) - (* apply greater_than_max_func. *) - (* assumption. assumption. *) - - (* unfold state_st_wf. intros. inversion H2. subst. *) - (* unfold_merge. *) - (* rewrite AssocMap.gso. *) - (* apply AssocMap.gss. *) - (* apply st_greater_than_res. *) - (* assumption. *) + intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. + inv_state. + exploit eval_correct; eauto. intros. inversion H1. inversion H2. + econstructor. split. + apply Smallstep.plus_one. + eapply HTL.step_module; eauto. + apply assumption_32bit. + econstructor; simpl; trivial. + constructor; trivial. + econstructor; simpl; eauto. + simpl. econstructor. econstructor. + apply H3. simplify. + + all: big_tac. + + assert (Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + + unfold Ple in H10. lia. + apply regs_lessdef_add_match. assumption. + apply regs_lessdef_add_greater. unfold Plt; lia. assumption. + assert (Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + unfold Ple in H12; lia. + unfold_merge. simpl. + rewrite AssocMap.gso. + apply AssocMap.gss. + apply st_greater_than_res. + + (*match_states*) + assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. + rewrite <- H1. + constructor; auto. + unfold_merge. + apply regs_lessdef_add_match. + constructor. + apply regs_lessdef_add_greater. + apply greater_than_max_func. + assumption. + + unfold state_st_wf. intros. inversion H2. subst. + unfold_merge. + rewrite AssocMap.gso. + apply AssocMap.gss. + apply st_greater_than_res. + + + econstructor. split. + apply Smallstep.plus_one. + eapply HTL.step_module; eauto. + econstructor; simpl; trivial. + constructor; trivial. + econstructor; simpl; eauto. + eapply eval_correct; eauto. + constructor. rewrite valueToInt_intToValue. trivial. + unfold_merge. simpl. + rewrite AssocMap.gso. + apply AssocMap.gss. + apply st_greater_than_res. + + match_states + assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. + rewrite <- H1. + constructor. + unfold_merge. + apply regs_lessdef_add_match. + constructor. + symmetry. apply valueToInt_intToValue. + apply regs_lessdef_add_greater. + apply greater_than_max_func. + assumption. assumption. + + unfold state_st_wf. intros. inversion H2. subst. + unfold_merge. + rewrite AssocMap.gso. + apply AssocMap.gss. + apply st_greater_than_res. + assumption. Admitted. Hint Resolve transl_iop_correct : htlproof. diff --git a/src/verilog/Value.v b/src/verilog/Value.v index acabcf2..23ce0f7 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -88,9 +88,18 @@ Definition intToValue (i : Integers.int) : value := Definition valueToInt (i : value) : Integers.int := Int.repr (uvalueToZ i). +Definition ptrToValue (i : Integers.ptrofs) : value := + ZToValue Ptrofs.wordsize (Ptrofs.unsigned i). + +Definition valueToPtr (i : value) : Integers.ptrofs := + Ptrofs.repr (uvalueToZ i). + Definition valToValue (v : Values.val) : option value := match v with | Values.Vint i => Some (intToValue i) + | Values.Vptr b off => if Z.eqb (Z.modulo (uvalueToZ (ptrToValue off)) 4) 0%Z + then Some (ptrToValue off) + else None | Values.Vundef => Some (ZToValue 32 0%Z) | _ => None end. @@ -304,7 +313,7 @@ Inductive val_value_lessdef: val -> value -> Prop := val_value_lessdef (Vint i) v' | val_value_lessdef_ptr: forall b off v', - off = Ptrofs.repr (uvalueToZ v') -> + off = valueToPtr v' -> (Z.modulo (uvalueToZ v') 4) = 0%Z -> val_value_lessdef (Vptr b off) v' | lessdef_undef: forall v, val_value_lessdef Vundef v. @@ -382,6 +391,41 @@ Proof. apply Z.lt_le_pred in H. apply H. Qed. +Lemma valueToPtr_ptrToValue : + forall v, + valueToPtr (ptrToValue v) = v. +Proof. + intros. + unfold valueToPtr, ptrToValue. rewrite uvalueToZ_ZToValue. auto using Ptrofs.repr_unsigned. + split. apply Ptrofs.unsigned_range_2. + assert ((Ptrofs.unsigned v <= Ptrofs.max_unsigned)%Z) by apply Ptrofs.unsigned_range_2. + apply Z.lt_le_pred in H. apply H. +Qed. + +Lemma intToValue_valueToInt : + forall v, + vsize v = 32%nat -> + intToValue (valueToInt v) = v. +Proof. + intros. unfold valueToInt, intToValue. rewrite Int.unsigned_repr_eq. + unfold ZToValue, uvalueToZ. unfold Int.modulus. unfold Int.wordsize. unfold Wordsize_32.wordsize. + pose proof (uwordToZ_bound (vword v)). + rewrite Z.mod_small. rewrite <- H. rewrite ZToWord_uwordToZ. destruct v; auto. + rewrite <- H. rewrite two_power_nat_equiv. apply H0. +Qed. + +Lemma ptrToValue_valueToPtr : + forall v, + vsize v = 32%nat -> + ptrToValue (valueToPtr v) = v. +Proof. + intros. unfold valueToPtr, ptrToValue. rewrite Ptrofs.unsigned_repr_eq. + unfold ZToValue, uvalueToZ. unfold Ptrofs.modulus. unfold Ptrofs.wordsize. unfold Wordsize_Ptrofs.wordsize. + pose proof (uwordToZ_bound (vword v)). + rewrite Z.mod_small. rewrite <- H. rewrite ZToWord_uwordToZ. destruct v; auto. + rewrite <- H. rewrite two_power_nat_equiv. apply H0. +Qed. + Lemma valToValue_lessdef : forall v v', valToValue v = Some v' -> @@ -391,6 +435,10 @@ Proof. destruct v; try discriminate; constructor. unfold valToValue in H. inversion H. symmetry. apply valueToInt_intToValue. + inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0); try discriminate. + inv H1. symmetry. apply valueToPtr_ptrToValue. + inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0) eqn:?; try discriminate. + inv H1. apply Z.eqb_eq. apply Heqb0. Qed. Lemma boolToValue_ValueToBool : @@ -418,6 +466,17 @@ Proof. rewrite ZToWord_plus; auto. Qed. +Lemma zadd_vplus3 : + forall w1 w2, + (wordToN w1 + wordToN w2 < Npow2 32)%N -> + valueToN (vplus (mkvalue 32 w1) (mkvalue 32 w2) eq_refl) = + (valueToN (mkvalue 32 w1) + valueToN (mkvalue 32 w2))%N. +Proof. + intros. unfold vplus, map_word2. rewrite unify_word_unfold. unfold valueToN. + simplify. unfold wplus. unfold wordBin. Search wordToN NToWord. + rewrite wordToN_NToWord_2. trivial. assumption. +Qed. + Lemma wordsize_32 : Int.wordsize = 32%nat. Proof. auto. Qed. @@ -431,6 +490,24 @@ Proof. rewrite Int.repr_unsigned. auto. rewrite wordsize_32. omega. Qed. +Lemma intadd_vplus2 : + forall v1 v2 EQ, + Int.add (valueToInt v1) (valueToInt v2) = valueToInt (vplus v1 v2 EQ). +Proof. + intros. unfold Int.add, valueToInt, intToValue. repeat (rewrite Int.unsigned_repr). + rewrite zadd_vplus3. trivial. + +Lemma valadd_vplus : + forall v1 v2 v1' v2' v v' EQ, + val_value_lessdef v1 v1' -> + val_value_lessdef v2 v2' -> + Val.add v1 v2 = v -> + vplus v1' v2' EQ = v' -> + val_value_lessdef v v'. +Proof. + intros. inv H; inv H0; constructor; simplify. + - + Lemma zsub_vminus : forall sz z1 z2, (sz > 0)%nat -> -- cgit From 2fa04589bc1e2404235e95ca272fc403c7234fa4 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 3 Jul 2020 12:58:21 +0100 Subject: Addition to int_add_v2 --- src/verilog/Value.v | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/verilog/Value.v b/src/verilog/Value.v index 23ce0f7..b80b614 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -473,7 +473,7 @@ Lemma zadd_vplus3 : (valueToN (mkvalue 32 w1) + valueToN (mkvalue 32 w2))%N. Proof. intros. unfold vplus, map_word2. rewrite unify_word_unfold. unfold valueToN. - simplify. unfold wplus. unfold wordBin. Search wordToN NToWord. + simplify. unfold wplus. unfold wordBin. rewrite wordToN_NToWord_2. trivial. assumption. Qed. @@ -490,12 +490,22 @@ Proof. rewrite Int.repr_unsigned. auto. rewrite wordsize_32. omega. Qed. +Lemma vadd_vplus : + forall v1 v2 EQ, + uvalueToZ v1 + uvalueToZ v2 = uvalueToZ (vplus v1 v2 EQ). +Proof. + Admitted. + Lemma intadd_vplus2 : forall v1 v2 EQ, + vsize v1 = 32%nat -> Int.add (valueToInt v1) (valueToInt v2) = valueToInt (vplus v1 v2 EQ). Proof. intros. unfold Int.add, valueToInt, intToValue. repeat (rewrite Int.unsigned_repr). - rewrite zadd_vplus3. trivial. + rewrite (@vadd_vplus v1 v2 EQ). trivial. + unfold uvalueToZ. Search word "bound". pose proof (@uwordToZ_bound (vsize v2) (vword v2)). + rewrite H in EQ. rewrite <- EQ in H0. + (*rewrite zadd_vplus3. trivia*) Lemma valadd_vplus : forall v1 v2 v1' v2' v v' EQ, @@ -506,7 +516,7 @@ Lemma valadd_vplus : val_value_lessdef v v'. Proof. intros. inv H; inv H0; constructor; simplify. - - + Abort. Lemma zsub_vminus : forall sz z1 z2, -- cgit From b5144a6f513c5c6e3344dcc935117706637ddd3f Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 3 Jul 2020 18:47:56 +0100 Subject: Add new value type to fix Iop proof --- src/translation/HTLgen.v | 4 +- src/verilog/AssocMap.v | 4 +- src/verilog/Value.v | 23 ++----- src/verilog/ValueInt.v | 160 +++++++++++++++++++++++++++++++++++++++++++++++ src/verilog/Verilog.v | 93 ++++++++++++++------------- 5 files changed, 217 insertions(+), 67 deletions(-) create mode 100644 src/verilog/ValueInt.v diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index a2b77e6..f58c9ae 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -19,7 +19,7 @@ From compcert Require Import Maps. From compcert Require Errors Globalenvs Integers. From compcert Require Import AST RTL. -From coqup Require Import Verilog HTL Coquplib AssocMap Value Statemonad. +From coqup Require Import Verilog HTL Coquplib AssocMap ValueInt Statemonad. Hint Resolve AssocMap.gempty : htlh. Hint Resolve AssocMap.gso : htlh. @@ -88,7 +88,7 @@ Import HTLMonadExtra. Export MonadNotation. Definition state_goto (st : reg) (n : node) : stmnt := - Vnonblock (Vvar st) (Vlit (posToValue 32 n)). + Vnonblock (Vvar st) (Vlit (posToValue n)). Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : stmnt := Vnonblock (Vvar st) (Vternary c (posToExpr 32 n1) (posToExpr 32 n2)). diff --git a/src/verilog/AssocMap.v b/src/verilog/AssocMap.v index 5d531d5..c5cfa3f 100644 --- a/src/verilog/AssocMap.v +++ b/src/verilog/AssocMap.v @@ -16,7 +16,7 @@ * along with this program. If not, see . *) -From coqup Require Import Coquplib Value. +From coqup Require Import Coquplib ValueInt. From compcert Require Import Maps. Definition reg := positive. @@ -192,7 +192,7 @@ Import AssocMapExt. Definition assocmap := AssocMap.t value. Definition find_assocmap (n : nat) : reg -> assocmap -> value := - get_default value (ZToValue n 0). + get_default value (ZToValue 0). Definition empty_assocmap : assocmap := AssocMap.empty value. diff --git a/src/verilog/Value.v b/src/verilog/Value.v index b80b614..2718a46 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -466,16 +466,9 @@ Proof. rewrite ZToWord_plus; auto. Qed. -Lemma zadd_vplus3 : - forall w1 w2, - (wordToN w1 + wordToN w2 < Npow2 32)%N -> - valueToN (vplus (mkvalue 32 w1) (mkvalue 32 w2) eq_refl) = - (valueToN (mkvalue 32 w1) + valueToN (mkvalue 32 w2))%N. -Proof. - intros. unfold vplus, map_word2. rewrite unify_word_unfold. unfold valueToN. - simplify. unfold wplus. unfold wordBin. - rewrite wordToN_NToWord_2. trivial. assumption. -Qed. +Lemma ZToValue_eq : + forall w1, + (mkvalue 32 w1) = (ZToValue 32 (wordToZ w1)). Admitted. Lemma wordsize_32 : Int.wordsize = 32%nat. @@ -490,13 +483,7 @@ Proof. rewrite Int.repr_unsigned. auto. rewrite wordsize_32. omega. Qed. -Lemma vadd_vplus : - forall v1 v2 EQ, - uvalueToZ v1 + uvalueToZ v2 = uvalueToZ (vplus v1 v2 EQ). -Proof. - Admitted. - -Lemma intadd_vplus2 : +(*Lemma intadd_vplus2 : forall v1 v2 EQ, vsize v1 = 32%nat -> Int.add (valueToInt v1) (valueToInt v2) = valueToInt (vplus v1 v2 EQ). @@ -504,7 +491,7 @@ Proof. intros. unfold Int.add, valueToInt, intToValue. repeat (rewrite Int.unsigned_repr). rewrite (@vadd_vplus v1 v2 EQ). trivial. unfold uvalueToZ. Search word "bound". pose proof (@uwordToZ_bound (vsize v2) (vword v2)). - rewrite H in EQ. rewrite <- EQ in H0. + rewrite H in EQ. rewrite <- EQ in H0 at 3.*) (*rewrite zadd_vplus3. trivia*) Lemma valadd_vplus : diff --git a/src/verilog/ValueInt.v b/src/verilog/ValueInt.v new file mode 100644 index 0000000..cc1d404 --- /dev/null +++ b/src/verilog/ValueInt.v @@ -0,0 +1,160 @@ +(* + * CoqUp: Verified high-level synthesis. + * Copyright (C) 2020 Yann Herklotz + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) + +(* begin hide *) +From bbv Require Import Word. +From bbv Require HexNotation WordScope. +From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia. +From compcert Require Import lib.Integers common.Values. +From coqup Require Import Coquplib. +(* end hide *) + +(** * Value + +A [value] is a bitvector with a specific size. We are using the implementation +of the bitvector by mit-plv/bbv, because it has many theorems that we can reuse. +However, we need to wrap it with an [Inductive] so that we can specify and match +on the size of the [value]. This is necessary so that we can easily store +[value]s of different sizes in a list or in a map. + +Using the default [word], this would not be possible, as the size is part of the type. *) + +Definition value : Type := int. + +(** ** Value conversions + +Various conversions to different number types such as [N], [Z], [positive] and +[int], where the last one is a theory of integers of powers of 2 in CompCert. *) + +Definition valueToNat (v : value) : nat := + Z.to_nat (Int.unsigned v). + +Definition natToValue (n : nat) : value := + Int.repr (Z.of_nat n). + +Definition valueToN (v : value) : N := + Z.to_N (Int.unsigned v). + +Definition NToValue (n : N) : value := + Int.repr (Z.of_N n). + +Definition ZToValue (z : Z) : value := + Int.repr z. + +Definition valueToZ (v : value) : Z := + Int.signed v. + +Definition uvalueToZ (v : value) : Z := + Int.unsigned v. + +Definition posToValue (p : positive) : value := + Int.repr (Z.pos p). + +Definition valueToPos (v : value) : positive := + Z.to_pos (Int.unsigned v). + +Definition intToValue (i : Integers.int) : value := i. + +Definition valueToInt (i : value) : Integers.int := i. + +Definition ptrToValue (i : ptrofs) : value := Ptrofs.to_int i. + +Definition valueToPtr (i : value) : Integers.ptrofs := + Ptrofs.of_int i. + +Search Ptrofs.of_int Ptrofs.to_int. +Definition valToValue (v : Values.val) : option value := + match v with + | Values.Vint i => Some (intToValue i) + | Values.Vptr b off => if Z.eqb (Z.modulo (uvalueToZ (ptrToValue off)) 4) 0%Z + then Some (ptrToValue off) + else None + | Values.Vundef => Some (ZToValue 0%Z) + | _ => None + end. + +(** Convert a [value] to a [bool], so that choices can be made based on the +result. This is also because comparison operators will give back [value] instead +of [bool], so if they are in a condition, they will have to be converted before +they can be used. *) + +Definition valueToBool (v : value) : bool := + if Z.eqb (uvalueToZ v) 0 then true else false. + +Definition boolToValue (b : bool) : value := + natToValue (if b then 1 else 0). + +(** ** Arithmetic operations *) + +Definition unify_word (sz1 sz2 : nat) (w1 : word sz2): sz1 = sz2 -> word sz1. +intros; subst; assumption. Defined. + +Lemma unify_word_unfold : + forall sz w, + unify_word sz sz w eq_refl = w. +Proof. auto. Qed. + +Inductive val_value_lessdef: val -> value -> Prop := +| val_value_lessdef_int: + forall i v', + i = valueToInt v' -> + val_value_lessdef (Vint i) v' +| val_value_lessdef_ptr: + forall b off v', + off = valueToPtr v' -> + (Z.modulo (uvalueToZ v') 4) = 0%Z -> + val_value_lessdef (Vptr b off) v' +| lessdef_undef: forall v, val_value_lessdef Vundef v. + +Inductive opt_val_value_lessdef: option val -> value -> Prop := +| opt_lessdef_some: + forall v v', val_value_lessdef v v' -> opt_val_value_lessdef (Some v) v' +| opt_lessdef_none: forall v, opt_val_value_lessdef None v. + +Lemma valueToZ_ZToValue : + forall z, + (Int.min_signed <= z <= Int.max_signed)%Z -> + valueToZ (ZToValue z) = z. +Proof. auto using Int.signed_repr. Qed. + +Lemma uvalueToZ_ZToValue : + forall z, + (0 <= z <= Int.max_unsigned)%Z -> + uvalueToZ (ZToValue z) = z. +Proof. auto using Int.unsigned_repr. Qed. + +Lemma valToValue_lessdef : + forall v v', + valToValue v = Some v' -> + val_value_lessdef v v'. +Proof. + intros. + destruct v; try discriminate; constructor. + unfold valToValue in H. inversion H. + unfold valueToInt. unfold intToValue in H1. auto. + inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0); try discriminate. + inv H1. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial. + inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0) eqn:?; try discriminate. + inv H1. apply Z.eqb_eq. apply Heqb0. +Qed. + +Local Open Scope Z. + +Ltac word_op_value H := + intros; unfold uvalueToZ, ZToValue; simpl; rewrite unify_word_unfold; + rewrite <- H; rewrite uwordToZ_ZToWord_full; auto; omega. diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 555ddbd..5ef4dda 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -29,11 +29,9 @@ Require Import Lia. Import ListNotations. -From coqup Require Import common.Coquplib common.Show verilog.Value AssocMap Array. -From compcert Require Integers Events. -From compcert Require Import Errors Smallstep Globalenvs. - -Import HexNotationValue. +From coqup Require Import common.Coquplib common.Show verilog.ValueInt AssocMap Array. +From compcert Require Events. +From compcert Require Import Integers Errors Smallstep Globalenvs. Local Open Scope assocmap. @@ -80,7 +78,7 @@ Definition merge_arrs (new : assocmap_arr) (old : assocmap_arr) : assocmap_arr : Definition arr_assocmap_lookup (a : assocmap_arr) (r : reg) (i : nat) : option value := match a ! r with | None => None - | Some arr => Some (Option.default (NToValue 32 0) (Option.join (array_get_error i arr))) + | Some arr => Some (Option.default (NToValue 0) (Option.join (array_get_error i arr))) end. Definition arr_assocmap_set (r : reg) (i : nat) (v : value) (a : assocmap_arr) : assocmap_arr := @@ -164,8 +162,8 @@ Inductive expr : Type := | Vunop : unop -> expr -> expr | Vternary : expr -> expr -> expr -> expr. -Definition posToExpr (sz : nat) (p : positive) : expr := - Vlit (posToValue sz p). +Definition posToExpr (p : positive) : expr := + Vlit (posToValue p). (** ** Statements *) @@ -245,7 +243,7 @@ Definition program := AST.program fundef unit. (** Convert a [positive] to an expression directly, setting it to the right size. *) Definition posToLit (p : positive) : expr := - Vlit (posToValueAuto p). + Vlit (posToValue p). Coercion Vlit : value >-> expr. Coercion Vvar : reg >-> expr. @@ -298,37 +296,43 @@ Inductive state : Type := (m : module) (args : list value), state. -Definition binop_run (op : binop) : forall v1 v2 : value, vsize v1 = vsize v2 -> value := +Definition binop_run (op : binop) (v1 v2 : value) : option value := match op with - | Vadd => vplus - | Vsub => vminus - | Vmul => vmul - | Vdiv => vdivs - | Vdivu => vdiv - | Vmod => vmods - | Vmodu => vmod - | Vlt => vlts - | Vltu => vlt - | Vgt => vgts - | Vgtu => vgt - | Vle => vles - | Vleu => vle - | Vge => vges - | Vgeu => vge - | Veq => veq - | Vne => vne - | Vand => vand - | Vor => vor - | Vxor => vxor - | Vshl => vshl - | Vshr => vshr - | Vshru => vshr (* FIXME: should not be the same operation. *) + | Vadd => Some (Int.add v1 v2) + | Vsub => Some (Int.sub v1 v2) + | Vmul => Some (Int.mul v1 v2) + | Vdiv => if Int.eq v2 Int.zero + || Int.eq v1 (Int.repr Int.min_signed) && Int.eq v2 Int.mone + then None + else Some (Int.divs v1 v2) + | Vdivu => if Int.eq v2 Int.zero then None else Some (Int.divu v1 v2) + | Vmod => if Int.eq v2 Int.zero + || Int.eq v1 (Int.repr Int.min_signed) && Int.eq v2 Int.mone + then None + else Some (Int.mods v1 v2) + | Vmodu => if Int.eq v2 Int.zero then None else Some (Int.modu v1 v2) + | Vlt => Some (boolToValue (Int.lt v1 v2)) + | Vltu => Some (boolToValue (Int.ltu v1 v2)) + | Vgt => Some (boolToValue (Int.lt v2 v1)) + | Vgtu => Some (boolToValue (Int.ltu v2 v1)) + | Vle => Some (boolToValue (negb (Int.lt v2 v1))) + | Vleu => Some (boolToValue (negb (Int.ltu v2 v1))) + | Vge => Some (boolToValue (negb (Int.lt v1 v2))) + | Vgeu => Some (boolToValue (negb (Int.ltu v1 v2))) + | Veq => Some (boolToValue (Int.eq v1 v2)) + | Vne => Some (boolToValue (negb (Int.eq v1 v2))) + | Vand => Some (Int.and v1 v2) + | Vor => Some (Int.or v1 v2) + | Vxor => Some (Int.xor v1 v2) + | Vshl => Some (Int.shl v1 v2) + | Vshr => Some (Int.shr v1 v2) + | Vshru => Some (Int.shru v1 v2) end. -Definition unop_run (op : unop) : value -> value := +Definition unop_run (op : unop) (v1 : value) : value := match op with - | Vneg => vnot - | Vnot => vbitneg + | Vneg => Int.notbool v1 + | Vnot => Int.not v1 end. Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop := @@ -349,11 +353,10 @@ Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop fext!r = Some v -> expr_runp fext reg stack (Vinputvar r) v | erun_Vbinop : - forall fext reg stack op l r lv rv oper EQ resv, + forall fext reg stack op l r lv rv resv, expr_runp fext reg stack l lv -> expr_runp fext reg stack r rv -> - oper = binop_run op -> - resv = oper lv rv EQ -> + Some resv = binop_run op lv rv -> expr_runp fext reg stack (Vbinop op l r) resv | erun_Vunop : forall fext reg stack u vu op oper resv, @@ -394,7 +397,7 @@ Local Open Scope error_monad_scope. Definition access_fext (f : fext) (r : reg) : res value := match AssocMap.get r f with | Some v => OK v - | _ => OK (ZToValue 1 0) + | _ => OK (ZToValue 0) end. (* TODO FIX Vvar case without default *) @@ -652,8 +655,8 @@ other arguments to the module are also to be supported. *) Definition initial_fextclk (m : module) : fextclk := fun x => match x with - | S O => (AssocMap.set (mod_reset m) (ZToValue 1 1) empty_assocmap) - | _ => (AssocMap.set (mod_reset m) (ZToValue 1 0) empty_assocmap) + | S O => (AssocMap.set (mod_reset m) (ZToValue 1) empty_assocmap) + | _ => (AssocMap.set (mod_reset m) (ZToValue 0) empty_assocmap) end. (*Definition module_run (n : nat) (m : module) : res assocmap := @@ -727,21 +730,21 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') | step_finish : forall asr asa sf retval m st g, - asr!(m.(mod_finish)) = Some (1'h"1") -> + asr!(m.(mod_finish)) = Some (ZToValue 1) -> asr!(m.(mod_return)) = Some retval -> step g (State sf m st asr asa) Events.E0 (Returnstate sf retval) | step_call : forall g res m args, step g (Callstate res m args) Events.E0 (State res m m.(mod_entrypoint) - (AssocMap.set m.(mod_st) (posToValue 32 m.(mod_entrypoint)) + (AssocMap.set m.(mod_st) (posToValue m.(mod_entrypoint)) (init_params args m.(mod_args))) (empty_stack m)) | step_return : forall g m asr i r sf pc mst asa, mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 - (State sf m pc ((asr # mst <- (posToValue 32 pc)) # r <- i) + (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) (empty_stack m)). Hint Constructors step : verilog. -- cgit From 594c2825012d94675317f51cf6a3e97c2f88cd02 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 3 Jul 2020 21:05:45 +0100 Subject: Fixing HTLgenproof --- src/translation/HTLgen.v | 22 ++++++++++----------- src/translation/HTLgenproof.v | 45 ++++++++++++++++++++++++++++++------------- src/translation/HTLgenspec.v | 8 ++++---- src/verilog/HTL.v | 10 ++++------ src/verilog/ValueInt.v | 21 ++++++++++++++------ src/verilog/Verilog.v | 2 +- 6 files changed, 67 insertions(+), 41 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index f58c9ae..1977f65 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -91,7 +91,7 @@ Definition state_goto (st : reg) (n : node) : stmnt := Vnonblock (Vvar st) (Vlit (posToValue n)). Definition state_cond (st : reg) (c : expr) (n1 n2 : node) : stmnt := - Vnonblock (Vvar st) (Vternary c (posToExpr 32 n1) (posToExpr 32 n2)). + Vnonblock (Vvar st) (Vternary c (posToExpr n1) (posToExpr n2)). Definition check_empty_node_datapath: forall (s: state) (n: node), { s.(st_datapath)!n = None } + { True }. @@ -244,7 +244,7 @@ Definition boplit (op : binop) (r : reg) (l : Integers.int) : expr := Vbinop op (Vvar r) (Vlit (intToValue l)). Definition boplitz (op: binop) (r: reg) (l: Z) : expr := - Vbinop op (Vvar r) (Vlit (ZToValue 32%nat l)). + Vbinop op (Vvar r) (Vlit (ZToValue l)). Definition translate_comparison (c : Integers.comparison) (args : list reg) : mon expr := match c, args with @@ -297,7 +297,7 @@ Definition translate_eff_addressing (a: Op.addressing) (args: list reg) : mon ex else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed): address misaligned") | Op.Ascaled scale offset, r1::nil => if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue 32 offset))) + then ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue offset))) else error (Errors.msg "Veriloggen: translate_eff_addressing (Ascaled): address misaligned") | Op.Aindexed2 offset, r1::r2::nil => if (check_address_parameter_signed offset) @@ -310,7 +310,7 @@ Definition translate_eff_addressing (a: Op.addressing) (args: list reg) : mon ex | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) let a := Integers.Ptrofs.unsigned a in if (check_address_parameter_unsigned a) - then ret (Vlit (ZToValue 32 a)) + then ret (Vlit (ZToValue a)) else error (Errors.msg "Veriloggen: translate_eff_addressing (Ainstack): address misaligned") | _, _ => error (Errors.msg "Veriloggen: translate_eff_addressing unsuported addressing") end. @@ -342,7 +342,7 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr := | Op.Oshr, r1::r2::nil => ret (bop Vshr r1 r2) | Op.Oshrimm n, r::nil => ret (boplit Vshr r n) | Op.Oshrximm n, r::nil => ret (Vbinop Vdiv (Vvar r) - (Vbinop Vshl (Vlit (ZToValue 32 1)) + (Vbinop Vshl (Vlit (ZToValue 1)) (Vlit (intToValue n)))) | Op.Oshru, r1::r2::nil => ret (bop Vshru r1 r2) | Op.Oshruimm n, r::nil => ret (boplit Vshru r n) @@ -395,19 +395,19 @@ Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing) match mem, addr, args with (* TODO: We should be more methodical here; what are the possibilities?*) | Mint32, Op.Aindexed off, r1::nil => if (check_address_parameter_signed off) - then ret (Vvari stack (Vbinop Vdivu (boplitz Vadd r1 off) (Vlit (ZToValue 32 4)))) + then ret (Vvari stack (Vbinop Vdivu (boplitz Vadd r1 off) (Vlit (ZToValue 4)))) else error (Errors.msg "HTLgen: translate_arr_access address misaligned") | Mint32, Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) then ret (Vvari stack (Vbinop Vdivu (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) - (ZToValue 32 4))) + (ZToValue 4))) else error (Errors.msg "HTLgen: translate_arr_access address misaligned") | Mint32, Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) let a := Integers.Ptrofs.unsigned a in if (check_address_parameter_unsigned a) - then ret (Vvari stack (Vlit (ZToValue 32 (a / 4)))) + then ret (Vvari stack (Vlit (ZToValue (a / 4)))) else error (Errors.msg "HTLgen: eff_addressing misaligned stack offset") | _, _, _ => error (Errors.msg "HTLgen: translate_arr_access unsuported addressing") end. @@ -420,7 +420,7 @@ Fixpoint enumerate (i : nat) (ns : list node) {struct ns} : list (nat * node) := Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) := List.map (fun a => match a with - (i, n) => (Vlit (natToValue 32 i), Vnonblock (Vvar st) (Vlit (posToValue 32 n))) + (i, n) => (Vlit (natToValue i), Vnonblock (Vvar st) (Vlit (posToValue n))) end) (enumerate 0 ns). @@ -452,9 +452,9 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni | Ireturn r => match r with | Some r' => - add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%nat 1%Z))) (block rtrn (Vvar r'))) + add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r'))) | None => - add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%nat 1%Z))) (block rtrn (Vlit (ZToValue 1%nat 0%Z)))) + add_instr_skip n (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vlit (ZToValue 0%Z)))) end end end. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 956c3ed..79bca49 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -16,9 +16,9 @@ * along with this program. If not, see . *) -From compcert Require RTL Registers AST Integers. -From compcert Require Import Globalenvs Memory. -From coqup Require Import Coquplib HTLgenspec HTLgen Value AssocMap Array IntegerExtra ZExtra. +From compcert Require RTL Registers AST. +From compcert Require Import Integers Globalenvs Memory. +From coqup Require Import Coquplib HTLgenspec HTLgen ValueInt AssocMap Array IntegerExtra ZExtra. From coqup Require HTL Verilog. Require Import Lia. @@ -41,7 +41,7 @@ Hint Constructors match_assocmaps : htlproof. Definition state_st_wf (m : HTL.module) (s : HTL.state) := forall st asa asr res, s = HTL.State res m st asa asr -> - asa!(m.(HTL.mod_st)) = Some (posToValue 32 st). + asa!(m.(HTL.mod_st)) = Some (posToValue st). Hint Unfold state_st_wf : htlproof. Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : mem) : @@ -53,7 +53,7 @@ Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem 0 <= ptr < Z.of_nat m.(HTL.mod_stk_len) -> opt_val_value_lessdef (Mem.loadv AST.Mint32 mem (Values.Val.offset_ptr sp (Integers.Ptrofs.repr (4 * ptr)))) - (Option.default (NToValue 32 0) + (Option.default (NToValue 0) (Option.join (array_get_error (Z.to_nat ptr) stack)))) -> match_arrs m f sp mem asa. @@ -254,12 +254,6 @@ Proof. assumption. Qed. -(* Need to eventually move posToValue 32 to posToValueAuto, as that has this proof. *) -Lemma assumption_32bit : - forall v, - valueToPos (posToValue 32 v) = v. -Admitted. - Ltac inv_state := match goal with MSTATE : match_states _ _ |- _ => @@ -358,6 +352,14 @@ Section CORRECTNESS. (Genv.senv_transf_partial TRANSL'). Hint Resolve senv_preserved : htlproof. + Lemma ptrofs_inj : + forall a b, + Ptrofs.unsigned a = Ptrofs.unsigned b -> a = b. + Proof. + intros. rewrite <- Ptrofs.repr_unsigned. symmetry. rewrite <- Ptrofs.repr_unsigned. + rewrite H. auto. + Qed. + Lemma eval_correct : forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> @@ -373,12 +375,29 @@ Section CORRECTNESS. - inv Heql. assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). apply H in HPle. eexists. split; try constructor; eauto. - - eexists. split. constructor. constructor. symmetry. apply valueToInt_intToValue. + - eexists. split. constructor. constructor. auto. - inv Heql. assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). apply H in HPle. eexists. split. econstructor; eauto. constructor. trivial. - unfold Verilog.unop_run. + unfold Verilog.unop_run. unfold Values.Val.neg. destruct (Registers.Regmap.get r rs) eqn:?; constructor. + inv HPle. auto. + - inv Heql. + assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + assert (HPle0 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + apply H in HPle. apply H in HPle0. + eexists. split. econstructor; eauto. constructor. trivial. + constructor. trivial. simplify. inv HPle. inv HPle0; constructor; auto. + + inv HPle0. constructor. unfold valueToPtr. Search Integers.Ptrofs.sub Integers.int. + pose proof Integers.Ptrofs.agree32_sub. unfold Integers.Ptrofs.agree32 in H3. + Print Integers.Ptrofs.agree32. unfold Ptrofs.of_int. simpl. + apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H3 in H4. + rewrite Ptrofs.unsigned_repr. apply H4. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + apply Int.unsigned_range_2. + auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. + replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + apply Int.unsigned_range_2. Lemma eval_cond_correct : forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index d2bd5af..799b198 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -18,7 +18,7 @@ From compcert Require RTL Op Maps Errors. From compcert Require Import Maps. -From coqup Require Import Coquplib Verilog Value HTL HTLgen AssocMap. +From coqup Require Import Coquplib Verilog ValueInt HTL HTLgen AssocMap. Require Import Lia. Hint Resolve Maps.PTree.elements_keys_norepet : htlspec. @@ -127,12 +127,12 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - translate_condition cond args s = OK c s' i -> tr_instr fin rtrn st stk (RTL.Icond cond args n1 n2) Vskip (state_cond st c n1 n2) | tr_instr_Ireturn_None : - tr_instr fin rtrn st stk (RTL.Ireturn None) (Vseq (block fin (Vlit (ZToValue 1%nat 1%Z))) - (block rtrn (Vlit (ZToValue 1%nat 0%Z)))) Vskip + tr_instr fin rtrn st stk (RTL.Ireturn None) (Vseq (block fin (Vlit (ZToValue 1%Z))) + (block rtrn (Vlit (ZToValue 0%Z)))) Vskip | tr_instr_Ireturn_Some : forall r, tr_instr fin rtrn st stk (RTL.Ireturn (Some r)) - (Vseq (block fin (Vlit (ZToValue 1%nat 1%Z))) (block rtrn (Vvar r))) Vskip + (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r))) Vskip | tr_instr_Iload : forall mem addr args s s' i c dst n, translate_arr_access mem addr args stk s = OK c s' i -> diff --git a/src/verilog/HTL.v b/src/verilog/HTL.v index a3623f0..df88f98 100644 --- a/src/verilog/HTL.v +++ b/src/verilog/HTL.v @@ -17,13 +17,11 @@ *) From Coq Require Import FSets.FMapPositive. -From coqup Require Import Coquplib Value AssocMap Array. +From coqup Require Import Coquplib ValueInt AssocMap Array. From coqup Require Verilog. From compcert Require Events Globalenvs Smallstep Integers Values. From compcert Require Import Maps. -Import HexNotationValue. - (** The purpose of the hardware transfer language (HTL) is to create a more hardware-like layout that is still similar to the register transfer language (RTL) that it came from. The main change is that function calls become module @@ -128,21 +126,21 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') | step_finish : forall g m st asr asa retval sf, - asr!(m.(mod_finish)) = Some (1'h"1") -> + asr!(m.(mod_finish)) = Some (ZToValue 1) -> asr!(m.(mod_return)) = Some retval -> step g (State sf m st asr asa) Events.E0 (Returnstate sf retval) | step_call : forall g m args res, step g (Callstate res m args) Events.E0 (State res m m.(mod_entrypoint) - (AssocMap.set (mod_st m) (posToValue 32 m.(mod_entrypoint)) + (AssocMap.set (mod_st m) (posToValue m.(mod_entrypoint)) (init_regs args m.(mod_params))) (empty_stack m)) | step_return : forall g m asr asa i r sf pc mst, mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 - (State sf m pc ((asr # mst <- (posToValue 32 pc)) # r <- i) asa). + (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). Hint Constructors step : htl. Inductive initial_state (p: program): state -> Prop := diff --git a/src/verilog/ValueInt.v b/src/verilog/ValueInt.v index cc1d404..dff7b5c 100644 --- a/src/verilog/ValueInt.v +++ b/src/verilog/ValueInt.v @@ -138,6 +138,21 @@ Lemma uvalueToZ_ZToValue : uvalueToZ (ZToValue z) = z. Proof. auto using Int.unsigned_repr. Qed. +Lemma valueToPos_posToValue : + forall v, + 0 <= Z.pos v <= Int.max_unsigned -> + valueToPos (posToValue v) = v. +Proof. + unfold valueToPos, posToValue. + intros. rewrite Int.unsigned_repr. + apply Pos2Z.id. assumption. +Qed. + +Lemma valueToInt_intToValue : + forall v, + valueToInt (intToValue v) = v. +Proof. auto. Qed. + Lemma valToValue_lessdef : forall v v', valToValue v = Some v' -> @@ -152,9 +167,3 @@ Proof. inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0) eqn:?; try discriminate. inv H1. apply Z.eqb_eq. apply Heqb0. Qed. - -Local Open Scope Z. - -Ltac word_op_value H := - intros; unfold uvalueToZ, ZToValue; simpl; rewrite unify_word_unfold; - rewrite <- H; rewrite uwordToZ_ZToWord_full; auto; omega. diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 5ef4dda..f5916ad 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -331,7 +331,7 @@ Definition binop_run (op : binop) (v1 v2 : value) : option value := Definition unop_run (op : unop) (v1 : value) : value := match op with - | Vneg => Int.notbool v1 + | Vneg => Int.neg v1 | Vnot => Int.not v1 end. -- cgit From 5a376f41865947da3739e6321a560b752a4b099b Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sat, 4 Jul 2020 11:18:35 +0100 Subject: Make HTLgen compile again --- src/translation/HTLgenproof.v | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 79bca49..82d4cfc 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -87,6 +87,12 @@ Inductive match_frames : list RTL.stackframe -> list HTL.stackframe -> Prop := | match_frames_nil : match_frames nil nil. + Lemma assumption_32bit : + forall v, + valueToPos (posToValue v) = v. + Proof. + Admitted. + Inductive match_states : RTL.state -> HTL.state -> Prop := | match_state : forall asa asr sf f sp sp' rs mem m st res (MASSOC : match_assocmaps f rs asr) @@ -336,6 +342,7 @@ Section CORRECTNESS. intros (cu & tf & P & Q & R); exists tf; auto. Qed. + Lemma functions_translated: forall (v: Values.val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> @@ -398,6 +405,7 @@ Section CORRECTNESS. apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. apply Int.unsigned_range_2. + Admitted. Lemma eval_cond_correct : forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, @@ -406,7 +414,7 @@ Section CORRECTNESS. cond (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some b -> - Verilog.expr_runp f asr asa c (boolToValue 32 b). + Verilog.expr_runp f asr asa c (boolToValue b). Admitted. (** The proof of semantic preservation for the translation of instructions @@ -436,7 +444,7 @@ Section CORRECTNESS. Ltac tac0 := match goal with - | [ |- context[valueToPos (posToValue 32 _)] ] => rewrite assumption_32bit + | [ |- context[valueToPos (posToValue _)] ] => rewrite assumption_32bit | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr @@ -456,7 +464,7 @@ Section CORRECTNESS. | [ |- state_st_wf _ _ ] => unfold state_st_wf; inversion 1 | [ |- context[match_states _ _] ] => econstructor; auto | [ |- match_arrs _ _ _ _ _ ] => econstructor; auto - | [ |- match_assocmaps _ _ _ # _ <- (posToValue 32 _) ] => + | [ |- match_assocmaps _ _ _ # _ <- (posToValue _) ] => apply regs_lessdef_add_greater; [> unfold Plt; lia | assumption] | [ H : ?asa ! ?r = Some _ |- Verilog.arr_assocmap_lookup ?asa ?r _ = Some _ ] => -- cgit From 03c27a57e81b61d02be2209ee9b5ca5f14b97b6a Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sat, 4 Jul 2020 16:04:50 +0100 Subject: Define ofbytes --- src/common/IntegerExtra.v | 73 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 72 insertions(+), 1 deletion(-) diff --git a/src/common/IntegerExtra.v b/src/common/IntegerExtra.v index dcaf3a1..fe7d94f 100644 --- a/src/common/IntegerExtra.v +++ b/src/common/IntegerExtra.v @@ -199,7 +199,7 @@ Ltac ptrofs := end. Module IntExtra. - + Import Int. Ltac int_mod_match m := match goal with | [ H : ?x = 0 |- context[?x] ] => rewrite H @@ -291,4 +291,75 @@ Module IntExtra. rewrite <- Zmod_div_mod; try lia; try assumption end; try (crush; lia); int_mod_tac m. Qed. + + Definition ofbytes (a b c d : byte) : int := + or (shl (repr (Byte.unsigned a)) (repr (3 * Byte.zwordsize))) + (or (shl (repr (Byte.unsigned b)) (repr (2 * Byte.zwordsize))) + (or (shl (repr (Byte.unsigned c)) (repr Byte.zwordsize)) + (repr (Byte.unsigned d)))). + + Definition byte1 (n: int) : byte := Byte.repr (unsigned n). + + Definition byte2 (n: int) : byte := Byte.repr (unsigned (shru n (repr Byte.zwordsize))). + + Definition byte3 (n: int) : byte := Byte.repr (unsigned (shru n (repr (2 * Byte.zwordsize)))). + + Definition byte4 (n: int) : byte := Byte.repr (unsigned (shru n (repr (3 * Byte.zwordsize)))). + + Lemma bits_byte1: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte1 n) i = testbit n i. + Proof. + intros. unfold byte1. rewrite Byte.testbit_repr; auto. + Qed. + + Lemma bits_byte2: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte2 n) i = testbit n (i + Byte.zwordsize). + Proof. + intros. unfold byte2. rewrite Byte.testbit_repr; auto. + assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. + fold (testbit (shru n (repr Byte.zwordsize)) i). rewrite bits_shru. + change (unsigned (repr Byte.zwordsize)) with Byte.zwordsize. + apply zlt_true. omega. omega. + Qed. + + Lemma bits_byte3: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte3 n) i = testbit n (i + (2 * Byte.zwordsize)). + Proof. + intros. unfold byte3. rewrite Byte.testbit_repr; auto. + assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. + fold (testbit (shru n (repr (2 * Byte.zwordsize))) i). rewrite bits_shru. + change (unsigned (repr (2 * Byte.zwordsize))) with (2 * Byte.zwordsize). + apply zlt_true. omega. omega. + Qed. + + Lemma bits_byte4: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte4 n) i = testbit n (i + (3 * Byte.zwordsize)). + Proof. + intros. unfold byte4. rewrite Byte.testbit_repr; auto. + assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. + fold (testbit (shru n (repr (3 * Byte.zwordsize))) i). rewrite bits_shru. + change (unsigned (repr (3 * Byte.zwordsize))) with (3 * Byte.zwordsize). + apply zlt_true. omega. omega. + Qed. + + Lemma bits_ofwords: + forall b4 b3 b2 b1 i, 0 <= i < zwordsize -> + testbit (ofbytes b4 b3 b2 b1) i = + if zlt i Byte.zwordsize + then Byte.testbit b1 i + else (if zlt i (2 * Byte.zwordsize) + then Byte.testbit b2 (i - Byte.zwordsize) + else (if zlt i (3 * Byte.zwordsize) + then Byte.testbit b2 (i - 2 * Byte.zwordsize) + else Byte.testbit b2 (i - 3 * Byte.zwordsize))). + Proof. + intros. unfold ofbytes. repeat (rewrite bits_or; auto). repeat (rewrite bits_shl; auto). + change (unsigned (repr Byte.zwordsize)) with Byte.zwordsize. + change (unsigned (repr (2 * Byte.zwordsize))) with (2 * Byte.zwordsize). + change (unsigned (repr (3 * Byte.zwordsize))) with (3 * Byte.zwordsize). + assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. + destruct (zlt i Byte.zwordsize). + rewrite testbit_repr; auto. + Abort. + End IntExtra. -- cgit From 7b3cbc141d2f7707351f27f6dadb9a196cfb2ba9 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Sat, 4 Jul 2020 16:12:47 +0100 Subject: Working on determinacy proof. --- src/common/Coquplib.v | 52 +++++++++++++++---- src/verilog/Verilog.v | 135 +++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 175 insertions(+), 12 deletions(-) diff --git a/src/common/Coquplib.v b/src/common/Coquplib.v index 8ad557b..2295ff6 100644 --- a/src/common/Coquplib.v +++ b/src/common/Coquplib.v @@ -34,6 +34,27 @@ From compcert Require Import Integers. Local Open Scope Z_scope. +(* This tactic due to Clement Pit-Claudel with some minor additions by JDP to + allow the result to be named: https://pit-claudel.fr/clement/MSc/#org96a1b5f *) +Inductive Learnt {A: Type} (a: A) := + | AlreadyKnown : Learnt a. + +Ltac learn_tac fact name := + lazymatch goal with + | [ H: Learnt fact |- _ ] => + fail 0 "fact" fact "has already been learnt" + | _ => let type := type of fact in + lazymatch goal with + | [ H: @Learnt type _ |- _ ] => + fail 0 "fact" fact "of type" type "was already learnt through" H + | _ => let learnt := fresh "Learn" in + pose proof (AlreadyKnown fact) as learnt; pose proof fact as name + end + end. + +Tactic Notation "learn" constr(fact) := let name := fresh "H" in learn_tac fact name. +Tactic Notation "learn" constr(fact) "as" simple_intropattern(name) := learn_tac fact name. + Ltac unfold_rec c := unfold c; fold c. Ltac solve_by_inverts n := @@ -51,10 +72,11 @@ Ltac invert x := inversion x; subst; clear x. Ltac destruct_match := match goal with | [ |- context[match ?x with | _ => _ end ] ] => destruct x end. -Ltac clear_obvious := +Ltac nicify_hypotheses := repeat match goal with | [ H : ex _ |- _ ] => invert H | [ H : Some _ = Some _ |- _ ] => invert H + | [ H : ?x = ?x |- _ ] => clear H | [ H : _ /\ _ |- _ ] => invert H end. @@ -131,22 +153,32 @@ Ltac unfold_constants := end end. +Ltac substpp := + repeat match goal with + | [ H1 : ?x = Some _, H2 : ?x = Some _ |- _ ] => + let EQ := fresh "EQ" in + learn H1 as EQ; rewrite H2 in EQ; invert EQ + | _ => idtac + end. + Ltac simplify := intros; unfold_constants; simpl in *; - repeat (clear_obvious; nicify_goals; kill_bools); + repeat (nicify_hypotheses; nicify_goals; kill_bools; substpp); simpl in *. Infix "==nat" := eq_nat_dec (no associativity, at level 50). Infix "==Z" := Z.eq_dec (no associativity, at level 50). Ltac liapp := - match goal with - | [ |- (?x | ?y) ] => - match (eval compute in (Z.rem y x ==Z 0)) with - | left _ => let q := (eval compute in (Z.div y x)) in exists q; reflexivity - | _ => idtac - end - | _ => idtac - end. + repeat match goal with + | [ |- (?x | ?y) ] => + match (eval compute in (Z.rem y x ==Z 0)) with + | left _ => + let q := (eval compute in (Z.div y x)) + in exists q; reflexivity + | _ => idtac + end + | _ => idtac + end. Ltac crush := simplify; try discriminate; try congruence; try lia; liapp; try assumption. diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index f5916ad..3c1b36f 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -522,7 +522,7 @@ Inductive stmnt_runp: fext -> reg_associations -> arr_associations -> forall f st1 st2 asr0 asa0 asr1 asa1 asr2 asa2, stmnt_runp f asr0 asa0 st1 asr1 asa1 -> stmnt_runp f asr1 asa1 st2 asr2 asa2 -> - stmnt_runp f asr0 asa1 (Vseq st1 st2) asr2 asa2 + stmnt_runp f asr0 asa0 (Vseq st1 st2) asr2 asa2 | stmnt_runp_Vcond_true: forall asr0 asa0 asr1 asa1 f c vc stt stf, expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) c vc -> @@ -602,7 +602,7 @@ Inductive mi_stepp : fext -> reg_associations -> arr_associations -> module_item -> reg_associations -> arr_associations -> Prop := | mi_stepp_Valways : forall f sr0 sa0 st sr1 sa1 c, - stmnt_runp f sr0 sa0 st sr1 sa0 -> + stmnt_runp f sr0 sa0 st sr1 sa1 -> mi_stepp f sr0 sa0 (Valways c st) sr1 sa1 | mi_stepp_Valways_ff : forall f sr0 sa0 st sr1 sa1 c, @@ -716,6 +716,7 @@ Definition empty_stack (m : module) : assocmap_arr := Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : forall asr asa asr' asa' basr1 nasr1 basa1 nasa1 f stval pstval m sf st g ist, + asr!(m.(mod_finish)) = Some (ZToValue 0) -> asr!(m.(mod_st)) = Some ist -> valueToPos ist = st -> mis_stepp f (mkassociations asr empty_assocmap) @@ -764,3 +765,133 @@ Inductive final_state : state -> Integers.int -> Prop := Definition semantics (m : program) := Smallstep.Semantics step (initial_state m) final_state (Globalenvs.Genv.globalenv m). + +Lemma expr_runp_determinate : + forall f e asr asa v, + expr_runp f asr asa e v -> + forall v', + expr_runp f asr asa e v' -> + v' = v. +Proof. + induction e; intros; + + repeat (try match goal with + | [ H : expr_runp _ _ _ (Vlit _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vvar _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vvari _ _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vinputvar _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vbinop _ _ _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vunop _ _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vternary _ _ _) _ |- _ ] => invert H + + | [ H1 : forall asr asa v, expr_runp _ asr asa ?e v -> _, + H2 : expr_runp _ _ _ ?e _ |- _ ] => + learn (H1 _ _ _ H2) + | [ H1 : forall v, expr_runp _ ?asr ?asa ?e v -> _, + H2 : expr_runp _ ?asr ?asa ?e _ |- _ ] => + learn (H1 _ H2) + end; crush). +Qed. +Hint Resolve expr_runp_determinate : verilog. + +Lemma location_is_determinate : + forall f asr asa e l, + location_is f asr asa e l -> + forall l', + location_is f asr asa e l' -> + l' = l. +Proof. + induction 1; intros; + + repeat (try match goal with + | [ H : location_is _ _ _ _ _ |- _ ] => invert H + | [ H1 : expr_runp _ ?asr ?asa ?e _, + H2 : expr_runp _ ?asr ?asa ?e _ |- _ ] => + learn (expr_runp_determinate H1 H2) + end; crush). +Qed. + +Lemma stmnt_runp_determinate : + forall f s asr0 asa0 asr1 asa1, + stmnt_runp f asr0 asa0 s asr1 asa1 -> + forall asr1' asa1', + stmnt_runp f asr0 asa0 s asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. + induction 1; intros; + + repeat (try match goal with + | [ H : stmnt_runp _ _ _ (Vseq _ _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vnonblock _ _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vblock _ _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ Vskip _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcond _ _ _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcase _ (_ :: _) _) _ _ |- _ ] => invert H + | [ H : stmnt_runp _ _ _ (Vcase _ [] _) _ _ |- _ ] => invert H + + | [ H1 : expr_runp _ ?asr ?asa ?e _, + H2 : expr_runp _ ?asr ?asa ?e _ |- _ ] => + learn (expr_runp_determinate H1 H2) + + | [ H1 : location_is _ ?asr ?asa ?e _, + H2 : location_is _ ?asr ?asa ?e _ |- _ ] => + learn (location_is_determinate H1 H2) + + | [ H1 : forall asr1 asa1, stmnt_runp _ ?asr0 ?asa0 ?s asr1 asa1 -> _, + H2 : stmnt_runp _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (H1 _ _ H2) + end; crush). +Qed. +Hint Resolve stmnt_runp_determinate : verilog. + +Lemma mi_stepp_determinate : + forall f asr0 asa0 m asr1 asa1, + mi_stepp f asr0 asa0 m asr1 asa1 -> + forall asr1' asa1', + mi_stepp f asr0 asa0 m asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. +Proof. + intros. destruct m; invert H; invert H0; + + repeat (try match goal with + | [ H1 : stmnt_runp _ ?asr0 ?asa0 ?s _ _, + H2 : stmnt_runp _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (stmnt_runp_determinate H1 H2) + end; crush). +Qed. + +Lemma mis_stepp_determinate : + forall f asr0 asa0 m asr1 asa1, + mis_stepp f asr0 asa0 m asr1 asa1 -> + forall asr1' asa1', + mis_stepp f asr0 asa0 m asr1' asa1' -> + asr1' = asr1 /\ asa1' = asa1. +Proof. + induction 1; intros; + + repeat (try match goal with + | [ H : mis_stepp _ _ _ [] _ _ |- _ ] => invert H + | [ H : mis_stepp _ _ _ ( _ :: _ ) _ _ |- _ ] => invert H + + | [ H1 : mi_stepp _ ?asr0 ?asa0 ?s _ _, + H2 : mi_stepp _ ?asr0 ?asa0 ?s _ _ |- _ ] => + learn (mi_stepp_determinate H1 H2) + + | [ H1 : forall asr1 asa1, mis_stepp _ ?asr0 ?asa0 ?m asr1 asa1 -> _, + H2 : mis_stepp _ ?asr0 ?asa0 ?m _ _ |- _ ] => + learn (H1 _ _ H2) + end; crush). +Qed. + +Lemma semantics_determinate : + forall (p: program), Smallstep.determinate (semantics p). +Proof. + intros. constructor; set (ge := Globalenvs.Genv.globalenv p); simplify. + - invert H; invert H0; constructor. (* Traces are always empty *) + - invert H; invert H0; crush. + pose proof (mis_stepp_determinate H4 H13) + admit. + - constructor. invert H; crush. + - invert H; invert H0; unfold ge0, ge1 in *; crush. + - red; simplify; intro; invert H0; invert H; crush. + - invert H; invert H0; crush. +Admitted. -- cgit From 322f3a1c2d547490b0e92a8f1ef937e1d68c2a6b Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 5 Jul 2020 02:28:30 +0100 Subject: Finish most of Veriloggenproof --- src/translation/Veriloggen.v | 34 ++++--- src/translation/Veriloggenproof.v | 186 ++++++++++++++++++++++++++++++++++++-- src/verilog/HTL.v | 4 + src/verilog/ValueInt.v | 2 +- src/verilog/Verilog.v | 10 +- 5 files changed, 205 insertions(+), 31 deletions(-) diff --git a/src/translation/Veriloggen.v b/src/translation/Veriloggen.v index b550ff9..f0ec576 100644 --- a/src/translation/Veriloggen.v +++ b/src/translation/Veriloggen.v @@ -19,32 +19,30 @@ From compcert Require Import Maps. From compcert Require Errors. From compcert Require Import AST. -From coqup Require Import Verilog HTL Coquplib AssocMap Value. +From coqup Require Import Verilog HTL Coquplib AssocMap ValueInt. -Fixpoint transl_list (st : list (node * Verilog.stmnt)) {struct st} : list (expr * Verilog.stmnt) := - match st with - | (n, stmt) :: ls => (Vlit (posToValue 32 n), stmt) :: transl_list ls - | nil => nil - end. +Definition transl_list_fun (a : node * Verilog.stmnt) := + let (n, stmnt) := a in + (Vlit (posToValue n), stmnt). -Fixpoint scl_to_Vdecl (scldecl : list (reg * (option io * scl_decl))) {struct scldecl} : list module_item := - match scldecl with - | (r, (io, VScalar sz))::scldecl' => Vdeclaration (Vdecl io r sz) :: scl_to_Vdecl scldecl' - | nil => nil - end. +Definition transl_list st := map transl_list_fun st. -Fixpoint arr_to_Vdeclarr (arrdecl : list (reg * (option io * arr_decl))) {struct arrdecl} : list module_item := - match arrdecl with - | (r, (io, VArray sz l))::arrdecl' => Vdeclaration (Vdeclarr io r sz l) :: arr_to_Vdeclarr arrdecl' - | nil => nil - end. +Definition scl_to_Vdecl_fun (a : reg * (option io * scl_decl)) := + match a with (r, (io, VScalar sz)) => Vdeclaration (Vdecl io r sz) end. + +Definition scl_to_Vdecl scldecl := map scl_to_Vdecl_fun scldecl. + +Definition arr_to_Vdeclarr_fun (a : reg * (option io * arr_decl)) := + match a with (r, (io, VArray sz l)) => Vdeclaration (Vdeclarr io r sz l) end. + +Definition arr_to_Vdeclarr arrdecl := map arr_to_Vdeclarr_fun arrdecl. Definition transl_module (m : HTL.module) : Verilog.module := let case_el_ctrl := transl_list (PTree.elements m.(mod_controllogic)) in let case_el_data := transl_list (PTree.elements m.(mod_datapath)) in let body := - Valways (Vposedge m.(mod_clk)) (Vcond (Vbinop Veq (Vvar m.(mod_reset)) (ZToValue 1 1)) - (Vnonblock (Vvar m.(mod_st)) (posToValue 32 m.(mod_entrypoint))) + Valways (Vposedge m.(mod_clk)) (Vcond (Vbinop Veq (Vvar m.(mod_reset)) (Vlit (ZToValue 1))) + (Vnonblock (Vvar m.(mod_st)) (Vlit (posToValue m.(mod_entrypoint)))) (Vcase (Vvar m.(mod_st)) case_el_ctrl (Some Vskip))) :: Valways (Vposedge m.(mod_clk)) (Vcase (Vvar m.(mod_st)) case_el_data (Some Vskip)) :: (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) diff --git a/src/translation/Veriloggenproof.v b/src/translation/Veriloggenproof.v index ca4ecab..3052d03 100644 --- a/src/translation/Veriloggenproof.v +++ b/src/translation/Veriloggenproof.v @@ -16,9 +16,12 @@ * along with this program. If not, see . *) -From compcert Require Import Smallstep Linking. +From compcert Require Import Smallstep Linking Integers. From coqup Require HTL. -From coqup Require Import Coquplib Veriloggen Verilog. +From coqup Require Import Coquplib Veriloggen Verilog ValueInt AssocMap. +Require Import Lia. + +Local Open Scope assocmap. Definition match_prog (prog : HTL.program) (tprog : Verilog.program) := match_program (fun cu f tf => tf = transl_fundef f) eq prog tprog. @@ -52,6 +55,96 @@ Inductive match_states : HTL.state -> state -> Prop := forall m, match_states (HTL.Callstate nil m nil) (Callstate nil (transl_module m) nil). +Lemma Vlit_inj : + forall a b, Vlit a = Vlit b -> a = b. +Proof. inversion 1. trivial. Qed. + +Lemma posToValue_inj : + forall a b, + 0 <= Z.pos a <= Int.max_unsigned -> + 0 <= Z.pos b <= Int.max_unsigned -> + posToValue a = posToValue b -> + a = b. +Proof. + intros. rewrite <- Pos2Z.id at 1. rewrite <- Pos2Z.id. + rewrite <- Int.unsigned_repr at 1; try assumption. + symmetry. + rewrite <- Int.unsigned_repr at 1; try assumption. + unfold posToValue in *. rewrite H1; auto. +Qed. + +Lemma valueToPos_inj : + forall a b, + 0 < Int.unsigned a -> + 0 < Int.unsigned b -> + valueToPos a = valueToPos b -> + a = b. +Proof. + intros. unfold valueToPos in *. + rewrite <- Int.repr_unsigned at 1. + rewrite <- Int.repr_unsigned. + apply Pos2Z.inj_iff in H1. + rewrite Z2Pos.id in H1; auto. + rewrite Z2Pos.id in H1; auto. + rewrite H1. auto. +Qed. + +Lemma transl_list_fun_fst : + forall p1 p2 a b, + 0 <= Z.pos p1 <= Int.max_unsigned -> + 0 <= Z.pos p2 <= Int.max_unsigned -> + transl_list_fun (p1, a) = transl_list_fun (p2, b) -> + (p1, a) = (p2, b). +Proof. + intros. unfold transl_list_fun in H1. apply pair_equal_spec in H1. + destruct H1. rewrite H2. apply Vlit_inj in H1. + apply posToValue_inj in H1; try assumption. + rewrite H1; auto. +Qed. + +Lemma transl_in : + forall l p, + 0 <= Z.pos p <= Int.max_unsigned -> + (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + In (Vlit (posToValue p)) (map fst (map transl_list_fun l)) -> + In p (map fst l). +Proof. + induction l. + - simplify. auto. + - intros. destruct a. simplify. destruct (peq p0 p); auto. + right. inv H1. apply Vlit_inj in H. apply posToValue_inj in H; auto. contradiction. + apply IHl; auto. +Qed. + +Lemma transl_notin : + forall l p, + 0 <= Z.pos p <= Int.max_unsigned -> + (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + ~ In p (List.map fst l) -> ~ In (Vlit (posToValue p)) (List.map fst (transl_list l)). +Proof. + induction l; auto. intros. destruct a. unfold not in *. intros. + simplify. + destruct (peq p0 p). apply H1. auto. apply H1. + unfold transl_list in *. inv H2. apply Vlit_inj in H. apply posToValue_inj in H. + contradiction. + apply H0; auto. auto. + right. apply transl_in; auto. +Qed. + +Lemma transl_norepet : + forall l, + (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + list_norepet (List.map fst l) -> list_norepet (List.map fst (transl_list l)). +Proof. + induction l. + - intros. simpl. apply list_norepet_nil. + - destruct a. intros. simpl. apply list_norepet_cons. + inv H0. apply transl_notin. apply H. simplify; auto. + intros. apply H. destruct (peq p0 p); subst; simplify; auto. + assumption. apply IHl. intros. apply H. destruct (peq p0 p); subst; simplify; auto. + simplify. inv H0. assumption. +Qed. + Section CORRECTNESS. Variable prog: HTL.program. @@ -59,6 +152,52 @@ Section CORRECTNESS. Hypothesis TRANSL : match_prog prog tprog. + Lemma transl_list_correct : + forall l v ev f asr asa asrn asan asr' asa' asrn' asan', + (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + list_norepet (List.map fst l) -> + asr!ev = Some v -> + (forall p s, + In (p, s) l -> + v = posToValue p -> + stmnt_runp f + {| assoc_blocking := asr; assoc_nonblocking := asrn |} + {| assoc_blocking := asa; assoc_nonblocking := asan |} + s + {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} + {| assoc_blocking := asa'; assoc_nonblocking := asan' |} -> + stmnt_runp f + {| assoc_blocking := asr; assoc_nonblocking := asrn |} + {| assoc_blocking := asa; assoc_nonblocking := asan |} + (Vcase (Vvar ev) (transl_list l) (Some Vskip)) + {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} + {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). + Proof. + induction l as [| a l IHl]. + - contradiction. + - intros v ev f asr asa asrn asan asr' asa' asrn' asan' BOUND NOREP ASSOC p s IN EQ SRUN. + destruct a as [p' s']. simplify. + destruct (peq p p'); subst. eapply stmnt_runp_Vcase_match. + constructor. simplify. unfold AssocMap.find_assocmap, AssocMapExt.get_default. + rewrite ASSOC. trivial. constructor. auto. + inversion IN as [INV | INV]. inversion INV as [INV2]; subst. assumption. + inv NOREP. eapply in_map with (f := fst) in INV. contradiction. + + eapply stmnt_runp_Vcase_nomatch. constructor. simplify. + unfold AssocMap.find_assocmap, AssocMapExt.get_default. rewrite ASSOC. + trivial. constructor. unfold not. intros. apply n. apply posToValue_inj. + apply BOUND. right. inv IN. inv H0; contradiction. eapply in_map with (f := fst) in H0. auto. + apply BOUND; auto. auto. + + eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. + trivial. assumption. + Qed. + + Lemma mis_stepp_decl : + forall l asr asa f, + mis_stepp f asr asa l asr asa. + Admitted. + Let ge : HTL.genv := Globalenvs.Genv.globalenv prog. Let tge : genv := Globalenvs.Genv.globalenv tprog. @@ -69,10 +208,45 @@ Section CORRECTNESS. match_states S1 R1 -> exists R2, Smallstep.plus step tge R1 t R2 /\ match_states S2 R2. Proof. -(* induction 1; intros R1 MSTATE; inv MSTATE; econstructor; split. - - apply Smallstep.plus_one. econstructor. eassumption. trivial. - * econstructor. econstructor.*) - Admitted. + induction 1; intros R1 MSTATE; inv MSTATE. + - econstructor; split. apply Smallstep.plus_one. econstructor. + assumption. assumption. eassumption. trivial. + econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. + simpl. unfold find_assocmap. unfold AssocMapExt.get_default. + rewrite H. trivial. + + econstructor. simpl. auto. auto. + + eapply transl_list_correct. + assert (forall p0 : positive, In p0 (map fst (Maps.PTree.elements (HTL.mod_controllogic m))) + -> 0 <= Z.pos p0 <= Int.max_unsigned) by admit; auto. + apply Maps.PTree.elements_keys_norepet. eassumption. + 2: { apply valueToPos_inj. assert (0 < Int.unsigned ist) by admit; auto. + admit. rewrite valueToPos_posToValue. trivial. admit. } + apply Maps.PTree.elements_correct. eassumption. eassumption. + + econstructor. econstructor. + + eapply transl_list_correct. + assert (forall p0 : positive, In p0 (map fst (Maps.PTree.elements (HTL.mod_datapath m))) + -> 0 <= Z.pos p0 <= Int.max_unsigned) by admit; auto. + apply Maps.PTree.elements_keys_norepet. eassumption. + 2: { apply valueToPos_inj. assert (0 < Int.unsigned ist) by admit; auto. + admit. rewrite valueToPos_posToValue. trivial. admit. } + apply Maps.PTree.elements_correct. eassumption. eassumption. + + apply mis_stepp_decl. trivial. trivial. simpl. eassumption. auto. + constructor; assumption. + + - econstructor; split. apply Smallstep.plus_one. apply step_finish. assumption. eassumption. + constructor; assumption. + - econstructor; split. apply Smallstep.plus_one. constructor. + + constructor. constructor. + - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. + + apply match_state. assumption. + Admitted. Theorem transf_program_correct: forward_simulation (HTL.semantics prog) (Verilog.semantics tprog). diff --git a/src/verilog/HTL.v b/src/verilog/HTL.v index df88f98..a7a6ecc 100644 --- a/src/verilog/HTL.v +++ b/src/verilog/HTL.v @@ -103,6 +103,8 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := basr2 basa2 nasr2 nasa2 asr' asa' f stval pstval, + asr!(mod_reset m) = Some (ZToValue 0) -> + asr!(mod_finish m) = Some (ZToValue 0) -> asr!(m.(mod_st)) = Some ist -> valueToPos ist = st -> m.(mod_controllogic)!st = Some ctrl -> @@ -113,6 +115,8 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := ctrl (Verilog.mkassociations basr1 nasr1) (Verilog.mkassociations basa1 nasa1) -> + basr1!(m.(mod_st)) = Some ist -> + valueToPos ist = st -> Verilog.stmnt_runp f (Verilog.mkassociations basr1 nasr1) (Verilog.mkassociations basa1 nasa1) diff --git a/src/verilog/ValueInt.v b/src/verilog/ValueInt.v index dff7b5c..aa99fbd 100644 --- a/src/verilog/ValueInt.v +++ b/src/verilog/ValueInt.v @@ -94,7 +94,7 @@ of [bool], so if they are in a condition, they will have to be converted before they can be used. *) Definition valueToBool (v : value) : bool := - if Z.eqb (uvalueToZ v) 0 then true else false. + if Z.eqb (uvalueToZ v) 0 then false else true. Definition boolToValue (b : bool) : value := natToValue (if b then 1 else 0). diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 3c1b36f..1513330 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -245,9 +245,6 @@ Definition program := AST.program fundef unit. Definition posToLit (p : positive) : expr := Vlit (posToValue p). -Coercion Vlit : value >-> expr. -Coercion Vvar : reg >-> expr. - Definition fext := assocmap. Definition fextclk := nat -> fext. @@ -533,7 +530,7 @@ Inductive stmnt_runp: fext -> reg_associations -> arr_associations -> forall asr0 asa0 asr1 asa1 f c vc stt stf, expr_runp f asr0.(assoc_blocking) asa0.(assoc_blocking) c vc -> valueToBool vc = false -> - stmnt_runp f asr0 asa0 stt asr1 asa1 -> + stmnt_runp f asr0 asa0 stf asr1 asa1 -> stmnt_runp f asr0 asa0 (Vcond c stt stf) asr1 asa1 | stmnt_runp_Vcase_nomatch: forall e ve asr0 asa0 f asr1 asa1 me mve sc cs def, @@ -716,6 +713,7 @@ Definition empty_stack (m : module) : assocmap_arr := Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : forall asr asa asr' asa' basr1 nasr1 basa1 nasa1 f stval pstval m sf st g ist, + asr!(m.(mod_reset)) = Some (ZToValue 0) -> asr!(m.(mod_finish)) = Some (ZToValue 0) -> asr!(m.(mod_st)) = Some ist -> valueToPos ist = st -> @@ -746,7 +744,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) - (empty_stack m)). + asa). Hint Constructors step : verilog. Inductive initial_state (p: program): state -> Prop := @@ -888,7 +886,7 @@ Proof. intros. constructor; set (ge := Globalenvs.Genv.globalenv p); simplify. - invert H; invert H0; constructor. (* Traces are always empty *) - invert H; invert H0; crush. - pose proof (mis_stepp_determinate H4 H13) + (*pose proof (mis_stepp_determinate H4 H13)*) admit. - constructor. invert H; crush. - invert H; invert H0; unfold ge0, ge1 in *; crush. -- cgit From d6c6c87d61dc10b1acaeb056975675c7e523f1ef Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 5 Jul 2020 02:46:11 +0100 Subject: Remove admitted in mis_stepp_Vdecl --- src/translation/Veriloggen.v | 6 +++--- src/translation/Veriloggenproof.v | 8 ++++++-- src/verilog/Verilog.v | 7 +++---- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/translation/Veriloggen.v b/src/translation/Veriloggen.v index f0ec576..f5d5fa7 100644 --- a/src/translation/Veriloggen.v +++ b/src/translation/Veriloggen.v @@ -28,12 +28,12 @@ Definition transl_list_fun (a : node * Verilog.stmnt) := Definition transl_list st := map transl_list_fun st. Definition scl_to_Vdecl_fun (a : reg * (option io * scl_decl)) := - match a with (r, (io, VScalar sz)) => Vdeclaration (Vdecl io r sz) end. + match a with (r, (io, VScalar sz)) => (Vdecl io r sz) end. Definition scl_to_Vdecl scldecl := map scl_to_Vdecl_fun scldecl. Definition arr_to_Vdeclarr_fun (a : reg * (option io * arr_decl)) := - match a with (r, (io, VArray sz l)) => Vdeclaration (Vdeclarr io r sz l) end. + match a with (r, (io, VArray sz l)) => (Vdeclarr io r sz l) end. Definition arr_to_Vdeclarr arrdecl := map arr_to_Vdeclarr_fun arrdecl. @@ -45,7 +45,7 @@ Definition transl_module (m : HTL.module) : Verilog.module := (Vnonblock (Vvar m.(mod_st)) (Vlit (posToValue m.(mod_entrypoint)))) (Vcase (Vvar m.(mod_st)) case_el_ctrl (Some Vskip))) :: Valways (Vposedge m.(mod_clk)) (Vcase (Vvar m.(mod_st)) case_el_data (Some Vskip)) - :: (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) + :: List.map Vdeclaration (arr_to_Vdeclarr (AssocMap.elements m.(mod_arrdecls)) ++ scl_to_Vdecl (AssocMap.elements m.(mod_scldecls))) in Verilog.mkmodule m.(mod_start) m.(mod_reset) diff --git a/src/translation/Veriloggenproof.v b/src/translation/Veriloggenproof.v index 3052d03..ee0aa64 100644 --- a/src/translation/Veriloggenproof.v +++ b/src/translation/Veriloggenproof.v @@ -195,8 +195,12 @@ Section CORRECTNESS. Lemma mis_stepp_decl : forall l asr asa f, - mis_stepp f asr asa l asr asa. - Admitted. + mis_stepp f asr asa (map Vdeclaration l) asr asa. + Proof. + induction l. + - intros. constructor. + - intros. simplify. econstructor. constructor. auto. + Qed. Let ge : HTL.genv := Globalenvs.Genv.globalenv prog. Let tge : genv := Globalenvs.Genv.globalenv tprog. diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 1513330..064474a 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -610,8 +610,8 @@ Inductive mi_stepp : fext -> reg_associations -> arr_associations -> stmnt_runp f sr0 sa0 st sr1 sa1 -> mi_stepp f sr0 sa0 (Valways_comb c st) sr1 sa1 | mi_stepp_Vdecl : - forall f sr sa lhs rhs io, - mi_stepp f sr sa (Vdeclaration (Vdecl io lhs rhs)) sr sa. + forall f sr sa d, + mi_stepp f sr sa (Vdeclaration d) sr sa. Hint Constructors mi_stepp : verilog. Inductive mis_stepp : fext -> reg_associations -> arr_associations -> @@ -743,8 +743,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := forall g m asr i r sf pc mst asa, mst = mod_st m -> step g (Returnstate (Stackframe r m pc asr asa :: sf) i) Events.E0 - (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) - asa). + (State sf m pc ((asr # mst <- (posToValue pc)) # r <- i) asa). Hint Constructors step : verilog. Inductive initial_state (p: program): state -> Prop := -- cgit From 4f65a83e13eff9119edb98683864b946a0947f76 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 5 Jul 2020 13:26:02 +0100 Subject: No addmitted in Veriloggenproof However, there may have been breaking changes to HTLgenproof. --- src/translation/HTLgen.v | 85 ++++++++++---- src/translation/HTLgenproof.v | 1 - src/translation/Veriloggenproof.v | 239 +++++++++++++++++++++++++++----------- src/verilog/HTL.v | 20 ++-- 4 files changed, 245 insertions(+), 100 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index 1977f65..e02d759 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -402,7 +402,7 @@ Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing) then ret (Vvari stack (Vbinop Vdivu (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) - (ZToValue 4))) + (Vlit (ZToValue 4)))) else error (Errors.msg "HTLgen: translate_arr_access address misaligned") | Mint32, Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) let a := Integers.Ptrofs.unsigned a in @@ -510,32 +510,67 @@ Definition create_arr (i : option io) (sz : nat) (ln : nat) : mon (reg * nat) := Definition stack_correct (sz : Z) : bool := (0 <=? sz) && (sz Pos.max m pc) m 1%positive. + +Lemma max_pc_map_sound: + forall m pc i, m!pc = Some i -> Ple pc (max_pc_map m). +Proof. + intros until i. unfold max_pc_function. + apply PTree_Properties.fold_rec with (P := fun c m => c!pc = Some i -> Ple pc m). + (* extensionality *) + intros. apply H0. rewrite H; auto. + (* base case *) + rewrite PTree.gempty. congruence. + (* inductive case *) + intros. rewrite PTree.gsspec in H2. destruct (peq pc k). + inv H2. xomega. + apply Ple_trans with a. auto. xomega. +Qed. + +Lemma max_pc_wf : + forall m, Z.pos (max_pc_map m) <= Integers.Int.max_unsigned -> + map_well_formed m. +Proof. + unfold map_well_formed. intros. + exploit list_in_map_inv. eassumption. intros [x [A B]]. destruct x. + apply Maps.PTree.elements_complete in B. apply max_pc_map_sound in B. + unfold Ple in B. apply Pos2Z.pos_le_pos in B. subst. + simplify. transitivity (Z.pos (max_pc_map m)); eauto. +Qed. + Definition transf_module (f: function) : mon module := if stack_correct f.(fn_stacksize) then - do fin <- create_reg (Some Voutput) 1; - do rtrn <- create_reg (Some Voutput) 32; - do (stack, stack_len) <- create_arr None 32 (Z.to_nat (f.(fn_stacksize) / 4)); - do _ <- collectlist (transf_instr fin rtrn stack) (Maps.PTree.elements f.(RTL.fn_code)); - do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32) f.(RTL.fn_params); - do start <- create_reg (Some Vinput) 1; - do rst <- create_reg (Some Vinput) 1; - do clk <- create_reg (Some Vinput) 1; - do current_state <- get; - ret (mkmodule - f.(RTL.fn_params) - current_state.(st_datapath) - current_state.(st_controllogic) - f.(fn_entrypoint) - current_state.(st_st) - stack - stack_len - fin - rtrn - start - rst - clk - current_state.(st_scldecls) - current_state.(st_arrdecls)) + do fin <- create_reg (Some Voutput) 1; + do rtrn <- create_reg (Some Voutput) 32; + do (stack, stack_len) <- create_arr None 32 (Z.to_nat (f.(fn_stacksize) / 4)); + do _ <- collectlist (transf_instr fin rtrn stack) (Maps.PTree.elements f.(RTL.fn_code)); + do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32) f.(RTL.fn_params); + do start <- create_reg (Some Vinput) 1; + do rst <- create_reg (Some Vinput) 1; + do clk <- create_reg (Some Vinput) 1; + do current_state <- get; + match zle (Z.pos (max_pc_map current_state.(st_datapath))) Integers.Int.max_unsigned, + zle (Z.pos (max_pc_map current_state.(st_controllogic))) Integers.Int.max_unsigned with + | left LEDATA, left LECTRL => + ret (mkmodule + f.(RTL.fn_params) + current_state.(st_datapath) + current_state.(st_controllogic) + f.(fn_entrypoint) + current_state.(st_st) + stack + stack_len + fin + rtrn + start + rst + clk + current_state.(st_scldecls) + current_state.(st_arrdecls) + (conj (max_pc_wf _ LECTRL) (max_pc_wf _ LEDATA))) + | _, _ => error (Errors.msg "More than 2^32 states.") + end else error (Errors.msg "Stack size misalignment."). Definition max_state (f: function) : state := diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 82d4cfc..305c14f 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -342,7 +342,6 @@ Section CORRECTNESS. intros (cu & tf & P & Q & R); exists tf; auto. Qed. - Lemma functions_translated: forall (v: Values.val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> diff --git a/src/translation/Veriloggenproof.v b/src/translation/Veriloggenproof.v index ee0aa64..5b467a7 100644 --- a/src/translation/Veriloggenproof.v +++ b/src/translation/Veriloggenproof.v @@ -16,7 +16,7 @@ * along with this program. If not, see . *) -From compcert Require Import Smallstep Linking Integers. +From compcert Require Import Smallstep Linking Integers Globalenvs. From coqup Require HTL. From coqup Require Import Coquplib Veriloggen Verilog ValueInt AssocMap. Require Import Lia. @@ -89,6 +89,14 @@ Proof. rewrite H1. auto. Qed. +Lemma unsigned_posToValue_le : + forall p, + Z.pos p <= Int.max_unsigned -> + 0 < Int.unsigned (posToValue p). +Proof. + intros. unfold posToValue. rewrite Int.unsigned_repr; lia. +Qed. + Lemma transl_list_fun_fst : forall p1 p2 a b, 0 <= Z.pos p1 <= Int.max_unsigned -> @@ -102,10 +110,17 @@ Proof. rewrite H1; auto. Qed. +Lemma Zle_relax : + forall p q r, + p < q <= r -> + p <= q <= r. +Proof. lia. Qed. +Hint Resolve Zle_relax : verilogproof. + Lemma transl_in : forall l p, 0 <= Z.pos p <= Int.max_unsigned -> - (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> In (Vlit (posToValue p)) (map fst (map transl_list_fun l)) -> In p (map fst l). Proof. @@ -113,13 +128,14 @@ Proof. - simplify. auto. - intros. destruct a. simplify. destruct (peq p0 p); auto. right. inv H1. apply Vlit_inj in H. apply posToValue_inj in H; auto. contradiction. + auto with verilogproof. apply IHl; auto. Qed. Lemma transl_notin : forall l p, 0 <= Z.pos p <= Int.max_unsigned -> - (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> ~ In p (List.map fst l) -> ~ In (Vlit (posToValue p)) (List.map fst (transl_list l)). Proof. induction l; auto. intros. destruct a. unfold not in *. intros. @@ -127,24 +143,88 @@ Proof. destruct (peq p0 p). apply H1. auto. apply H1. unfold transl_list in *. inv H2. apply Vlit_inj in H. apply posToValue_inj in H. contradiction. - apply H0; auto. auto. + auto with verilogproof. auto. right. apply transl_in; auto. Qed. Lemma transl_norepet : forall l, - (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> + (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> list_norepet (List.map fst l) -> list_norepet (List.map fst (transl_list l)). Proof. induction l. - intros. simpl. apply list_norepet_nil. - destruct a. intros. simpl. apply list_norepet_cons. - inv H0. apply transl_notin. apply H. simplify; auto. + inv H0. apply transl_notin. apply Zle_relax. apply H. simplify; auto. intros. apply H. destruct (peq p0 p); subst; simplify; auto. assumption. apply IHl. intros. apply H. destruct (peq p0 p); subst; simplify; auto. simplify. inv H0. assumption. Qed. +Lemma transl_list_correct : + forall l v ev f asr asa asrn asan asr' asa' asrn' asan', + (forall p0, In p0 (List.map fst l) -> 0 < Z.pos p0 <= Int.max_unsigned) -> + list_norepet (List.map fst l) -> + asr!ev = Some v -> + (forall p s, + In (p, s) l -> + v = posToValue p -> + stmnt_runp f + {| assoc_blocking := asr; assoc_nonblocking := asrn |} + {| assoc_blocking := asa; assoc_nonblocking := asan |} + s + {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} + {| assoc_blocking := asa'; assoc_nonblocking := asan' |} -> + stmnt_runp f + {| assoc_blocking := asr; assoc_nonblocking := asrn |} + {| assoc_blocking := asa; assoc_nonblocking := asan |} + (Vcase (Vvar ev) (transl_list l) (Some Vskip)) + {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} + {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). +Proof. + induction l as [| a l IHl]. + - contradiction. + - intros v ev f asr asa asrn asan asr' asa' asrn' asan' BOUND NOREP ASSOC p s IN EQ SRUN. + destruct a as [p' s']. simplify. + destruct (peq p p'); subst. eapply stmnt_runp_Vcase_match. + constructor. simplify. unfold AssocMap.find_assocmap, AssocMapExt.get_default. + rewrite ASSOC. trivial. constructor. auto. + inversion IN as [INV | INV]. inversion INV as [INV2]; subst. assumption. + inv NOREP. eapply in_map with (f := fst) in INV. contradiction. + + eapply stmnt_runp_Vcase_nomatch. constructor. simplify. + unfold AssocMap.find_assocmap, AssocMapExt.get_default. rewrite ASSOC. + trivial. constructor. unfold not. intros. apply n. apply posToValue_inj. + apply Zle_relax. apply BOUND. right. inv IN. inv H0; contradiction. + eapply in_map with (f := fst) in H0. auto. + apply Zle_relax. apply BOUND; auto. auto. + + eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. + trivial. assumption. +Qed. +Hint Resolve transl_list_correct : verilogproof. + +Lemma pc_wf : + forall A m p v, + (forall p0, In p0 (List.map fst (@AssocMap.elements A m)) -> 0 < Z.pos p0 <= Int.max_unsigned) -> + m!p = Some v -> + 0 <= Z.pos p <= Int.max_unsigned. +Proof. + intros A m p v LT S. apply Zle_relax. apply LT. + apply AssocMap.elements_correct in S. remember (p, v) as x. + exploit in_map. apply S. instantiate (1 := fst). subst. simplify. auto. +Qed. + +Lemma mis_stepp_decl : + forall l asr asa f, + mis_stepp f asr asa (map Vdeclaration l) asr asa. +Proof. + induction l. + - intros. constructor. + - intros. simplify. econstructor. constructor. auto. +Qed. +Hint Resolve mis_stepp_decl : verilogproof. + Section CORRECTNESS. Variable prog: HTL.program. @@ -152,58 +232,42 @@ Section CORRECTNESS. Hypothesis TRANSL : match_prog prog tprog. - Lemma transl_list_correct : - forall l v ev f asr asa asrn asan asr' asa' asrn' asan', - (forall p0, In p0 (List.map fst l) -> 0 <= Z.pos p0 <= Int.max_unsigned) -> - list_norepet (List.map fst l) -> - asr!ev = Some v -> - (forall p s, - In (p, s) l -> - v = posToValue p -> - stmnt_runp f - {| assoc_blocking := asr; assoc_nonblocking := asrn |} - {| assoc_blocking := asa; assoc_nonblocking := asan |} - s - {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} - {| assoc_blocking := asa'; assoc_nonblocking := asan' |} -> - stmnt_runp f - {| assoc_blocking := asr; assoc_nonblocking := asrn |} - {| assoc_blocking := asa; assoc_nonblocking := asan |} - (Vcase (Vvar ev) (transl_list l) (Some Vskip)) - {| assoc_blocking := asr'; assoc_nonblocking := asrn' |} - {| assoc_blocking := asa'; assoc_nonblocking := asan' |}). + Let ge : HTL.genv := Globalenvs.Genv.globalenv prog. + Let tge : genv := Globalenvs.Genv.globalenv tprog. + + Lemma symbols_preserved: + forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. + Proof. intros. eapply (Genv.find_symbol_match TRANSL). Qed. + Hint Resolve symbols_preserved : verilogproof. + + Lemma function_ptr_translated: + forall (b: Values.block) (f: HTL.fundef), + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = tf. Proof. - induction l as [| a l IHl]. - - contradiction. - - intros v ev f asr asa asrn asan asr' asa' asrn' asan' BOUND NOREP ASSOC p s IN EQ SRUN. - destruct a as [p' s']. simplify. - destruct (peq p p'); subst. eapply stmnt_runp_Vcase_match. - constructor. simplify. unfold AssocMap.find_assocmap, AssocMapExt.get_default. - rewrite ASSOC. trivial. constructor. auto. - inversion IN as [INV | INV]. inversion INV as [INV2]; subst. assumption. - inv NOREP. eapply in_map with (f := fst) in INV. contradiction. - - eapply stmnt_runp_Vcase_nomatch. constructor. simplify. - unfold AssocMap.find_assocmap, AssocMapExt.get_default. rewrite ASSOC. - trivial. constructor. unfold not. intros. apply n. apply posToValue_inj. - apply BOUND. right. inv IN. inv H0; contradiction. eapply in_map with (f := fst) in H0. auto. - apply BOUND; auto. auto. - - eapply IHl. auto. inv NOREP. auto. eassumption. inv IN. inv H. contradiction. apply H. - trivial. assumption. + intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. Qed. + Hint Resolve function_ptr_translated : verilogproof. - Lemma mis_stepp_decl : - forall l asr asa f, - mis_stepp f asr asa (map Vdeclaration l) asr asa. + Lemma functions_translated: + forall (v: Values.val) (f: HTL.fundef), + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transl_fundef f = tf. Proof. - induction l. - - intros. constructor. - - intros. simplify. econstructor. constructor. auto. + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. Qed. + Hint Resolve functions_translated : verilogproof. - Let ge : HTL.genv := Globalenvs.Genv.globalenv prog. - Let tge : genv := Globalenvs.Genv.globalenv tprog. + Lemma senv_preserved: + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). + Proof. + intros. eapply (Genv.senv_match TRANSL). + Qed. + Hint Resolve senv_preserved : verilogproof. Theorem transl_step_correct : forall (S1 : HTL.state) t S2, @@ -214,7 +278,10 @@ Section CORRECTNESS. Proof. induction 1; intros R1 MSTATE; inv MSTATE. - econstructor; split. apply Smallstep.plus_one. econstructor. - assumption. assumption. eassumption. trivial. + assumption. assumption. eassumption. apply valueToPos_posToValue. + split. lia. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. econstructor. econstructor. eapply stmnt_runp_Vcond_false. econstructor. econstructor. simpl. unfold find_assocmap. unfold AssocMapExt.get_default. rewrite H. trivial. @@ -222,25 +289,33 @@ Section CORRECTNESS. econstructor. simpl. auto. auto. eapply transl_list_correct. - assert (forall p0 : positive, In p0 (map fst (Maps.PTree.elements (HTL.mod_controllogic m))) - -> 0 <= Z.pos p0 <= Int.max_unsigned) by admit; auto. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. auto. apply Maps.PTree.elements_keys_norepet. eassumption. - 2: { apply valueToPos_inj. assert (0 < Int.unsigned ist) by admit; auto. - admit. rewrite valueToPos_posToValue. trivial. admit. } + 2: { apply valueToPos_inj. apply unsigned_posToValue_le. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. + destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. trivial. + } apply Maps.PTree.elements_correct. eassumption. eassumption. econstructor. econstructor. eapply transl_list_correct. - assert (forall p0 : positive, In p0 (map fst (Maps.PTree.elements (HTL.mod_datapath m))) - -> 0 <= Z.pos p0 <= Int.max_unsigned) by admit; auto. + intros. split. lia. pose proof (HTL.mod_wf m) as HP. destruct HP as [_ HP]. auto. apply Maps.PTree.elements_keys_norepet. eassumption. - 2: { apply valueToPos_inj. assert (0 < Int.unsigned ist) by admit; auto. - admit. rewrite valueToPos_posToValue. trivial. admit. } + 2: { apply valueToPos_inj. apply unsigned_posToValue_le. + eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. + apply unsigned_posToValue_le. eapply pc_wf. intros. pose proof (HTL.mod_wf m) as HP. + destruct HP as [HP _]. + split. lia. apply HP. eassumption. eassumption. trivial. + } apply Maps.PTree.elements_correct. eassumption. eassumption. apply mis_stepp_decl. trivial. trivial. simpl. eassumption. auto. - constructor; assumption. + rewrite valueToPos_posToValue. constructor; assumption. lia. - econstructor; split. apply Smallstep.plus_one. apply step_finish. assumption. eassumption. constructor; assumption. @@ -250,12 +325,44 @@ Section CORRECTNESS. - inv H3. econstructor; split. apply Smallstep.plus_one. constructor. trivial. apply match_state. assumption. - Admitted. + Qed. + Hint Resolve transl_step_correct : verilogproof. + + Lemma transl_initial_states : + forall s1 : Smallstep.state (HTL.semantics prog), + Smallstep.initial_state (HTL.semantics prog) s1 -> + exists s2 : Smallstep.state (Verilog.semantics tprog), + Smallstep.initial_state (Verilog.semantics tprog) s2 /\ match_states s1 s2. + Proof. + induction 1. + econstructor; split. econstructor. + apply (Genv.init_mem_transf TRANSL); eauto. + rewrite symbols_preserved. + replace (AST.prog_main tprog) with (AST.prog_main prog); eauto. + symmetry; eapply Linking.match_program_main; eauto. + exploit function_ptr_translated; eauto. intros [tf [A B]]. + inv B. eauto. + constructor. + Qed. + Hint Resolve transl_initial_states : verilogproof. + + Lemma transl_final_states : + forall (s1 : Smallstep.state (HTL.semantics prog)) + (s2 : Smallstep.state (Verilog.semantics tprog)) + (r : Integers.Int.int), + match_states s1 s2 -> + Smallstep.final_state (HTL.semantics prog) s1 r -> + Smallstep.final_state (Verilog.semantics tprog) s2 r. + Proof. + intros. inv H0. inv H. inv H3. constructor. reflexivity. + Qed. + Hint Resolve transl_final_states : verilogproof. Theorem transf_program_correct: forward_simulation (HTL.semantics prog) (Verilog.semantics tprog). - Admitted. - + Proof. + eapply Smallstep.forward_simulation_plus; eauto with verilogproof. + apply senv_preserved. + Qed. End CORRECTNESS. - diff --git a/src/verilog/HTL.v b/src/verilog/HTL.v index a7a6ecc..3ba5b59 100644 --- a/src/verilog/HTL.v +++ b/src/verilog/HTL.v @@ -36,6 +36,11 @@ Definition node := positive. Definition datapath := PTree.t Verilog.stmnt. Definition controllogic := PTree.t Verilog.stmnt. +Definition map_well_formed {A : Type} (m : PTree.t A) : Prop := + forall p0 : positive, + In p0 (map fst (Maps.PTree.elements m)) -> + Z.pos p0 <= Integers.Int.max_unsigned. + Record module: Type := mkmodule { mod_params : list reg; @@ -52,6 +57,7 @@ Record module: Type := mod_clk : reg; mod_scldecls : AssocMap.t (option Verilog.io * Verilog.scl_decl); mod_arrdecls : AssocMap.t (option Verilog.io * Verilog.arr_decl); + mod_wf : (map_well_formed mod_controllogic /\ map_well_formed mod_datapath); }. Definition fundef := AST.fundef module. @@ -97,16 +103,15 @@ Inductive state : Type := Inductive step : genv -> state -> Events.trace -> state -> Prop := | step_module : - forall g m st sf ctrl data ist + forall g m st sf ctrl data asr asa basr1 basa1 nasr1 nasa1 basr2 basa2 nasr2 nasa2 asr' asa' - f stval pstval, + f pstval, asr!(mod_reset m) = Some (ZToValue 0) -> asr!(mod_finish m) = Some (ZToValue 0) -> - asr!(m.(mod_st)) = Some ist -> - valueToPos ist = st -> + asr!(m.(mod_st)) = Some (posToValue st) -> m.(mod_controllogic)!st = Some ctrl -> m.(mod_datapath)!st = Some data -> Verilog.stmnt_runp f @@ -115,8 +120,7 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := ctrl (Verilog.mkassociations basr1 nasr1) (Verilog.mkassociations basa1 nasa1) -> - basr1!(m.(mod_st)) = Some ist -> - valueToPos ist = st -> + basr1!(m.(mod_st)) = Some (posToValue st) -> Verilog.stmnt_runp f (Verilog.mkassociations basr1 nasr1) (Verilog.mkassociations basa1 nasa1) @@ -125,8 +129,8 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := (Verilog.mkassociations basa2 nasa2) -> asr' = Verilog.merge_regs nasr2 basr2 -> asa' = Verilog.merge_arrs nasa2 basa2 -> - asr'!(m.(mod_st)) = Some stval -> - valueToPos stval = pstval -> + asr'!(m.(mod_st)) = Some (posToValue pstval) -> + Z.pos pstval <= Integers.Int.max_unsigned -> step g (State sf m st asr asa) Events.E0 (State sf m pstval asr' asa') | step_finish : forall g m st asr asa retval sf, -- cgit From e3b7213e552d601094d784042cc502cd518d3125 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 5 Jul 2020 13:50:22 +0100 Subject: Fix HTLgenspec --- src/translation/HTLgenspec.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index 799b198..a9626c4 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -161,12 +161,12 @@ Hint Constructors tr_code : htlspec. Inductive tr_module (f : RTL.function) : module -> Prop := tr_module_intro : - forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls, + forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, m = (mkmodule f.(RTL.fn_params) data control f.(RTL.fn_entrypoint) - st stk stk_len fin rtrn start rst clk scldecls arrdecls) -> + st stk stk_len fin rtrn start rst clk scldecls arrdecls wf) -> (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> @@ -581,6 +581,8 @@ Proof. crush; monadInv Heqr. + repeat unfold_match EQ9. monadInv EQ9. + (* TODO: We should be able to fold this into the automation. *) pose proof (create_arr_inv _ _ _ _ _ _ _ _ EQ0) as STK_LEN. inv STK_LEN. inv H5. pose proof (create_reg_inv _ _ _ _ _ _ EQ) as FIN_VAL. inv FIN_VAL. @@ -591,7 +593,6 @@ Proof. pose proof (create_reg_inv _ _ _ _ _ _ EQ4) as START_VAL. inv START_VAL. pose proof (create_reg_inv _ _ _ _ _ _ EQ5) as RESET_VAL. inv RESET_VAL. pose proof (create_reg_inv _ _ _ _ _ _ EQ6) as CLK_VAL. inv CLK_VAL. - simpl. rewrite H9 in *. rewrite H8 in *. replace (st_freshreg s4) with (st_freshreg s2) in * by congruence. rewrite H6 in *. rewrite H7 in *. rewrite H5 in *. simpl in *. inv_incr. -- cgit From c76ac9be323e3513aa0db2721ecd0f6c3987aef0 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 5 Jul 2020 18:45:14 +0100 Subject: Fix Inop --- src/translation/HTLgen.v | 33 ++++++++++++++++++++++----------- src/translation/HTLgenproof.v | 25 ++++++++++++++----------- src/translation/HTLgenspec.v | 30 ++++++++++++++++++++++-------- src/translation/Veriloggenspec.v | 17 ----------------- 4 files changed, 58 insertions(+), 47 deletions(-) delete mode 100644 src/translation/Veriloggenspec.v diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index e02d759..b4f6b51 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -428,24 +428,35 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni match ni with (n, i) => match i with - | Inop n' => add_instr n n' Vskip + | Inop n' => + if Z.leb (Z.pos n') Integers.Int.max_unsigned then + add_instr n n' Vskip + else error (Errors.msg "State is larger than 2^32.") | Iop op args dst n' => - do instr <- translate_instr op args; - do _ <- declare_reg None dst 32; - add_instr n n' (nonblock dst instr) + if Z.leb (Z.pos n') Integers.Int.max_unsigned then + do instr <- translate_instr op args; + do _ <- declare_reg None dst 32; + add_instr n n' (nonblock dst instr) + else error (Errors.msg "State is larger than 2^32.") | Iload mem addr args dst n' => - do src <- translate_arr_access mem addr args stack; - do _ <- declare_reg None dst 32; - add_instr n n' (nonblock dst src) + if Z.leb (Z.pos n') Integers.Int.max_unsigned then + do src <- translate_arr_access mem addr args stack; + do _ <- declare_reg None dst 32; + add_instr n n' (nonblock dst src) + else error (Errors.msg "State is larger than 2^32.") | Istore mem addr args src n' => - do dst <- translate_arr_access mem addr args stack; - add_instr n n' (Vnonblock dst (Vvar src)) (* TODO: Could juse use add_instr? reg exists. *) + if Z.leb (Z.pos n') Integers.Int.max_unsigned then + do dst <- translate_arr_access mem addr args stack; + add_instr n n' (Vnonblock dst (Vvar src)) (* TODO: Could juse use add_instr? reg exists. *) + else error (Errors.msg "State is larger than 2^32.") | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.") | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.") | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.") | Icond cond args n1 n2 => - do e <- translate_condition cond args; - add_branch_instr e n n1 n2 + if Z.leb (Z.pos n1) Integers.Int.max_unsigned && Z.leb (Z.pos n2) Integers.Int.max_unsigned then + do e <- translate_condition cond args; + add_branch_instr e n n1 n2 + else error (Errors.msg "State is larger than 2^32.") | Ijumptable r tbl => do s <- get; add_node_skip n (Vcase (Vvar r) (tbl_to_case_expr s.(st_st) tbl) (Some Vskip)) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 305c14f..fe4faf5 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -87,11 +87,12 @@ Inductive match_frames : list RTL.stackframe -> list HTL.stackframe -> Prop := | match_frames_nil : match_frames nil nil. - Lemma assumption_32bit : - forall v, - valueToPos (posToValue v) = v. - Proof. - Admitted. +Inductive match_constants : HTL.module -> assocmap -> Prop := + match_constant : + forall m asr, + asr!(HTL.mod_reset m) = Some (ZToValue 0) -> + asr!(HTL.mod_finish m) = Some (ZToValue 0) -> + match_constants m asr. Inductive match_states : RTL.state -> HTL.state -> Prop := | match_state : forall asa asr sf f sp sp' rs mem m st res @@ -103,7 +104,8 @@ Inductive match_states : RTL.state -> HTL.state -> Prop := (SP : sp = Values.Vptr sp' (Integers.Ptrofs.repr 0)) (RSBP : reg_stack_based_pointers sp' rs) (ASBP : arr_stack_based_pointers sp' mem (f.(RTL.fn_stacksize)) sp) - (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem), + (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem) + (CONST : match_constants m asr), match_states (RTL.State sf f sp st rs mem) (HTL.State res m st asr asa) | match_returnstate : @@ -443,8 +445,6 @@ Section CORRECTNESS. Ltac tac0 := match goal with - | [ |- context[valueToPos (posToValue _)] ] => rewrite assumption_32bit - | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge @@ -502,7 +502,8 @@ Section CORRECTNESS. split. apply Smallstep.plus_one. eapply HTL.step_module; eauto. - apply assumption_32bit. + inv CONST; assumption. + inv CONST; assumption. (* processing of state *) econstructor. crush. @@ -511,8 +512,10 @@ Section CORRECTNESS. econstructor. all: invert MARR; big_tac. - Unshelve. - constructor. + + inv CONST; constructor; simplify; rewrite AssocMap.gso; auto; lia. + + Unshelve. auto. Qed. Hint Resolve transl_inop_correct : htlproof. diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index a9626c4..f0508bd 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -17,7 +17,7 @@ *) From compcert Require RTL Op Maps Errors. -From compcert Require Import Maps. +From compcert Require Import Maps Integers. From coqup Require Import Coquplib Verilog ValueInt HTL HTLgen AssocMap. Require Import Lia. @@ -117,13 +117,17 @@ translations for each of the elements *) Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt -> Prop := | tr_instr_Inop : forall n, + Z.pos n <= Int.max_unsigned -> tr_instr fin rtrn st stk (RTL.Inop n) Vskip (state_goto st n) | tr_instr_Iop : forall n op args dst s s' e i, + Z.pos n <= Int.max_unsigned -> translate_instr op args s = OK e s' i -> tr_instr fin rtrn st stk (RTL.Iop op args dst n) (Vnonblock (Vvar dst) e) (state_goto st n) | tr_instr_Icond : forall n1 n2 cond args s s' i c, + Z.pos n1 <= Int.max_unsigned -> + Z.pos n2 <= Int.max_unsigned -> translate_condition cond args s = OK c s' i -> tr_instr fin rtrn st stk (RTL.Icond cond args n1 n2) Vskip (state_cond st c n1 n2) | tr_instr_Ireturn_None : @@ -135,10 +139,12 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r))) Vskip | tr_instr_Iload : forall mem addr args s s' i c dst n, + Z.pos n <= Int.max_unsigned -> translate_arr_access mem addr args stk s = OK c s' i -> tr_instr fin rtrn st stk (RTL.Iload mem addr args dst n) (nonblock dst c) (state_goto st n) | tr_instr_Istore : forall mem addr args s s' i c src n, + Z.pos n <= Int.max_unsigned -> translate_arr_access mem addr args stk s = OK c s' i -> tr_instr fin rtrn st stk (RTL.Istore mem addr args src n) (Vnonblock c (Vvar src)) (state_goto st n) @@ -415,12 +421,12 @@ Lemma transf_instr_freshreg_trans : Proof. intros. destruct instr eqn:?. subst. unfold transf_instr in H. destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. - - apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. + - monadInv H. apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. apply declare_reg_freshreg_trans in EQ1. congruence. - - apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. + - monadInv H. apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. apply declare_reg_freshreg_trans in EQ1. congruence. - - apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. - - apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. + - monadInv H. apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. + - monadInv H. apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. congruence. - inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence. Qed. @@ -445,13 +451,16 @@ Ltac rewrite_states := Ltac inv_add_instr' H := match type of H with + | ?f _ _ = OK _ _ _ => unfold f in H | ?f _ _ _ = OK _ _ _ => unfold f in H | ?f _ _ _ _ = OK _ _ _ => unfold f in H | ?f _ _ _ _ _ = OK _ _ _ => unfold f in H + | ?f _ _ _ _ _ _ = OK _ _ _ => unfold f in H end; repeat unfold_match H; inversion H. Ltac inv_add_instr := - lazymatch goal with + match goal with + | H: (if ?c then _ else _) _ = OK _ _ _ |- _ => destruct c eqn:EQN; try discriminate; inv_add_instr | H: context[add_instr_skip _ _ _] |- _ => inv_add_instr' H | H: context[add_instr_skip _ _] |- _ => @@ -491,23 +500,27 @@ Proof. + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. + apply Z.leb_le. assumption. eapply in_map with (f := fst) in H9. contradiction. + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + inversion H2. inversion H14. unfold nonblock. replace (st_st s4) with (st_st s2) by congruence. - econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + econstructor. apply Z.leb_le; assumption. + apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. - econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + econstructor. apply Z.leb_le; assumption. + apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + destruct H2. * inversion H2. replace (st_st s2) with (st_st s0) by congruence. + econstructor. apply Z.leb_le; assumption. eauto with htlspec. * apply in_map with (f := fst) in H2. contradiction. @@ -516,6 +529,7 @@ Proof. + destruct H2. * inversion H2. replace (st_st s2) with (st_st s0) by congruence. + econstructor; try (apply Z.leb_le; apply andb_prop in EQN; apply EQN). eauto with htlspec. * apply in_map with (f := fst) in H2. contradiction. diff --git a/src/translation/Veriloggenspec.v b/src/translation/Veriloggenspec.v deleted file mode 100644 index 7dc632c..0000000 --- a/src/translation/Veriloggenspec.v +++ /dev/null @@ -1,17 +0,0 @@ -(* - * CoqUp: Verified high-level synthesis. - * Copyright (C) 2020 Yann Herklotz - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see . - *) -- cgit From 78e549331ba3f136ebe94955f68767bd384df454 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 6 Jul 2020 14:09:54 +0100 Subject: HTLgenproof compiles again - Commented out Iload, Istore proofs for now --- src/Compiler.v | 7 ++++++- src/translation/HTLgenproof.v | 44 +++++++++++++++++++++++++++++-------------- src/verilog/HTL.v | 6 ++++-- src/verilog/Verilog.v | 12 +++++++----- 4 files changed, 47 insertions(+), 22 deletions(-) diff --git a/src/Compiler.v b/src/Compiler.v index a34b359..17d8921 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -48,7 +48,9 @@ From compcert.driver Require From coqup Require Verilog Veriloggen - HTLgen. + Veriloggenproof + HTLgen + HTLgenproof. Parameter print_RTL: Z -> RTL.program -> unit. Parameter print_HTL: HTL.program -> unit. @@ -107,6 +109,9 @@ Definition CompCert's_passes := ::: mkpass Cminorgenproof.match_prog ::: mkpass Selectionproof.match_prog ::: mkpass RTLgenproof.match_prog + ::: mkpass Inliningproof.match_prog + ::: mkpass HTLgenproof.match_prog + ::: mkpass Veriloggenproof.match_prog ::: pass_nil _. Definition match_prog: Csyntax.program -> RTL.program -> Prop := diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index fe4faf5..338e77d 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -537,7 +537,8 @@ Section CORRECTNESS. econstructor. split. apply Smallstep.plus_one. eapply HTL.step_module; eauto. - apply assumption_32bit. + inv CONST. assumption. + inv CONST. assumption. econstructor; simpl; trivial. constructor; trivial. econstructor; simpl; eauto. @@ -555,7 +556,8 @@ Section CORRECTNESS. assert (Ple res0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_def; eauto; simpl; auto). unfold Ple in H12; lia. - unfold_merge. simpl. + Admitted. +(* unfold_merge. simpl. rewrite AssocMap.gso. apply AssocMap.gss. apply st_greater_than_res. @@ -608,7 +610,7 @@ Section CORRECTNESS. apply AssocMap.gss. apply st_greater_than_res. assumption. - Admitted. + Admitted.*) Hint Resolve transl_iop_correct : htlproof. Ltac tac := @@ -680,7 +682,7 @@ Section CORRECTNESS. (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. + (*assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. { rewrite HeqOFFSET. apply PtrofsExtra.add_mod; crush. rewrite Integers.Ptrofs.unsigned_repr_eq. @@ -1024,7 +1026,7 @@ Section CORRECTNESS. specialize (ASBP (Integers.Ptrofs.unsigned (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption. + rewrite NORMALISE in H0. rewrite H1 in H0. assumption.*) Admitted. Hint Resolve transl_iload_correct : htlproof. @@ -1041,7 +1043,7 @@ Section CORRECTNESS. exists R2 : HTL.state, Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m') R2. Proof. - intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. +(* intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. inv_state. inv_arr_access. + (** Preamble *) @@ -1838,7 +1840,7 @@ Section CORRECTNESS. (Integers.Ptrofs.unsigned (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence. + apply X in H0. invert H0. congruence.*) Admitted. Hint Resolve transl_istore_correct : htlproof. @@ -1859,8 +1861,9 @@ Section CORRECTNESS. eexists. split. apply Smallstep.plus_one. eapply HTL.step_module; eauto. - apply assumption_32bit. - eapply Verilog.stmnt_runp_Vnonblock_reg with + inv CONST; assumption. + inv CONST; assumption. +(* eapply Verilog.stmnt_runp_Vnonblock_reg with (rhsval := if b then posToValue 32 ifso else posToValue 32 ifnot). constructor. @@ -1883,7 +1886,8 @@ Section CORRECTNESS. Unshelve. constructor. - Qed. + Qed.*) + Admitted. Hint Resolve transl_icond_correct : htlproof. Lemma transl_ijumptable_correct: @@ -1921,7 +1925,8 @@ Section CORRECTNESS. eapply Smallstep.plus_two. eapply HTL.step_module; eauto. - apply assumption_32bit. + inv CONST; assumption. + inv CONST; assumption. constructor. econstructor; simpl; trivial. econstructor; simpl; trivial. @@ -1932,6 +1937,9 @@ Section CORRECTNESS. constructor. constructor. unfold state_st_wf in WF; big_tac; eauto. + destruct wf as [HCTRL HDATA]. apply HCTRL. + apply AssocMapExt.elements_iff. eexists. + match goal with H: control ! pc = Some _ |- _ => apply H end. apply HTL.step_finish. unfold Verilog.merge_regs. @@ -1948,7 +1956,8 @@ Section CORRECTNESS. - econstructor. split. eapply Smallstep.plus_two. eapply HTL.step_module; eauto. - apply assumption_32bit. + inv CONST; assumption. + inv CONST; assumption. constructor. econstructor; simpl; trivial. econstructor; simpl; trivial. @@ -1957,6 +1966,10 @@ Section CORRECTNESS. unfold state_st_wf in WF; big_tac; eauto. + destruct wf as [HCTRL HDATA]. apply HCTRL. + apply AssocMapExt.elements_iff. eexists. + match goal with H: control ! pc = Some _ |- _ => apply H end. + apply HTL.step_finish. unfold Verilog.merge_regs. unfold_merge. @@ -2001,8 +2014,9 @@ Section CORRECTNESS. all: big_tac. - apply regs_lessdef_add_greater. - unfold Plt; lia. + apply regs_lessdef_add_greater. unfold Plt; lia. + apply regs_lessdef_add_greater. unfold Plt; lia. + apply regs_lessdef_add_greater. unfold Plt; lia. apply init_reg_assoc_empty. constructor. @@ -2078,6 +2092,8 @@ Section CORRECTNESS. match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. crush. apply proj_sumbool_true in H10. lia. + constructor. simplify. rewrite AssocMap.gss. + simplify. rewrite AssocMap.gso. apply AssocMap.gss. simplify. lia. Opaque Mem.alloc. Opaque Mem.load. Opaque Mem.store. diff --git a/src/verilog/HTL.v b/src/verilog/HTL.v index 3ba5b59..b3d1442 100644 --- a/src/verilog/HTL.v +++ b/src/verilog/HTL.v @@ -141,8 +141,10 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := forall g m args res, step g (Callstate res m args) Events.E0 (State res m m.(mod_entrypoint) - (AssocMap.set (mod_st m) (posToValue m.(mod_entrypoint)) - (init_regs args m.(mod_params))) + (AssocMap.set (mod_reset m) (ZToValue 0) + (AssocMap.set (mod_finish m) (ZToValue 0) + (AssocMap.set (mod_st m) (posToValue m.(mod_entrypoint)) + (init_regs args m.(mod_params))))) (empty_stack m)) | step_return : forall g m asr asa i r sf pc mst, diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 064474a..9659189 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -736,8 +736,10 @@ Inductive step : genv -> state -> Events.trace -> state -> Prop := forall g res m args, step g (Callstate res m args) Events.E0 (State res m m.(mod_entrypoint) - (AssocMap.set m.(mod_st) (posToValue m.(mod_entrypoint)) - (init_params args m.(mod_args))) + (AssocMap.set (mod_reset m) (ZToValue 0) + (AssocMap.set (mod_finish m) (ZToValue 0) + (AssocMap.set m.(mod_st) (posToValue m.(mod_entrypoint)) + (init_params args m.(mod_args))))) (empty_stack m)) | step_return : forall g m asr i r sf pc mst asa, @@ -884,9 +886,9 @@ Lemma semantics_determinate : Proof. intros. constructor; set (ge := Globalenvs.Genv.globalenv p); simplify. - invert H; invert H0; constructor. (* Traces are always empty *) - - invert H; invert H0; crush. - (*pose proof (mis_stepp_determinate H4 H13)*) - admit. + - invert H; invert H0; crush. assert (f = f0) by admit; subst. + pose proof (mis_stepp_determinate H5 H15). + crush. - constructor. invert H; crush. - invert H; invert H0; unfold ge0, ge1 in *; crush. - red; simplify; intro; invert H0; invert H; crush. -- cgit From ec97745e4675b72cbabd2a3bd12d6efdd8bfa6d6 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Mon, 6 Jul 2020 15:33:04 +0100 Subject: Implemented algorithm for new byte-addressed stack. --- src/common/Coquplib.v | 2 + src/common/IntegerExtra.v | 36 +- src/common/Monad.v | 4 + src/extraction/Extraction.v | 4 +- src/translation/HTLgen.v | 88 +- src/translation/HTLgenproof.v | 4311 +++++++++++++++++++++-------------------- src/translation/HTLgenspec.v | 918 ++++----- src/verilog/PrintHTL.ml | 2 +- src/verilog/PrintVerilog.ml | 10 +- src/verilog/PrintVerilog.mli | 4 +- src/verilog/Verilog.v | 33 +- 11 files changed, 2730 insertions(+), 2682 deletions(-) diff --git a/src/common/Coquplib.v b/src/common/Coquplib.v index 2295ff6..469eddc 100644 --- a/src/common/Coquplib.v +++ b/src/common/Coquplib.v @@ -235,3 +235,5 @@ Definition debug_show {A B : Type} `{Show A} (a : A) (b : B) : B := Definition debug_show_msg {A B : Type} `{Show A} (s : string) (a : A) (b : B) : B := let unused := debug_print (s ++ show a) in b. + +Notation "f $ x" := (f x) (at level 60, right associativity, only parsing). diff --git a/src/common/IntegerExtra.v b/src/common/IntegerExtra.v index fe7d94f..8e32c2c 100644 --- a/src/common/IntegerExtra.v +++ b/src/common/IntegerExtra.v @@ -298,44 +298,48 @@ Module IntExtra. (or (shl (repr (Byte.unsigned c)) (repr Byte.zwordsize)) (repr (Byte.unsigned d)))). - Definition byte1 (n: int) : byte := Byte.repr (unsigned n). + Definition byte0 (n: int) : byte := Byte.repr $ unsigned n. + Definition ibyte0 (n: int) : int := Int.repr $ Byte.unsigned $ byte0 n. - Definition byte2 (n: int) : byte := Byte.repr (unsigned (shru n (repr Byte.zwordsize))). + Definition byte1 (n: int) : byte := Byte.repr $ unsigned $ shru n $ repr Byte.zwordsize. + Definition ibyte1 (n: int) : int := Int.repr $ Byte.unsigned $ byte1 n. - Definition byte3 (n: int) : byte := Byte.repr (unsigned (shru n (repr (2 * Byte.zwordsize)))). + Definition byte2 (n: int) : byte := Byte.repr $ unsigned $ shru n $ repr (2 * Byte.zwordsize). + Definition ibyte2 (n: int) : int := Int.repr $ Byte.unsigned $ byte2 n. - Definition byte4 (n: int) : byte := Byte.repr (unsigned (shru n (repr (3 * Byte.zwordsize)))). + Definition byte3 (n: int) : byte := Byte.repr $ unsigned $ shru n $ repr (3 * Byte.zwordsize). + Definition ibyte3 (n: int) : int := Int.repr $ Byte.unsigned $ byte3 n. - Lemma bits_byte1: - forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte1 n) i = testbit n i. + Lemma bits_byte0: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte0 n) i = testbit n i. Proof. - intros. unfold byte1. rewrite Byte.testbit_repr; auto. + intros. unfold byte0. rewrite Byte.testbit_repr; auto. Qed. - Lemma bits_byte2: - forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte2 n) i = testbit n (i + Byte.zwordsize). + Lemma bits_byte1: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte1 n) i = testbit n (i + Byte.zwordsize). Proof. - intros. unfold byte2. rewrite Byte.testbit_repr; auto. + intros. unfold byte1. rewrite Byte.testbit_repr; auto. assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. fold (testbit (shru n (repr Byte.zwordsize)) i). rewrite bits_shru. change (unsigned (repr Byte.zwordsize)) with Byte.zwordsize. apply zlt_true. omega. omega. Qed. - Lemma bits_byte3: - forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte3 n) i = testbit n (i + (2 * Byte.zwordsize)). + Lemma bits_byte2: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte2 n) i = testbit n (i + (2 * Byte.zwordsize)). Proof. - intros. unfold byte3. rewrite Byte.testbit_repr; auto. + intros. unfold byte2. rewrite Byte.testbit_repr; auto. assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. fold (testbit (shru n (repr (2 * Byte.zwordsize))) i). rewrite bits_shru. change (unsigned (repr (2 * Byte.zwordsize))) with (2 * Byte.zwordsize). apply zlt_true. omega. omega. Qed. - Lemma bits_byte4: - forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte4 n) i = testbit n (i + (3 * Byte.zwordsize)). + Lemma bits_byte3: + forall n i, 0 <= i < Byte.zwordsize -> Byte.testbit (byte3 n) i = testbit n (i + (3 * Byte.zwordsize)). Proof. - intros. unfold byte4. rewrite Byte.testbit_repr; auto. + intros. unfold byte3. rewrite Byte.testbit_repr; auto. assert (zwordsize = 4 * Byte.zwordsize) by reflexivity. fold (testbit (shru n (repr (3 * Byte.zwordsize))) i). rewrite bits_shru. change (unsigned (repr (3 * Byte.zwordsize))) with (3 * Byte.zwordsize). diff --git a/src/common/Monad.v b/src/common/Monad.v index 8517186..628963e 100644 --- a/src/common/Monad.v +++ b/src/common/Monad.v @@ -20,6 +20,10 @@ Module MonadExtra(M : Monad). Module MonadNotation. + Notation "A ; B" := + (bind A (fun _ => B)) + (at level 200, B at level 200). + Notation "'do' X <- A ; B" := (bind A (fun X => B)) (at level 200, X ident, A at level 100, B at level 200). diff --git a/src/extraction/Extraction.v b/src/extraction/Extraction.v index df21dc4..5d10cd7 100644 --- a/src/extraction/Extraction.v +++ b/src/extraction/Extraction.v @@ -16,7 +16,7 @@ * along with this program. If not, see . *) -From coqup Require Verilog Value Compiler. +From coqup Require Verilog ValueInt Compiler. From Coq Require DecidableClass. @@ -167,7 +167,7 @@ Set Extraction AccessOpaque. Cd "src/extraction". Separate Extraction - Verilog.module Value.uvalueToZ coqup.Compiler.transf_hls + Verilog.module ValueInt.uvalueToZ coqup.Compiler.transf_hls Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index e02d759..995977c 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -292,26 +292,16 @@ Definition check_address_parameter_unsigned (p : Z) : bool := Definition translate_eff_addressing (a: Op.addressing) (args: list reg) : mon expr := match a, args with (* TODO: We should be more methodical here; what are the possibilities?*) | Op.Aindexed off, r1::nil => - if (check_address_parameter_signed off) - then ret (boplitz Vadd r1 off) - else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed): address misaligned") + ret (boplitz Vadd r1 off) | Op.Ascaled scale offset, r1::nil => - if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue offset))) - else error (Errors.msg "Veriloggen: translate_eff_addressing (Ascaled): address misaligned") + ret (Vbinop Vadd (boplitz Vmul r1 scale) (Vlit (ZToValue offset))) | Op.Aindexed2 offset, r1::r2::nil => - if (check_address_parameter_signed offset) - then ret (Vbinop Vadd (Vvar r1) (boplitz Vadd r2 offset)) - else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed2): address misaligned") + ret (Vbinop Vadd (Vvar r1) (boplitz Vadd r2 offset)) | Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) - if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) - else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed2scaled): address misaligned") + ret (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) let a := Integers.Ptrofs.unsigned a in - if (check_address_parameter_unsigned a) - then ret (Vlit (ZToValue a)) - else error (Errors.msg "Veriloggen: translate_eff_addressing (Ainstack): address misaligned") + ret (Vlit (ZToValue a)) | _, _ => error (Errors.msg "Veriloggen: translate_eff_addressing unsuported addressing") end. @@ -390,27 +380,27 @@ Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit := | _, _ => Error (Errors.msg "Htlgen: add_branch_instr") end. -Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing) - (args : list reg) (stack : reg) : mon expr := - match mem, addr, args with (* TODO: We should be more methodical here; what are the possibilities?*) - | Mint32, Op.Aindexed off, r1::nil => - if (check_address_parameter_signed off) - then ret (Vvari stack (Vbinop Vdivu (boplitz Vadd r1 off) (Vlit (ZToValue 4)))) - else error (Errors.msg "HTLgen: translate_arr_access address misaligned") - | Mint32, Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) - if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vvari stack - (Vbinop Vdivu - (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) - (Vlit (ZToValue 4)))) - else error (Errors.msg "HTLgen: translate_arr_access address misaligned") - | Mint32, Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) - let a := Integers.Ptrofs.unsigned a in - if (check_address_parameter_unsigned a) - then ret (Vvari stack (Vlit (ZToValue (a / 4)))) - else error (Errors.msg "HTLgen: eff_addressing misaligned stack offset") - | _, _, _ => error (Errors.msg "HTLgen: translate_arr_access unsuported addressing") - end. +(* Definition translate_arr_access (mem : AST.memory_chunk) (addr : Op.addressing) *) +(* (args : list reg) (stack : reg) : mon expr := *) +(* match mem, addr, args with (* TODO: We should be more methodical here; what are the possibilities?*) *) +(* | Mint32, Op.Aindexed off, r1::nil => *) +(* if (check_address_parameter_signed off) *) +(* then ret (Vvari stack (Vbinop Vdivu (boplitz Vadd r1 off) (Vlit (ZToValue 4)))) *) +(* else error (Errors.msg "HTLgen: translate_arr_access address misaligned") *) +(* | Mint32, Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) *) +(* if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) *) +(* then ret (Vvari stack *) +(* (Vbinop Vdivu *) +(* (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) *) +(* (Vlit (ZToValue 4)))) *) +(* else error (Errors.msg "HTLgen: translate_arr_access address misaligned") *) +(* | Mint32, Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) *) +(* let a := Integers.Ptrofs.unsigned a in *) +(* if (check_address_parameter_unsigned a) *) +(* then ret (Vvari stack (Vlit (ZToValue (a / 4)))) *) +(* else error (Errors.msg "HTLgen: eff_addressing misaligned stack offset") *) +(* | _, _, _ => error (Errors.msg "HTLgen: translate_arr_access unsuported addressing") *) +(* end. *) Fixpoint enumerate (i : nat) (ns : list node) {struct ns} : list (nat * node) := match ns with @@ -424,6 +414,22 @@ Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) := end) (enumerate 0 ns). +Definition add_single_cycle_load (n n' : node) (stack : reg) (addr : expr) (dst : reg) : mon unit := + let l0 := Vnonblock (Vvarb0 dst) (Vvari stack addr) in + let l1 := Vnonblock (Vvarb1 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 1)) in + let l2 := Vnonblock (Vvarb2 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) in + let l3 := Vnonblock (Vvarb3 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) in + let instr := Vseq l0 $ Vseq l1 $ Vseq l2 $ l3 + in add_instr n n' instr. + +Definition add_single_cycle_store (n n' : node) (stack : reg) (addr : expr) (src : reg) : mon unit := + let l0 := Vnonblock (Vvari stack addr) (Vvarb0 src) in + let l1 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 1)) (Vvarb1 src) in + let l2 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb2 src) in + let l3 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb3 src) in + let instr := Vseq l0 $ Vseq l1 $ Vseq l2 $ l3 + in add_instr n n' instr. + Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon unit := match ni with (n, i) => @@ -434,12 +440,12 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni do _ <- declare_reg None dst 32; add_instr n n' (nonblock dst instr) | Iload mem addr args dst n' => - do src <- translate_arr_access mem addr args stack; + do addr' <- translate_eff_addressing addr args; do _ <- declare_reg None dst 32; - add_instr n n' (nonblock dst src) + add_single_cycle_load n n' stack addr' dst | Istore mem addr args src n' => - do dst <- translate_arr_access mem addr args stack; - add_instr n n' (Vnonblock dst (Vvar src)) (* TODO: Could juse use add_instr? reg exists. *) + do addr' <- translate_eff_addressing addr args; + add_single_cycle_store n n' stack addr' src | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.") | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.") | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.") @@ -543,7 +549,7 @@ Definition transf_module (f: function) : mon module := if stack_correct f.(fn_stacksize) then do fin <- create_reg (Some Voutput) 1; do rtrn <- create_reg (Some Voutput) 32; - do (stack, stack_len) <- create_arr None 32 (Z.to_nat (f.(fn_stacksize) / 4)); + do (stack, stack_len) <- create_arr None 8 (Z.to_nat f.(fn_stacksize)); do _ <- collectlist (transf_instr fin rtrn stack) (Maps.PTree.elements f.(RTL.fn_code)); do _ <- collectlist (fun r => declare_reg (Some Vinput) r 32) f.(RTL.fn_params); do start <- create_reg (Some Vinput) 1; diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 305c14f..e404c82 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -31,2158 +31,2159 @@ Hint Resolve AssocMap.gso : htlproof. Hint Unfold find_assocmap AssocMapExt.get_default : htlproof. -Inductive match_assocmaps : RTL.function -> RTL.regset -> assocmap -> Prop := - match_assocmap : forall f rs am, - (forall r, Ple r (RTL.max_reg_function f) -> - val_value_lessdef (Registers.Regmap.get r rs) am#r) -> - match_assocmaps f rs am. -Hint Constructors match_assocmaps : htlproof. - -Definition state_st_wf (m : HTL.module) (s : HTL.state) := - forall st asa asr res, - s = HTL.State res m st asa asr -> - asa!(m.(HTL.mod_st)) = Some (posToValue st). -Hint Unfold state_st_wf : htlproof. - -Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : mem) : - Verilog.assocmap_arr -> Prop := -| match_arr : forall asa stack, - asa ! (m.(HTL.mod_stk)) = Some stack /\ - stack.(arr_length) = Z.to_nat (f.(RTL.fn_stacksize) / 4) /\ - (forall ptr, - 0 <= ptr < Z.of_nat m.(HTL.mod_stk_len) -> - opt_val_value_lessdef (Mem.loadv AST.Mint32 mem - (Values.Val.offset_ptr sp (Integers.Ptrofs.repr (4 * ptr)))) - (Option.default (NToValue 0) - (Option.join (array_get_error (Z.to_nat ptr) stack)))) -> - match_arrs m f sp mem asa. - -Definition stack_based (v : Values.val) (sp : Values.block) : Prop := - match v with - | Values.Vptr sp' off => sp' = sp - | _ => True - end. - -Definition reg_stack_based_pointers (sp : Values.block) (rs : Registers.Regmap.t Values.val) : Prop := - forall r, stack_based (Registers.Regmap.get r rs) sp. - -Definition arr_stack_based_pointers (spb : Values.block) (m : mem) (stack_length : Z) - (sp : Values.val) : Prop := - forall ptr, - 0 <= ptr < (stack_length / 4) -> - stack_based (Option.default - Values.Vundef - (Mem.loadv AST.Mint32 m - (Values.Val.offset_ptr sp (Integers.Ptrofs.repr (4 * ptr))))) - spb. - -Definition stack_bounds (sp : Values.val) (hi : Z) (m : mem) : Prop := - forall ptr v, - hi <= ptr <= Integers.Ptrofs.max_unsigned -> - Z.modulo ptr 4 = 0 -> - Mem.loadv AST.Mint32 m (Values.Val.offset_ptr sp (Integers.Ptrofs.repr ptr )) = None /\ - Mem.storev AST.Mint32 m (Values.Val.offset_ptr sp (Integers.Ptrofs.repr ptr )) v = None. - -Inductive match_frames : list RTL.stackframe -> list HTL.stackframe -> Prop := -| match_frames_nil : - match_frames nil nil. - - Lemma assumption_32bit : - forall v, - valueToPos (posToValue v) = v. - Proof. - Admitted. - -Inductive match_states : RTL.state -> HTL.state -> Prop := -| match_state : forall asa asr sf f sp sp' rs mem m st res - (MASSOC : match_assocmaps f rs asr) - (TF : tr_module f m) - (WF : state_st_wf m (HTL.State res m st asr asa)) - (MF : match_frames sf res) - (MARR : match_arrs m f sp mem asa) - (SP : sp = Values.Vptr sp' (Integers.Ptrofs.repr 0)) - (RSBP : reg_stack_based_pointers sp' rs) - (ASBP : arr_stack_based_pointers sp' mem (f.(RTL.fn_stacksize)) sp) - (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem), - match_states (RTL.State sf f sp st rs mem) - (HTL.State res m st asr asa) -| match_returnstate : - forall - v v' stack mem res - (MF : match_frames stack res), - val_value_lessdef v v' -> - match_states (RTL.Returnstate stack v mem) (HTL.Returnstate res v') -| match_initial_call : - forall f m m0 - (TF : tr_module f m), - match_states (RTL.Callstate nil (AST.Internal f) nil m0) (HTL.Callstate nil m nil). -Hint Constructors match_states : htlproof. - -Definition match_prog (p: RTL.program) (tp: HTL.program) := - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp /\ - main_is_internal p = true. - -Definition match_prog_matches : - forall p tp, - match_prog p tp -> - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. - Proof. intros. unfold match_prog in H. tauto. Qed. - -Lemma transf_program_match: - forall p tp, HTLgen.transl_program p = Errors.OK tp -> match_prog p tp. -Proof. - intros. unfold transl_program in H. - destruct (main_is_internal p) eqn:?; try discriminate. - unfold match_prog. split. - apply Linking.match_transform_partial_program; auto. - assumption. -Qed. - -Lemma regs_lessdef_add_greater : - forall f rs1 rs2 n v, - Plt (RTL.max_reg_function f) n -> - match_assocmaps f rs1 rs2 -> - match_assocmaps f rs1 (AssocMap.set n v rs2). -Proof. - inversion 2; subst. - intros. constructor. - intros. unfold find_assocmap. unfold AssocMapExt.get_default. - rewrite AssocMap.gso. eauto. - apply Pos.le_lt_trans with _ _ n in H2. - unfold not. intros. subst. eapply Pos.lt_irrefl. eassumption. assumption. -Qed. -Hint Resolve regs_lessdef_add_greater : htlproof. - -Lemma regs_lessdef_add_match : - forall f rs am r v v', - val_value_lessdef v v' -> - match_assocmaps f rs am -> - match_assocmaps f (Registers.Regmap.set r v rs) (AssocMap.set r v' am). -Proof. - inversion 2; subst. - constructor. intros. - destruct (peq r0 r); subst. - rewrite Registers.Regmap.gss. - unfold find_assocmap. unfold AssocMapExt.get_default. - rewrite AssocMap.gss. assumption. - - rewrite Registers.Regmap.gso; try assumption. - unfold find_assocmap. unfold AssocMapExt.get_default. - rewrite AssocMap.gso; eauto. -Qed. -Hint Resolve regs_lessdef_add_match : htlproof. - -Lemma list_combine_none : - forall n l, - length l = n -> - list_combine Verilog.merge_cell (list_repeat None n) l = l. -Proof. - induction n; intros; crush. - - symmetry. apply length_zero_iff_nil. auto. - - destruct l; crush. - rewrite list_repeat_cons. - crush. f_equal. - eauto. -Qed. - -Lemma combine_none : - forall n a, - a.(arr_length) = n -> - arr_contents (combine Verilog.merge_cell (arr_repeat None n) a) = arr_contents a. -Proof. - intros. - unfold combine. - crush. - - rewrite <- (arr_wf a) in H. - apply list_combine_none. - assumption. -Qed. - -Lemma list_combine_lookup_first : - forall l1 l2 n, - length l1 = length l2 -> - nth_error l1 n = Some None -> - nth_error (list_combine Verilog.merge_cell l1 l2) n = nth_error l2 n. -Proof. - induction l1; intros; crush. - - rewrite nth_error_nil in H0. - discriminate. - - destruct l2 eqn:EQl2. crush. - simpl in H. invert H. - destruct n; simpl in *. - invert H0. simpl. reflexivity. - eauto. -Qed. - -Lemma combine_lookup_first : - forall a1 a2 n, - a1.(arr_length) = a2.(arr_length) -> - array_get_error n a1 = Some None -> - array_get_error n (combine Verilog.merge_cell a1 a2) = array_get_error n a2. -Proof. - intros. - - unfold array_get_error in *. - apply list_combine_lookup_first; eauto. - rewrite a1.(arr_wf). rewrite a2.(arr_wf). - assumption. -Qed. - -Lemma list_combine_lookup_second : - forall l1 l2 n x, - length l1 = length l2 -> - nth_error l1 n = Some (Some x) -> - nth_error (list_combine Verilog.merge_cell l1 l2) n = Some (Some x). -Proof. - induction l1; intros; crush; auto. - - destruct l2 eqn:EQl2. crush. - simpl in H. invert H. - destruct n; simpl in *. - invert H0. simpl. reflexivity. - eauto. -Qed. - -Lemma combine_lookup_second : - forall a1 a2 n x, - a1.(arr_length) = a2.(arr_length) -> - array_get_error n a1 = Some (Some x) -> - array_get_error n (combine Verilog.merge_cell a1 a2) = Some (Some x). -Proof. - intros. - - unfold array_get_error in *. - apply list_combine_lookup_second; eauto. - rewrite a1.(arr_wf). rewrite a2.(arr_wf). - assumption. -Qed. - -Ltac inv_state := - match goal with - MSTATE : match_states _ _ |- _ => - inversion MSTATE; - match goal with - TF : tr_module _ _ |- _ => - inversion TF; - match goal with - TC : forall _ _, - Maps.PTree.get _ _ = Some _ -> tr_code _ _ _ _ _ _ _ _ _, - H : Maps.PTree.get _ _ = Some _ |- _ => - apply TC in H; inversion H; - match goal with - TI : context[tr_instr] |- _ => - inversion TI - end - end - end -end; subst. - -Ltac unfold_func H := - match type of H with - | ?f = _ => unfold f in H; repeat (unfold_match H) - | ?f _ = _ => unfold f in H; repeat (unfold_match H) - | ?f _ _ = _ => unfold f in H; repeat (unfold_match H) - | ?f _ _ _ = _ => unfold f in H; repeat (unfold_match H) - | ?f _ _ _ _ = _ => unfold f in H; repeat (unfold_match H) - end. - -Lemma init_reg_assoc_empty : - forall f l, - match_assocmaps f (RTL.init_regs nil l) (HTL.init_regs nil l). -Proof. - induction l; simpl; constructor; intros. - - rewrite Registers.Regmap.gi. unfold find_assocmap. - unfold AssocMapExt.get_default. rewrite AssocMap.gempty. - constructor. - - - rewrite Registers.Regmap.gi. unfold find_assocmap. - unfold AssocMapExt.get_default. rewrite AssocMap.gempty. - constructor. -Qed. - -Lemma arr_lookup_some: - forall (z : Z) (r0 : Registers.reg) (r : Verilog.reg) (asr : assocmap) (asa : Verilog.assocmap_arr) - (stack : Array (option value)) (H5 : asa ! r = Some stack) n, - exists x, Verilog.arr_assocmap_lookup asa r n = Some x. -Proof. - intros z r0 r asr asa stack H5 n. - eexists. - unfold Verilog.arr_assocmap_lookup. rewrite H5. reflexivity. -Qed. -Hint Resolve arr_lookup_some : htlproof. - -Section CORRECTNESS. - - Variable prog : RTL.program. - Variable tprog : HTL.program. - - Hypothesis TRANSL : match_prog prog tprog. - - Lemma TRANSL' : - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog. - Proof. intros; apply match_prog_matches; assumption. Qed. - - Let ge : RTL.genv := Globalenvs.Genv.globalenv prog. - Let tge : HTL.genv := Globalenvs.Genv.globalenv tprog. - - Lemma symbols_preserved: - forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. - Proof. intros. eapply (Genv.find_symbol_match TRANSL'). Qed. - - Lemma function_ptr_translated: - forall (b: Values.block) (f: RTL.fundef), - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Errors.OK tf. - Proof. - intros. exploit (Genv.find_funct_ptr_match TRANSL'); eauto. - intros (cu & tf & P & Q & R); exists tf; auto. - Qed. - - Lemma functions_translated: - forall (v: Values.val) (f: RTL.fundef), - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transl_fundef f = Errors.OK tf. - Proof. - intros. exploit (Genv.find_funct_match TRANSL'); eauto. - intros (cu & tf & P & Q & R); exists tf; auto. - Qed. - - Lemma senv_preserved: - Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). - Proof - (Genv.senv_transf_partial TRANSL'). - Hint Resolve senv_preserved : htlproof. - - Lemma ptrofs_inj : - forall a b, - Ptrofs.unsigned a = Ptrofs.unsigned b -> a = b. - Proof. - intros. rewrite <- Ptrofs.repr_unsigned. symmetry. rewrite <- Ptrofs.repr_unsigned. - rewrite H. auto. - Qed. - - Lemma eval_correct : - forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, - match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> - (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> - Op.eval_operation ge sp op - (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> - translate_instr op args s = OK e s' i -> - exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. - Proof. - intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. - inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; - unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); simplify. - - inv Heql. - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H in HPle. eexists. split; try constructor; eauto. - - eexists. split. constructor. constructor. auto. - - inv Heql. - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H in HPle. - eexists. split. econstructor; eauto. constructor. trivial. - unfold Verilog.unop_run. unfold Values.Val.neg. destruct (Registers.Regmap.get r rs) eqn:?; constructor. - inv HPle. auto. - - inv Heql. - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - assert (HPle0 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H in HPle. apply H in HPle0. - eexists. split. econstructor; eauto. constructor. trivial. - constructor. trivial. simplify. inv HPle. inv HPle0; constructor; auto. - + inv HPle0. constructor. unfold valueToPtr. Search Integers.Ptrofs.sub Integers.int. - pose proof Integers.Ptrofs.agree32_sub. unfold Integers.Ptrofs.agree32 in H3. - Print Integers.Ptrofs.agree32. unfold Ptrofs.of_int. simpl. - apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H3 in H4. - rewrite Ptrofs.unsigned_repr. apply H4. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. - auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. - replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. - Admitted. - - Lemma eval_cond_correct : - forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, - translate_condition cond args s1 = OK c s' i -> - Op.eval_condition - cond - (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) - m = Some b -> - Verilog.expr_runp f asr asa c (boolToValue b). - Admitted. - - (** The proof of semantic preservation for the translation of instructions - is a simulation argument based on diagrams of the following form: -<< - match_states - code st rs ---------------- State m st assoc - || | - || | - || | - \/ v - code st rs' --------------- State m st assoc' - match_states ->> - where [tr_code c data control fin rtrn st] is assumed to hold. - - The precondition and postcondition is that that should hold is [match_assocmaps rs assoc]. - *) - - Definition transl_instr_prop (instr : RTL.instruction) : Prop := - forall m asr asa fin rtrn st stmt trans res, - tr_instr fin rtrn st (m.(HTL.mod_stk)) instr stmt trans -> - exists asr' asa', - HTL.step tge (HTL.State res m st asr asa) Events.E0 (HTL.State res m st asr' asa'). - - Opaque combine. - - Ltac tac0 := - match goal with - | [ |- context[valueToPos (posToValue _)] ] => rewrite assumption_32bit - - | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs - | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr - | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge - | [ |- context[reg_stack_based_pointers] ] => unfold reg_stack_based_pointers; intros - | [ |- context[Verilog.arr_assocmap_set _ _ _ _] ] => unfold Verilog.arr_assocmap_set - - | [ |- context[HTL.empty_stack] ] => unfold HTL.empty_stack - - | [ |- context[_ # ?d <- _ ! ?d] ] => rewrite AssocMap.gss - | [ |- context[_ # ?d <- _ ! ?s] ] => rewrite AssocMap.gso - | [ |- context[(AssocMap.empty _) ! _] ] => rewrite AssocMap.gempty - - | [ |- context[array_get_error _ (combine Verilog.merge_cell (arr_repeat None _) _)] ] => - rewrite combine_lookup_first - - | [ |- state_st_wf _ _ ] => unfold state_st_wf; inversion 1 - | [ |- context[match_states _ _] ] => econstructor; auto - | [ |- match_arrs _ _ _ _ _ ] => econstructor; auto - | [ |- match_assocmaps _ _ _ # _ <- (posToValue _) ] => - apply regs_lessdef_add_greater; [> unfold Plt; lia | assumption] - - | [ H : ?asa ! ?r = Some _ |- Verilog.arr_assocmap_lookup ?asa ?r _ = Some _ ] => - unfold Verilog.arr_assocmap_lookup; setoid_rewrite H; f_equal - | [ |- context[(AssocMap.combine _ _ _) ! _] ] => - try (rewrite AssocMap.gcombine; [> | reflexivity]) - - | [ |- context[Registers.Regmap.get ?d (Registers.Regmap.set ?d _ _)] ] => - rewrite Registers.Regmap.gss - | [ |- context[Registers.Regmap.get ?s (Registers.Regmap.set ?d _ _)] ] => - destruct (Pos.eq_dec s d) as [EQ|EQ]; - [> rewrite EQ | rewrite Registers.Regmap.gso; auto] - - | [ H : opt_val_value_lessdef _ _ |- _ ] => invert H - | [ H : context[Z.of_nat (Z.to_nat _)] |- _ ] => rewrite Z2Nat.id in H; [> solve crush |] - | [ H : _ ! _ = Some _ |- _] => setoid_rewrite H - end. - - Ltac small_tac := repeat (crush; try array; try ptrofs); crush; auto. - Ltac big_tac := repeat (crush; try array; try ptrofs; try tac0); crush; auto. - - Lemma transl_inop_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : RTL.regset) (m : mem) (pc' : RTL.node), - (RTL.fn_code f) ! pc = Some (RTL.Inop pc') -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. - Proof. - intros s f sp pc rs m pc' H R1 MSTATE. - inv_state. - - unfold match_prog in TRANSL. - econstructor. - split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - apply assumption_32bit. - (* processing of state *) - econstructor. - crush. - econstructor. - econstructor. - econstructor. - - all: invert MARR; big_tac. - Unshelve. - constructor. - Qed. - Hint Resolve transl_inop_correct : htlproof. - - Lemma transl_iop_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (op : Op.operation) (args : list Registers.reg) - (res0 : Registers.reg) (pc' : RTL.node) (v : Values.val), - (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> - Op.eval_operation ge sp op (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. - Proof. - intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. - inv_state. - exploit eval_correct; eauto. intros. inversion H1. inversion H2. - econstructor. split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - apply assumption_32bit. - econstructor; simpl; trivial. - constructor; trivial. - econstructor; simpl; eauto. - simpl. econstructor. econstructor. - apply H3. simplify. - - all: big_tac. - - assert (Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - - unfold Ple in H10. lia. - apply regs_lessdef_add_match. assumption. - apply regs_lessdef_add_greater. unfold Plt; lia. assumption. - assert (Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in H12; lia. - unfold_merge. simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - - (*match_states*) - assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. - rewrite <- H1. - constructor; auto. - unfold_merge. - apply regs_lessdef_add_match. - constructor. - apply regs_lessdef_add_greater. - apply greater_than_max_func. - assumption. - - unfold state_st_wf. intros. inversion H2. subst. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - - + econstructor. split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - econstructor; simpl; trivial. - constructor; trivial. - econstructor; simpl; eauto. - eapply eval_correct; eauto. - constructor. rewrite valueToInt_intToValue. trivial. - unfold_merge. simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - - match_states - assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. - rewrite <- H1. - constructor. - unfold_merge. - apply regs_lessdef_add_match. - constructor. - symmetry. apply valueToInt_intToValue. - apply regs_lessdef_add_greater. - apply greater_than_max_func. - assumption. assumption. - - unfold state_st_wf. intros. inversion H2. subst. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - assumption. - Admitted. - Hint Resolve transl_iop_correct : htlproof. - - Ltac tac := - repeat match goal with - | [ _ : error _ _ = OK _ _ _ |- _ ] => discriminate - | [ _ : context[if (?x && ?y) then _ else _] |- _ ] => - let EQ1 := fresh "EQ" in - let EQ2 := fresh "EQ" in - destruct x eqn:EQ1; destruct y eqn:EQ2; simpl in * - | [ _ : context[if ?x then _ else _] |- _ ] => - let EQ := fresh "EQ" in - destruct x eqn:EQ; simpl in * - | [ H : ret _ _ = _ |- _ ] => invert H - | [ _ : context[match ?x with | _ => _ end] |- _ ] => destruct x - end. - - Ltac inv_arr_access := - match goal with - | [ _ : translate_arr_access ?chunk ?addr ?args _ _ = OK ?c _ _ |- _] => - destruct c, chunk, addr, args; crush; tac; crush - end. - - Lemma transl_iload_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) - (addr : Op.addressing) (args : list Registers.reg) (dst : Registers.reg) - (pc' : RTL.node) (a v : Values.val), - (RTL.fn_code f) ! pc = Some (RTL.Iload chunk addr args dst pc') -> - Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> - Mem.loadv chunk m a = Some v -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc' (Registers.Regmap.set dst v rs) m) R2. - Proof. - intros s f sp pc rs m chunk addr args dst pc' a v H H0 H1 R1 MSTATE. - inv_state. inv_arr_access. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. - - rewrite ARCHI in H1. crush. - subst. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - apply H6 in HPler0. - invert HPler0; try congruence. - rewrite EQr0 in H8. - invert H8. - clear H0. clear H6. - - unfold check_address_parameter_signed in *; - unfold check_address_parameter_unsigned in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Read bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - rewrite <- EXPR_OK. - - specialize (H7 (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4)))). - exploit H7; big_tac. - - (** RSBP preservation *) - unfold arr_stack_based_pointers in ASBP. - specialize (ASBP (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). - exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - pose proof (RSBP r1) as RSBPr1. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; - destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. - - rewrite ARCHI in H1. crush. - subst. - clear RSBPr1. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - pose proof (H0 r1). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - assert (HPler1 : Ple r1 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H6 in HPler0. - apply H8 in HPler1. - invert HPler0; invert HPler1; try congruence. - rewrite EQr0 in H9. - rewrite EQr1 in H11. - invert H9. invert H11. - clear H0. clear H6. clear H8. - - unfold check_address_parameter_signed in *; - unfold check_address_parameter_unsigned in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int - (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) - (Integers.Int.repr z0)))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - apply IntExtra.add_mod; crush. - apply IntExtra.mul_mod2; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Read bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - rewrite <- EXPR_OK. - - specialize (H7 (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4)))). - exploit H7; big_tac. - - (** RSBP preservation *) - unfold arr_stack_based_pointers in ASBP. - specialize (ASBP (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). - exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption. - - + invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - rewrite ARCHI in H0. crush. - - unfold check_address_parameter_unsigned in *; - unfold check_address_parameter_signed in *; crush. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - rewrite ZERO in H1. clear ZERO. - rewrite Integers.Ptrofs.add_zero_l in H1. - - remember i0 as OFFSET. - - (** Modular preservation proof *) - rename H0 into MOD_PRESERVE. - - (** Read bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - rewrite <- EXPR_OK. - - specialize (H7 (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4)))). - exploit H7; big_tac. - - (** RSBP preservation *) - unfold arr_stack_based_pointers in ASBP. - specialize (ASBP (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). - exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption. - Admitted. - Hint Resolve transl_iload_correct : htlproof. - - Lemma transl_istore_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) - (addr : Op.addressing) (args : list Registers.reg) (src : Registers.reg) - (pc' : RTL.node) (a : Values.val) (m' : mem), - (RTL.fn_code f) ! pc = Some (RTL.Istore chunk addr args src pc') -> - Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> - Mem.storev chunk m a (Registers.Regmap.get src rs) = Some m' -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m') R2. - Proof. - intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. - inv_state. inv_arr_access. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. - - rewrite ARCHI in H1. crush. - subst. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - apply H6 in HPler0. - invert HPler0; try congruence. - rewrite EQr0 in H8. - invert H8. - clear H0. clear H6. - - unfold check_address_parameter_unsigned in *; - unfold check_address_parameter_signed in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Write bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - inversion MASSOC; revert HeqOFFSET; subst; clear MASSOC; intros HeqOFFSET. - - econstructor. - repeat split; crush. - unfold HTL.empty_stack. - crush. - unfold Verilog.merge_arrs. - - rewrite AssocMap.gcombine. - 2: { reflexivity. } - unfold Verilog.arr_assocmap_set. - rewrite AssocMap.gss. - unfold Verilog.merge_arr. - rewrite AssocMap.gss. - setoid_rewrite H5. - reflexivity. - - rewrite combine_length. - rewrite <- array_set_len. - unfold arr_repeat. crush. - apply list_repeat_len. - - rewrite <- array_set_len. - unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. - - destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). - - erewrite Mem.load_store_same. - 2: { rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite e. - rewrite Integers.Ptrofs.unsigned_repr. - exact H1. - apply Integers.Ptrofs.unsigned_range_2. } - constructor. - erewrite combine_lookup_second. - simpl. - assert (Ple src (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H0 in H13. - destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H13; eauto. - - rewrite <- array_set_len. - unfold arr_repeat. crush. - rewrite list_repeat_len. auto. - - assert (4 * ptr / 4 = Integers.Ptrofs.unsigned OFFSET / 4) by (f_equal; assumption). - rewrite Z.mul_comm in H13. - rewrite Z_div_mult in H13; try lia. - replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H13 by reflexivity. - rewrite <- PtrofsExtra.divu_unsigned in H13; unfold_constants; try lia. - rewrite H13. rewrite EXPR_OK. - rewrite array_get_error_set_bound. - reflexivity. - unfold arr_length, arr_repeat. simpl. - rewrite list_repeat_len. lia. - - erewrite Mem.load_store_other with (m1 := m). - 2: { exact H1. } - 2: { right. - rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite Integers.Ptrofs.unsigned_repr. - simpl. - destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. - right. - apply ZExtra.mod_0_bounds; try lia. - apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H15; try lia. - apply Zmult_lt_compat_r with (p := 4) in H15; try lia. - rewrite ZLib.div_mul_undo in H15; try lia. - split; try lia. - apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. - } - - rewrite <- EXPR_OK. - rewrite PtrofsExtra.divu_unsigned; auto; try (unfold_constants; lia). - destruct (ptr ==Z Integers.Ptrofs.unsigned OFFSET / 4). - apply Z.mul_cancel_r with (p := 4) in e; try lia. - rewrite ZLib.div_mul_undo in e; try lia. - rewrite combine_lookup_first. - eapply H7; eauto. - - rewrite <- array_set_len. - unfold arr_repeat. crush. - rewrite list_repeat_len. auto. - rewrite array_gso. - unfold array_get_error. - unfold arr_repeat. - crush. - apply list_repeat_lookup. - lia. - unfold_constants. - intro. - apply Z2Nat.inj_iff in H13; try lia. - apply Z.div_pos; try lia. - apply Integers.Ptrofs.unsigned_range. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - unfold arr_stack_based_pointers. - intros. - destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). - - crush. - erewrite Mem.load_store_same. - 2: { rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite e. - rewrite Integers.Ptrofs.unsigned_repr. - exact H1. - apply Integers.Ptrofs.unsigned_range_2. } - crush. - destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; try constructor. - destruct (Archi.ptr64); try discriminate. - pose proof (RSBP src). rewrite EQ_SRC in H0. - assumption. - - simpl. - erewrite Mem.load_store_other with (m1 := m). - 2: { exact H1. } - 2: { right. - rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite Integers.Ptrofs.unsigned_repr. - simpl. - destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. - right. - apply ZExtra.mod_0_bounds; try lia. - apply ZLib.Z_mod_mult'. - invert H0. - apply Zmult_lt_compat_r with (p := 4) in H14; try lia. - rewrite ZLib.div_mul_undo in H14; try lia. - split; try lia. - apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. - } - apply ASBP; assumption. - - unfold stack_bounds in *. intros. - simpl. - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - erewrite Mem.load_store_other with (m1 := m). - 2: { exact H1. } - 2: { right. right. simpl. - rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite Integers.Ptrofs.unsigned_repr; crush; try lia. - apply ZExtra.mod_0_bounds; crush; try lia. } - crush. - exploit (BOUNDS ptr); try lia. intros. crush. - exploit (BOUNDS ptr v); try lia. intros. - invert H0. - match goal with | |- ?x = _ => destruct x eqn:EQ end; try reflexivity. - assert (Mem.valid_access m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H0. - exact H0. eapply Mem.store_valid_access_3. eassumption. } - pose proof (Mem.valid_access_store m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - pose proof (RSBP r1) as RSBPr1. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; - destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. - - rewrite ARCHI in H1. crush. - subst. - clear RSBPr1. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - pose proof (H0 r1). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - assert (HPler1 : Ple r1 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H6 in HPler0. - apply H8 in HPler1. - invert HPler0; invert HPler1; try congruence. - rewrite EQr0 in H9. - rewrite EQr1 in H11. - invert H9. invert H11. - clear H0. clear H6. clear H8. - - unfold check_address_parameter_signed in *; - unfold check_address_parameter_unsigned in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int - (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) - (Integers.Int.repr z0)))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - apply IntExtra.add_mod; crush. - apply IntExtra.mul_mod2; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Write bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. - assert (Mem.valid_access m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H0. - exact H0. eapply Mem.store_valid_access_3. eassumption. } - pose proof (Mem.valid_access_store m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence. - - + invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - rewrite ARCHI in H0. crush. - - unfold check_address_parameter_unsigned in *; - unfold check_address_parameter_signed in *; crush. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - rewrite ZERO in H1. clear ZERO. - rewrite Integers.Ptrofs.add_zero_l in H1. - - remember i0 as OFFSET. - - (** Modular preservation proof *) - rename H0 into MOD_PRESERVE. - - (** Write bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. - assert (Mem.valid_access m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H0. - exact H0. eapply Mem.store_valid_access_3. eassumption. } - pose proof (Mem.valid_access_store m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence. - Admitted. - Hint Resolve transl_istore_correct : htlproof. - - Lemma transl_icond_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (cond : Op.condition) (args : list Registers.reg) - (ifso ifnot : RTL.node) (b : bool) (pc' : RTL.node), - (RTL.fn_code f) ! pc = Some (RTL.Icond cond args ifso ifnot) -> - Op.eval_condition cond (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some b -> - pc' = (if b then ifso else ifnot) -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. - Proof. - intros s f sp pc rs m cond args ifso ifnot b pc' H H0 H1 R1 MSTATE. - inv_state. - - eexists. split. apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - apply assumption_32bit. - eapply Verilog.stmnt_runp_Vnonblock_reg with - (rhsval := if b then posToValue 32 ifso else posToValue 32 ifnot). - constructor. - - simpl. - destruct b. - eapply Verilog.erun_Vternary_true. - eapply eval_cond_correct; eauto. - constructor. - apply boolToValue_ValueToBool. - eapply Verilog.erun_Vternary_false. - eapply eval_cond_correct; eauto. - constructor. - apply boolToValue_ValueToBool. - constructor. - - big_tac. - - invert MARR. - destruct b; rewrite assumption_32bit; big_tac. - - Unshelve. - constructor. - Qed. - Hint Resolve transl_icond_correct : htlproof. - - Lemma transl_ijumptable_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (arg : Registers.reg) (tbl : list RTL.node) - (n : Integers.Int.int) (pc' : RTL.node), - (RTL.fn_code f) ! pc = Some (RTL.Ijumptable arg tbl) -> - Registers.Regmap.get arg rs = Values.Vint n -> - list_nth_z tbl (Integers.Int.unsigned n) = Some pc' -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. - Proof. - intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. - Admitted. - Hint Resolve transl_ijumptable_correct : htlproof. - - Lemma transl_ireturn_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) - (pc : positive) (rs : RTL.regset) (m : mem) (or : option Registers.reg) - (m' : mem), - (RTL.fn_code f) ! pc = Some (RTL.Ireturn or) -> - Mem.free m stk 0 (RTL.fn_stacksize f) = Some m' -> - forall R1 : HTL.state, - match_states (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.Returnstate s (Registers.regmap_optget or Values.Vundef rs) m') R2. - Proof. - intros s f stk pc rs m or m' H H0 R1 MSTATE. - inv_state. - - - econstructor. split. - eapply Smallstep.plus_two. - - eapply HTL.step_module; eauto. - apply assumption_32bit. - constructor. - econstructor; simpl; trivial. - econstructor; simpl; trivial. - constructor. - econstructor; simpl; trivial. - constructor. - - constructor. constructor. - - unfold state_st_wf in WF; big_tac; eauto. - - apply HTL.step_finish. - unfold Verilog.merge_regs. - unfold_merge; simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. lia. - apply AssocMap.gss. - rewrite Events.E0_left. reflexivity. - - constructor; auto. - constructor. - - (* FIXME: Duplication *) - - econstructor. split. - eapply Smallstep.plus_two. - eapply HTL.step_module; eauto. - apply assumption_32bit. - constructor. - econstructor; simpl; trivial. - econstructor; simpl; trivial. - constructor. constructor. constructor. - constructor. constructor. constructor. - - unfold state_st_wf in WF; big_tac; eauto. - - apply HTL.step_finish. - unfold Verilog.merge_regs. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. simpl; lia. - apply AssocMap.gss. - rewrite Events.E0_left. trivial. - - constructor; auto. - - simpl. inversion MASSOC. subst. - unfold find_assocmap, AssocMapExt.get_default. rewrite AssocMap.gso. - apply H1. eapply RTL.max_reg_function_use. eauto. simpl; tauto. - assert (HPle : Ple r (RTL.max_reg_function f)). - eapply RTL.max_reg_function_use. eassumption. simpl; auto. - apply ZExtra.Ple_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - - Unshelve. - all: constructor. - Qed. - Hint Resolve transl_ireturn_correct : htlproof. - - Lemma transl_callstate_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) - (m : mem) (m' : Mem.mem') (stk : Values.block), - Mem.alloc m 0 (RTL.fn_stacksize f) = (m', stk) -> - forall R1 : HTL.state, - match_states (RTL.Callstate s (AST.Internal f) args m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states - (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) (RTL.fn_entrypoint f) - (RTL.init_regs args (RTL.fn_params f)) m') R2. - Proof. - intros s f args m m' stk H R1 MSTATE. - - inversion MSTATE; subst. inversion TF; subst. - econstructor. split. apply Smallstep.plus_one. - eapply HTL.step_call. crush. - - apply match_state with (sp' := stk); eauto. - - all: big_tac. - - apply regs_lessdef_add_greater. - unfold Plt; lia. - apply init_reg_assoc_empty. - - constructor. - - destruct (Mem.load AST.Mint32 m' stk - (Integers.Ptrofs.unsigned (Integers.Ptrofs.add - Integers.Ptrofs.zero - (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. - pose proof Mem.load_alloc_same as LOAD_ALLOC. - pose proof H as ALLOC. - eapply LOAD_ALLOC in ALLOC. - 2: { exact LOAD. } - ptrofs. rewrite LOAD. - rewrite ALLOC. - repeat constructor. - - ptrofs. rewrite LOAD. - repeat constructor. - - unfold reg_stack_based_pointers. intros. - unfold RTL.init_regs; crush. - destruct (RTL.fn_params f); - rewrite Registers.Regmap.gi; constructor. - - unfold arr_stack_based_pointers. intros. - crush. - destruct (Mem.load AST.Mint32 m' stk - (Integers.Ptrofs.unsigned (Integers.Ptrofs.add - Integers.Ptrofs.zero - (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. - pose proof Mem.load_alloc_same as LOAD_ALLOC. - pose proof H as ALLOC. - eapply LOAD_ALLOC in ALLOC. - 2: { exact LOAD. } - rewrite ALLOC. - repeat constructor. - constructor. - - Transparent Mem.alloc. (* TODO: Since there are opaque there's probably a lemma. *) - Transparent Mem.load. - Transparent Mem.store. - unfold stack_bounds. - split. - - unfold Mem.alloc in H. - invert H. - crush. - unfold Mem.load. - intros. - match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H4. - unfold Mem.perm in H4. crush. - unfold Mem.perm_order' in H4. - small_tac. - exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. - rewrite Maps.PMap.gss in H8. - match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. - crush. - apply proj_sumbool_true in H10. lia. - - unfold Mem.alloc in H. - invert H. - crush. - unfold Mem.store. - intros. - match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H4. - unfold Mem.perm in H4. crush. - unfold Mem.perm_order' in H4. - small_tac. - exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. - rewrite Maps.PMap.gss in H8. - match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. - crush. - apply proj_sumbool_true in H10. lia. - Opaque Mem.alloc. - Opaque Mem.load. - Opaque Mem.store. - Qed. - Hint Resolve transl_callstate_correct : htlproof. - - Lemma transl_returnstate_correct: - forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) - (rs : RTL.regset) (s : list RTL.stackframe) (vres : Values.val) (m : mem) - (R1 : HTL.state), - match_states (RTL.Returnstate (RTL.Stackframe res0 f sp pc rs :: s) vres m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc (Registers.Regmap.set res0 vres rs) m) R2. - Proof. - intros res0 f sp pc rs s vres m R1 MSTATE. - inversion MSTATE. inversion MF. - Qed. - Hint Resolve transl_returnstate_correct : htlproof. - - Lemma option_inv : - forall A x y, - @Some A x = Some y -> x = y. - Proof. intros. inversion H. trivial. Qed. - - Lemma main_tprog_internal : - forall b, - Globalenvs.Genv.find_symbol tge tprog.(AST.prog_main) = Some b -> - exists f, Genv.find_funct_ptr (Genv.globalenv tprog) b = Some (AST.Internal f). - Proof. - intros. - destruct TRANSL. unfold main_is_internal in H1. - repeat (unfold_match H1). replace b with b0. - exploit function_ptr_translated; eauto. intros [tf [A B]]. - unfold transl_fundef, AST.transf_partial_fundef, Errors.bind in B. - unfold_match B. inv B. econstructor. apply A. - - apply option_inv. rewrite <- Heqo. rewrite <- H. - rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - trivial. symmetry; eapply Linking.match_program_main; eauto. - Qed. - - Lemma transl_initial_states : - forall s1 : Smallstep.state (RTL.semantics prog), - Smallstep.initial_state (RTL.semantics prog) s1 -> - exists s2 : Smallstep.state (HTL.semantics tprog), - Smallstep.initial_state (HTL.semantics tprog) s2 /\ match_states s1 s2. - Proof. - induction 1. - destruct TRANSL. unfold main_is_internal in H4. - repeat (unfold_match H4). - assert (f = AST.Internal f1). apply option_inv. - rewrite <- Heqo0. rewrite <- H1. replace b with b0. - auto. apply option_inv. rewrite <- H0. rewrite <- Heqo. - trivial. - exploit function_ptr_translated; eauto. - intros [tf [A B]]. - unfold transl_fundef, Errors.bind in B. - unfold AST.transf_partial_fundef, Errors.bind in B. - repeat (unfold_match B). inversion B. subst. - exploit main_tprog_internal; eauto; intros. - rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - apply Heqo. symmetry; eapply Linking.match_program_main; eauto. - inversion H5. - econstructor; split. econstructor. - apply (Genv.init_mem_transf_partial TRANSL'); eauto. - replace (AST.prog_main tprog) with (AST.prog_main prog). - rewrite symbols_preserved; eauto. - symmetry; eapply Linking.match_program_main; eauto. - apply H6. - - constructor. - apply transl_module_correct. - assert (Some (AST.Internal x) = Some (AST.Internal m)). - replace (AST.fundef HTL.module) with (HTL.fundef). - rewrite <- H6. setoid_rewrite <- A. trivial. - trivial. inv H7. assumption. - Qed. - Hint Resolve transl_initial_states : htlproof. - - Lemma transl_final_states : - forall (s1 : Smallstep.state (RTL.semantics prog)) - (s2 : Smallstep.state (HTL.semantics tprog)) - (r : Integers.Int.int), - match_states s1 s2 -> - Smallstep.final_state (RTL.semantics prog) s1 r -> - Smallstep.final_state (HTL.semantics tprog) s2 r. - Proof. - intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. - Qed. - Hint Resolve transl_final_states : htlproof. - - Theorem transl_step_correct: - forall (S1 : RTL.state) t S2, - RTL.step ge S1 t S2 -> - forall (R1 : HTL.state), - match_states S1 R1 -> - exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states S2 R2. - Proof. - induction 1; eauto with htlproof; (intros; inv_state). - Qed. - Hint Resolve transl_step_correct : htlproof. - - Theorem transf_program_correct: - Smallstep.forward_simulation (RTL.semantics prog) (HTL.semantics tprog). - Proof. - eapply Smallstep.forward_simulation_plus; eauto with htlproof. - apply senv_preserved. - Qed. - -End CORRECTNESS. +(* Inductive match_assocmaps : RTL.function -> RTL.regset -> assocmap -> Prop := *) +(* match_assocmap : forall f rs am, *) +(* (forall r, Ple r (RTL.max_reg_function f) -> *) +(* val_value_lessdef (Registers.Regmap.get r rs) am#r) -> *) +(* match_assocmaps f rs am. *) +(* Hint Constructors match_assocmaps : htlproof. *) + +(* Definition state_st_wf (m : HTL.module) (s : HTL.state) := *) +(* forall st asa asr res, *) +(* s = HTL.State res m st asa asr -> *) +(* asa!(m.(HTL.mod_st)) = Some (posToValue st). *) +(* Hint Unfold state_st_wf : htlproof. *) + +(* Inductive match_arrs (m : HTL.module) (f : RTL.function) (sp : Values.val) (mem : mem) : *) +(* Verilog.assocmap_arr -> Prop := *) +(* | match_arr : forall asa stack, *) +(* asa ! (m.(HTL.mod_stk)) = Some stack /\ *) +(* stack.(arr_length) = Z.to_nat (f.(RTL.fn_stacksize) / 4) /\ *) +(* (forall ptr, *) +(* 0 <= ptr < Z.of_nat m.(HTL.mod_stk_len) -> *) +(* opt_val_value_lessdef (Mem.loadv AST.Mint32 mem *) +(* (Values.Val.offset_ptr sp (Integers.Ptrofs.repr (4 * ptr)))) *) +(* (Option.default (NToValue 0) *) +(* (Option.join (array_get_error (Z.to_nat ptr) stack)))) -> *) +(* match_arrs m f sp mem asa. *) + +(* Definition stack_based (v : Values.val) (sp : Values.block) : Prop := *) +(* match v with *) +(* | Values.Vptr sp' off => sp' = sp *) +(* | _ => True *) +(* end. *) + +(* Definition reg_stack_based_pointers (sp : Values.block) (rs : Registers.Regmap.t Values.val) : Prop := *) +(* forall r, stack_based (Registers.Regmap.get r rs) sp. *) + +(* Definition arr_stack_based_pointers (spb : Values.block) (m : mem) (stack_length : Z) *) +(* (sp : Values.val) : Prop := *) +(* forall ptr, *) +(* 0 <= ptr < (stack_length / 4) -> *) +(* stack_based (Option.default *) +(* Values.Vundef *) +(* (Mem.loadv AST.Mint32 m *) +(* (Values.Val.offset_ptr sp (Integers.Ptrofs.repr (4 * ptr))))) *) +(* spb. *) + +(* Definition stack_bounds (sp : Values.val) (hi : Z) (m : mem) : Prop := *) +(* forall ptr v, *) +(* hi <= ptr <= Integers.Ptrofs.max_unsigned -> *) +(* Z.modulo ptr 4 = 0 -> *) +(* Mem.loadv AST.Mint32 m (Values.Val.offset_ptr sp (Integers.Ptrofs.repr ptr )) = None /\ *) +(* Mem.storev AST.Mint32 m (Values.Val.offset_ptr sp (Integers.Ptrofs.repr ptr )) v = None. *) + +(* Inductive match_frames : list RTL.stackframe -> list HTL.stackframe -> Prop := *) +(* | match_frames_nil : *) +(* match_frames nil nil. *) + +(* Lemma assumption_32bit : *) +(* forall v, *) +(* valueToPos (posToValue v) = v. *) +(* Proof. *) +(* Admitted. *) + +(* Inductive match_states : RTL.state -> HTL.state -> Prop := *) +(* | match_state : forall asa asr sf f sp sp' rs mem m st res *) +(* (MASSOC : match_assocmaps f rs asr) *) +(* (TF : tr_module f m) *) +(* (WF : state_st_wf m (HTL.State res m st asr asa)) *) +(* (MF : match_frames sf res) *) +(* (MARR : match_arrs m f sp mem asa) *) +(* (SP : sp = Values.Vptr sp' (Integers.Ptrofs.repr 0)) *) +(* (RSBP : reg_stack_based_pointers sp' rs) *) +(* (ASBP : arr_stack_based_pointers sp' mem (f.(RTL.fn_stacksize)) sp) *) +(* (BOUNDS : stack_bounds sp (f.(RTL.fn_stacksize)) mem), *) +(* match_states (RTL.State sf f sp st rs mem) *) +(* (HTL.State res m st asr asa) *) +(* | match_returnstate : *) +(* forall *) +(* v v' stack mem res *) +(* (MF : match_frames stack res), *) +(* val_value_lessdef v v' -> *) +(* match_states (RTL.Returnstate stack v mem) (HTL.Returnstate res v') *) +(* | match_initial_call : *) +(* forall f m m0 *) +(* (TF : tr_module f m), *) +(* match_states (RTL.Callstate nil (AST.Internal f) nil m0) (HTL.Callstate nil m nil). *) +(* Hint Constructors match_states : htlproof. *) + +(* Definition match_prog (p: RTL.program) (tp: HTL.program) := *) +(* Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp /\ *) +(* main_is_internal p = true. *) + +(* Definition match_prog_matches : *) +(* forall p tp, *) +(* match_prog p tp -> *) +(* Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. *) +(* Proof. intros. unfold match_prog in H. tauto. Qed. *) + +(* Lemma transf_program_match: *) +(* forall p tp, HTLgen.transl_program p = Errors.OK tp -> match_prog p tp. *) +(* Proof. *) +(* intros. unfold transl_program in H. *) +(* destruct (main_is_internal p) eqn:?; try discriminate. *) +(* unfold match_prog. split. *) +(* apply Linking.match_transform_partial_program; auto. *) +(* assumption. *) +(* Qed. *) + +(* Lemma regs_lessdef_add_greater : *) +(* forall f rs1 rs2 n v, *) +(* Plt (RTL.max_reg_function f) n -> *) +(* match_assocmaps f rs1 rs2 -> *) +(* match_assocmaps f rs1 (AssocMap.set n v rs2). *) +(* Proof. *) +(* inversion 2; subst. *) +(* intros. constructor. *) +(* intros. unfold find_assocmap. unfold AssocMapExt.get_default. *) +(* rewrite AssocMap.gso. eauto. *) +(* apply Pos.le_lt_trans with _ _ n in H2. *) +(* unfold not. intros. subst. eapply Pos.lt_irrefl. eassumption. assumption. *) +(* Qed. *) +(* Hint Resolve regs_lessdef_add_greater : htlproof. *) + +(* Lemma regs_lessdef_add_match : *) +(* forall f rs am r v v', *) +(* val_value_lessdef v v' -> *) +(* match_assocmaps f rs am -> *) +(* match_assocmaps f (Registers.Regmap.set r v rs) (AssocMap.set r v' am). *) +(* Proof. *) +(* inversion 2; subst. *) +(* constructor. intros. *) +(* destruct (peq r0 r); subst. *) +(* rewrite Registers.Regmap.gss. *) +(* unfold find_assocmap. unfold AssocMapExt.get_default. *) +(* rewrite AssocMap.gss. assumption. *) + +(* rewrite Registers.Regmap.gso; try assumption. *) +(* unfold find_assocmap. unfold AssocMapExt.get_default. *) +(* rewrite AssocMap.gso; eauto. *) +(* Qed. *) +(* Hint Resolve regs_lessdef_add_match : htlproof. *) + +(* Lemma list_combine_none : *) +(* forall n l, *) +(* length l = n -> *) +(* list_combine Verilog.merge_cell (list_repeat None n) l = l. *) +(* Proof. *) +(* induction n; intros; crush. *) +(* - symmetry. apply length_zero_iff_nil. auto. *) +(* - destruct l; crush. *) +(* rewrite list_repeat_cons. *) +(* crush. f_equal. *) +(* eauto. *) +(* Qed. *) + +(* Lemma combine_none : *) +(* forall n a, *) +(* a.(arr_length) = n -> *) +(* arr_contents (combine Verilog.merge_cell (arr_repeat None n) a) = arr_contents a. *) +(* Proof. *) +(* intros. *) +(* unfold combine. *) +(* crush. *) + +(* rewrite <- (arr_wf a) in H. *) +(* apply list_combine_none. *) +(* assumption. *) +(* Qed. *) + +(* Lemma list_combine_lookup_first : *) +(* forall l1 l2 n, *) +(* length l1 = length l2 -> *) +(* nth_error l1 n = Some None -> *) +(* nth_error (list_combine Verilog.merge_cell l1 l2) n = nth_error l2 n. *) +(* Proof. *) +(* induction l1; intros; crush. *) + +(* rewrite nth_error_nil in H0. *) +(* discriminate. *) + +(* destruct l2 eqn:EQl2. crush. *) +(* simpl in H. invert H. *) +(* destruct n; simpl in *. *) +(* invert H0. simpl. reflexivity. *) +(* eauto. *) +(* Qed. *) + +(* Lemma combine_lookup_first : *) +(* forall a1 a2 n, *) +(* a1.(arr_length) = a2.(arr_length) -> *) +(* array_get_error n a1 = Some None -> *) +(* array_get_error n (combine Verilog.merge_cell a1 a2) = array_get_error n a2. *) +(* Proof. *) +(* intros. *) + +(* unfold array_get_error in *. *) +(* apply list_combine_lookup_first; eauto. *) +(* rewrite a1.(arr_wf). rewrite a2.(arr_wf). *) +(* assumption. *) +(* Qed. *) + +(* Lemma list_combine_lookup_second : *) +(* forall l1 l2 n x, *) +(* length l1 = length l2 -> *) +(* nth_error l1 n = Some (Some x) -> *) +(* nth_error (list_combine Verilog.merge_cell l1 l2) n = Some (Some x). *) +(* Proof. *) +(* induction l1; intros; crush; auto. *) + +(* destruct l2 eqn:EQl2. crush. *) +(* simpl in H. invert H. *) +(* destruct n; simpl in *. *) +(* invert H0. simpl. reflexivity. *) +(* eauto. *) +(* Qed. *) + +(* Lemma combine_lookup_second : *) +(* forall a1 a2 n x, *) +(* a1.(arr_length) = a2.(arr_length) -> *) +(* array_get_error n a1 = Some (Some x) -> *) +(* array_get_error n (combine Verilog.merge_cell a1 a2) = Some (Some x). *) +(* Proof. *) +(* intros. *) + +(* unfold array_get_error in *. *) +(* apply list_combine_lookup_second; eauto. *) +(* rewrite a1.(arr_wf). rewrite a2.(arr_wf). *) +(* assumption. *) +(* Qed. *) + +(* Ltac inv_state := *) +(* match goal with *) +(* MSTATE : match_states _ _ |- _ => *) +(* inversion MSTATE; *) +(* match goal with *) +(* TF : tr_module _ _ |- _ => *) +(* inversion TF; *) +(* match goal with *) +(* TC : forall _ _, *) +(* Maps.PTree.get _ _ = Some _ -> tr_code _ _ _ _ _ _ _ _ _, *) +(* H : Maps.PTree.get _ _ = Some _ |- _ => *) +(* apply TC in H; inversion H; *) +(* match goal with *) +(* TI : context[tr_instr] |- _ => *) +(* inversion TI *) +(* end *) +(* end *) +(* end *) +(* end; subst. *) + +(* Ltac unfold_func H := *) +(* match type of H with *) +(* | ?f = _ => unfold f in H; repeat (unfold_match H) *) +(* | ?f _ = _ => unfold f in H; repeat (unfold_match H) *) +(* | ?f _ _ = _ => unfold f in H; repeat (unfold_match H) *) +(* | ?f _ _ _ = _ => unfold f in H; repeat (unfold_match H) *) +(* | ?f _ _ _ _ = _ => unfold f in H; repeat (unfold_match H) *) +(* end. *) + +(* Lemma init_reg_assoc_empty : *) +(* forall f l, *) +(* match_assocmaps f (RTL.init_regs nil l) (HTL.init_regs nil l). *) +(* Proof. *) +(* induction l; simpl; constructor; intros. *) +(* - rewrite Registers.Regmap.gi. unfold find_assocmap. *) +(* unfold AssocMapExt.get_default. rewrite AssocMap.gempty. *) +(* constructor. *) + +(* - rewrite Registers.Regmap.gi. unfold find_assocmap. *) +(* unfold AssocMapExt.get_default. rewrite AssocMap.gempty. *) +(* constructor. *) +(* Qed. *) + +(* Lemma arr_lookup_some: *) +(* forall (z : Z) (r0 : Registers.reg) (r : Verilog.reg) (asr : assocmap) (asa : Verilog.assocmap_arr) *) +(* (stack : Array (option value)) (H5 : asa ! r = Some stack) n, *) +(* exists x, Verilog.arr_assocmap_lookup asa r n = Some x. *) +(* Proof. *) +(* intros z r0 r asr asa stack H5 n. *) +(* eexists. *) +(* unfold Verilog.arr_assocmap_lookup. rewrite H5. reflexivity. *) +(* Qed. *) +(* Hint Resolve arr_lookup_some : htlproof. *) + +(* Section CORRECTNESS. *) + +(* Variable prog : RTL.program. *) +(* Variable tprog : HTL.program. *) + +(* Hypothesis TRANSL : match_prog prog tprog. *) + +(* Lemma TRANSL' : *) +(* Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog. *) +(* Proof. intros; apply match_prog_matches; assumption. Qed. *) + +(* Let ge : RTL.genv := Globalenvs.Genv.globalenv prog. *) +(* Let tge : HTL.genv := Globalenvs.Genv.globalenv tprog. *) + +(* Lemma symbols_preserved: *) +(* forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. *) +(* Proof. intros. eapply (Genv.find_symbol_match TRANSL'). Qed. *) + +(* Lemma function_ptr_translated: *) +(* forall (b: Values.block) (f: RTL.fundef), *) +(* Genv.find_funct_ptr ge b = Some f -> *) +(* exists tf, *) +(* Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Errors.OK tf. *) +(* Proof. *) +(* intros. exploit (Genv.find_funct_ptr_match TRANSL'); eauto. *) +(* intros (cu & tf & P & Q & R); exists tf; auto. *) +(* Qed. *) + +(* Lemma functions_translated: *) +(* forall (v: Values.val) (f: RTL.fundef), *) +(* Genv.find_funct ge v = Some f -> *) +(* exists tf, *) +(* Genv.find_funct tge v = Some tf /\ transl_fundef f = Errors.OK tf. *) +(* Proof. *) +(* intros. exploit (Genv.find_funct_match TRANSL'); eauto. *) +(* intros (cu & tf & P & Q & R); exists tf; auto. *) +(* Qed. *) + +(* Lemma senv_preserved: *) +(* Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). *) +(* Proof *) +(* (Genv.senv_transf_partial TRANSL'). *) +(* Hint Resolve senv_preserved : htlproof. *) + +(* Lemma ptrofs_inj : *) +(* forall a b, *) +(* Ptrofs.unsigned a = Ptrofs.unsigned b -> a = b. *) +(* Proof. *) +(* intros. rewrite <- Ptrofs.repr_unsigned. symmetry. rewrite <- Ptrofs.repr_unsigned. *) +(* rewrite H. auto. *) +(* Qed. *) + +(* Lemma eval_correct : *) +(* forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, *) +(* match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> *) +(* (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> *) +(* Op.eval_operation ge sp op *) +(* (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> *) +(* translate_instr op args s = OK e s' i -> *) +(* exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. *) +(* Proof. *) +(* intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. *) +(* inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; *) +(* unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); simplify. *) +(* - inv Heql. *) +(* assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) +(* apply H in HPle. eexists. split; try constructor; eauto. *) +(* - eexists. split. constructor. constructor. auto. *) +(* - inv Heql. *) +(* assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) +(* apply H in HPle. *) +(* eexists. split. econstructor; eauto. constructor. trivial. *) +(* unfold Verilog.unop_run. unfold Values.Val.neg. destruct (Registers.Regmap.get r rs) eqn:?; constructor. *) +(* inv HPle. auto. *) +(* - inv Heql. *) +(* assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) +(* assert (HPle0 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) +(* apply H in HPle. apply H in HPle0. *) +(* eexists. split. econstructor; eauto. constructor. trivial. *) +(* constructor. trivial. simplify. inv HPle. inv HPle0; constructor; auto. *) +(* + inv HPle0. constructor. unfold valueToPtr. Search Integers.Ptrofs.sub Integers.int. *) +(* pose proof Integers.Ptrofs.agree32_sub. unfold Integers.Ptrofs.agree32 in H3. *) +(* Print Integers.Ptrofs.agree32. unfold Ptrofs.of_int. simpl. *) +(* apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H3 in H4. *) +(* rewrite Ptrofs.unsigned_repr. apply H4. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* apply Int.unsigned_range_2. *) +(* auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. *) +(* replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* apply Int.unsigned_range_2. *) +(* Admitted. *) + +(* Lemma eval_cond_correct : *) +(* forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, *) +(* translate_condition cond args s1 = OK c s' i -> *) +(* Op.eval_condition *) +(* cond *) +(* (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) *) +(* m = Some b -> *) +(* Verilog.expr_runp f asr asa c (boolToValue b). *) +(* Admitted. *) + +(* (** The proof of semantic preservation for the translation of instructions *) +(* is a simulation argument based on diagrams of the following form: *) +(* << *) +(* match_states *) +(* code st rs ---------------- State m st assoc *) +(* || | *) +(* || | *) +(* || | *) +(* \/ v *) +(* code st rs' --------------- State m st assoc' *) +(* match_states *) +(* >> *) +(* where [tr_code c data control fin rtrn st] is assumed to hold. *) + +(* The precondition and postcondition is that that should hold is [match_assocmaps rs assoc]. *) +(* *) *) + +(* Definition transl_instr_prop (instr : RTL.instruction) : Prop := *) +(* forall m asr asa fin rtrn st stmt trans res, *) +(* tr_instr fin rtrn st (m.(HTL.mod_stk)) instr stmt trans -> *) +(* exists asr' asa', *) +(* HTL.step tge (HTL.State res m st asr asa) Events.E0 (HTL.State res m st asr' asa'). *) + +(* Opaque combine. *) + +(* Ltac tac0 := *) +(* match goal with *) +(* | [ |- context[valueToPos (posToValue _)] ] => rewrite assumption_32bit *) + +(* | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs *) +(* | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr *) +(* | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge *) +(* | [ |- context[reg_stack_based_pointers] ] => unfold reg_stack_based_pointers; intros *) +(* | [ |- context[Verilog.arr_assocmap_set _ _ _ _] ] => unfold Verilog.arr_assocmap_set *) + +(* | [ |- context[HTL.empty_stack] ] => unfold HTL.empty_stack *) + +(* | [ |- context[_ # ?d <- _ ! ?d] ] => rewrite AssocMap.gss *) +(* | [ |- context[_ # ?d <- _ ! ?s] ] => rewrite AssocMap.gso *) +(* | [ |- context[(AssocMap.empty _) ! _] ] => rewrite AssocMap.gempty *) + +(* | [ |- context[array_get_error _ (combine Verilog.merge_cell (arr_repeat None _) _)] ] => *) +(* rewrite combine_lookup_first *) + +(* | [ |- state_st_wf _ _ ] => unfold state_st_wf; inversion 1 *) +(* | [ |- context[match_states _ _] ] => econstructor; auto *) +(* | [ |- match_arrs _ _ _ _ _ ] => econstructor; auto *) +(* | [ |- match_assocmaps _ _ _ # _ <- (posToValue _) ] => *) +(* apply regs_lessdef_add_greater; [> unfold Plt; lia | assumption] *) + +(* | [ H : ?asa ! ?r = Some _ |- Verilog.arr_assocmap_lookup ?asa ?r _ = Some _ ] => *) +(* unfold Verilog.arr_assocmap_lookup; setoid_rewrite H; f_equal *) +(* | [ |- context[(AssocMap.combine _ _ _) ! _] ] => *) +(* try (rewrite AssocMap.gcombine; [> | reflexivity]) *) + +(* | [ |- context[Registers.Regmap.get ?d (Registers.Regmap.set ?d _ _)] ] => *) +(* rewrite Registers.Regmap.gss *) +(* | [ |- context[Registers.Regmap.get ?s (Registers.Regmap.set ?d _ _)] ] => *) +(* destruct (Pos.eq_dec s d) as [EQ|EQ]; *) +(* [> rewrite EQ | rewrite Registers.Regmap.gso; auto] *) + +(* | [ H : opt_val_value_lessdef _ _ |- _ ] => invert H *) +(* | [ H : context[Z.of_nat (Z.to_nat _)] |- _ ] => rewrite Z2Nat.id in H; [> solve crush |] *) +(* | [ H : _ ! _ = Some _ |- _] => setoid_rewrite H *) +(* end. *) + +(* Ltac small_tac := repeat (crush; try array; try ptrofs); crush; auto. *) +(* Ltac big_tac := repeat (crush; try array; try ptrofs; try tac0); crush; auto. *) + + (* Lemma transl_inop_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) + (* (rs : RTL.regset) (m : mem) (pc' : RTL.node), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Inop pc') -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f sp pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. *) + (* Proof. *) + (* intros s f sp pc rs m pc' H R1 MSTATE. *) + (* inv_state. *) + + (* unfold match_prog in TRANSL. *) + (* econstructor. *) + (* split. *) + (* apply Smallstep.plus_one. *) + (* eapply HTL.step_module; eauto. *) + (* apply assumption_32bit. *) + (* (* processing of state *) *) + (* econstructor. *) + (* crush. *) + (* econstructor. *) + (* econstructor. *) + (* econstructor. *) + + (* all: invert MARR; big_tac. *) + (* Unshelve. *) + (* constructor. *) + (* Qed. *) + (* Hint Resolve transl_inop_correct : htlproof. *) + + (* Lemma transl_iop_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) + (* (rs : Registers.Regmap.t Values.val) (m : mem) (op : Op.operation) (args : list Registers.reg) *) + (* (res0 : Registers.reg) (pc' : RTL.node) (v : Values.val), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> *) + (* Op.eval_operation ge sp op (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f sp pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) + (* match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. *) + (* Proof. *) + (* intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. *) + (* inv_state. *) + (* exploit eval_correct; eauto. intros. inversion H1. inversion H2. *) + (* econstructor. split. *) + (* apply Smallstep.plus_one. *) + (* eapply HTL.step_module; eauto. *) + (* apply assumption_32bit. *) + (* econstructor; simpl; trivial. *) + (* constructor; trivial. *) + (* econstructor; simpl; eauto. *) + (* simpl. econstructor. econstructor. *) + (* apply H3. simplify. *) + + (* all: big_tac. *) + + (* assert (Ple res0 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_def; eauto; simpl; auto). *) + + (* unfold Ple in H10. lia. *) + (* apply regs_lessdef_add_match. assumption. *) + (* apply regs_lessdef_add_greater. unfold Plt; lia. assumption. *) + (* assert (Ple res0 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_def; eauto; simpl; auto). *) + (* unfold Ple in H12; lia. *) + (* unfold_merge. simpl. *) + (* rewrite AssocMap.gso. *) + (* apply AssocMap.gss. *) + (* apply st_greater_than_res. *) + + (* (*match_states*) *) + (* assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. *) + (* rewrite <- H1. *) + (* constructor; auto. *) + (* unfold_merge. *) + (* apply regs_lessdef_add_match. *) + (* constructor. *) + (* apply regs_lessdef_add_greater. *) + (* apply greater_than_max_func. *) + (* assumption. *) + + (* unfold state_st_wf. intros. inversion H2. subst. *) + (* unfold_merge. *) + (* rewrite AssocMap.gso. *) + (* apply AssocMap.gss. *) + (* apply st_greater_than_res. *) + + (* + econstructor. split. *) + (* apply Smallstep.plus_one. *) + (* eapply HTL.step_module; eauto. *) + (* econstructor; simpl; trivial. *) + (* constructor; trivial. *) + (* econstructor; simpl; eauto. *) + (* eapply eval_correct; eauto. *) + (* constructor. rewrite valueToInt_intToValue. trivial. *) + (* unfold_merge. simpl. *) + (* rewrite AssocMap.gso. *) + (* apply AssocMap.gss. *) + (* apply st_greater_than_res. *) + + (* match_states *) + (* assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. *) + (* rewrite <- H1. *) + (* constructor. *) + (* unfold_merge. *) + (* apply regs_lessdef_add_match. *) + (* constructor. *) + (* symmetry. apply valueToInt_intToValue. *) + (* apply regs_lessdef_add_greater. *) + (* apply greater_than_max_func. *) + (* assumption. assumption. *) + + (* unfold state_st_wf. intros. inversion H2. subst. *) + (* unfold_merge. *) + (* rewrite AssocMap.gso. *) + (* apply AssocMap.gss. *) + (* apply st_greater_than_res. *) + (* assumption. *) + (* Admitted. *) + (* Hint Resolve transl_iop_correct : htlproof. *) + + (* Ltac tac := *) + (* repeat match goal with *) + (* | [ _ : error _ _ = OK _ _ _ |- _ ] => discriminate *) + (* | [ _ : context[if (?x && ?y) then _ else _] |- _ ] => *) + (* let EQ1 := fresh "EQ" in *) + (* let EQ2 := fresh "EQ" in *) + (* destruct x eqn:EQ1; destruct y eqn:EQ2; simpl in * *) + (* | [ _ : context[if ?x then _ else _] |- _ ] => *) + (* let EQ := fresh "EQ" in *) + (* destruct x eqn:EQ; simpl in * *) + (* | [ H : ret _ _ = _ |- _ ] => invert H *) + (* | [ _ : context[match ?x with | _ => _ end] |- _ ] => destruct x *) + (* end. *) + + (* Ltac inv_arr_access := *) + (* match goal with *) + (* | [ _ : translate_arr_access ?chunk ?addr ?args _ _ = OK ?c _ _ |- _] => *) + (* destruct c, chunk, addr, args; crush; tac; crush *) + (* end. *) + + (* Lemma transl_iload_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) + (* (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) *) + (* (addr : Op.addressing) (args : list Registers.reg) (dst : Registers.reg) *) + (* (pc' : RTL.node) (a v : Values.val), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Iload chunk addr args dst pc') -> *) + (* Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> *) + (* Mem.loadv chunk m a = Some v -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f sp pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) + (* match_states (RTL.State s f sp pc' (Registers.Regmap.set dst v rs) m) R2. *) + (* Proof. *) + (* intros s f sp pc rs m chunk addr args dst pc' a v H H0 H1 R1 MSTATE. *) + (* inv_state. inv_arr_access. *) + + (* + (** Preamble *) *) + (* invert MARR. crush. *) + + (* unfold Op.eval_addressing in H0. *) + (* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + + (* unfold reg_stack_based_pointers in RSBP. *) + (* pose proof (RSBP r0) as RSBPr0. *) + + (* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. *) + + (* rewrite ARCHI in H1. crush. *) + (* subst. *) + + (* pose proof MASSOC as MASSOC'. *) + (* invert MASSOC'. *) + (* pose proof (H0 r0). *) + (* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) + (* apply H6 in HPler0. *) + (* invert HPler0; try congruence. *) + (* rewrite EQr0 in H8. *) + (* invert H8. *) + (* clear H0. clear H6. *) + + (* unfold check_address_parameter_signed in *; *) + (* unfold check_address_parameter_unsigned in *; crush. *) + + (* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) + (* (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. *) + + (* (** Modular preservation proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) + (* { rewrite HeqOFFSET. *) + (* apply PtrofsExtra.add_mod; crush. *) + (* rewrite Integers.Ptrofs.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. *) + (* apply PtrofsExtra.of_int_mod. *) + (* rewrite Integers.Int.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. } *) + + (* (** Read bounds proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. *) + (* { destruct (Integers.Ptrofs.unsigned OFFSET *) + (* assert (Z.to_nat *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4))) *) + (* = *) + (* valueToNat x) *) + (* as EXPR_OK by admit *) + (* end. *) + (* rewrite <- EXPR_OK. *) + + (* specialize (H7 (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4)))). *) + (* exploit H7; big_tac. *) + + (* (** RSBP preservation *) *) + (* unfold arr_stack_based_pointers in ASBP. *) + (* specialize (ASBP (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). *) + (* exploit ASBP; big_tac. *) + (* rewrite NORMALISE in H0. rewrite H1 in H0. assumption. *) + + (* + (** Preamble *) *) + (* invert MARR. crush. *) + + (* unfold Op.eval_addressing in H0. *) + (* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + + (* unfold reg_stack_based_pointers in RSBP. *) + (* pose proof (RSBP r0) as RSBPr0. *) + (* pose proof (RSBP r1) as RSBPr1. *) + + (* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; *) + (* destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. *) + + (* rewrite ARCHI in H1. crush. *) + (* subst. *) + (* clear RSBPr1. *) + + (* pose proof MASSOC as MASSOC'. *) + (* invert MASSOC'. *) + (* pose proof (H0 r0). *) + (* pose proof (H0 r1). *) + (* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) + (* assert (HPler1 : Ple r1 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) + (* apply H6 in HPler0. *) + (* apply H8 in HPler1. *) + (* invert HPler0; invert HPler1; try congruence. *) + (* rewrite EQr0 in H9. *) + (* rewrite EQr1 in H11. *) + (* invert H9. invert H11. *) + (* clear H0. clear H6. clear H8. *) + + (* unfold check_address_parameter_signed in *; *) + (* unfold check_address_parameter_unsigned in *; crush. *) + + (* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) + (* (Integers.Ptrofs.of_int *) + (* (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) *) + (* (Integers.Int.repr z0)))) as OFFSET. *) + + (* (** Modular preservation proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) + (* { rewrite HeqOFFSET. *) + (* apply PtrofsExtra.add_mod; crush; try lia. *) + (* rewrite Integers.Ptrofs.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. *) + (* apply PtrofsExtra.of_int_mod. *) + (* apply IntExtra.add_mod; crush. *) + (* apply IntExtra.mul_mod2; crush. *) + (* rewrite Integers.Int.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. *) + (* rewrite Integers.Int.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. } *) + + (* (** Read bounds proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. *) + (* { destruct (Integers.Ptrofs.unsigned OFFSET *) + (* assert (Z.to_nat *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4))) *) + (* = *) + (* valueToNat x) *) + (* as EXPR_OK by admit *) + (* end. *) + (* rewrite <- EXPR_OK. *) + + (* specialize (H7 (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4)))). *) + (* exploit H7; big_tac. *) + + (* (** RSBP preservation *) *) + (* unfold arr_stack_based_pointers in ASBP. *) + (* specialize (ASBP (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). *) + (* exploit ASBP; big_tac. *) + (* rewrite NORMALISE in H0. rewrite H1 in H0. assumption. *) + + (* + invert MARR. crush. *) + + (* unfold Op.eval_addressing in H0. *) + (* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + (* rewrite ARCHI in H0. crush. *) + + (* unfold check_address_parameter_unsigned in *; *) + (* unfold check_address_parameter_signed in *; crush. *) + + (* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) + (* rewrite ZERO in H1. clear ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l in H1. *) + + (* remember i0 as OFFSET. *) + + (* (** Modular preservation proof *) *) + (* rename H0 into MOD_PRESERVE. *) + + (* (** Read bounds proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. *) + (* { destruct (Integers.Ptrofs.unsigned OFFSET *) + (* assert (Z.to_nat *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4))) *) + (* = *) + (* valueToNat x) *) + (* as EXPR_OK by admit *) + (* end. *) + (* rewrite <- EXPR_OK. *) + + (* specialize (H7 (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4)))). *) + (* exploit H7; big_tac. *) + + (* (** RSBP preservation *) *) + (* unfold arr_stack_based_pointers in ASBP. *) + (* specialize (ASBP (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). *) + (* exploit ASBP; big_tac. *) + (* rewrite NORMALISE in H0. rewrite H1 in H0. assumption. *) + (* Admitted. *) + (* Hint Resolve transl_iload_correct : htlproof. *) + + (* Lemma transl_istore_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) + (* (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) *) + (* (addr : Op.addressing) (args : list Registers.reg) (src : Registers.reg) *) + (* (pc' : RTL.node) (a : Values.val) (m' : mem), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Istore chunk addr args src pc') -> *) + (* Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> *) + (* Mem.storev chunk m a (Registers.Regmap.get src rs) = Some m' -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f sp pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m') R2. *) + (* Proof. *) + (* intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. *) + (* inv_state. inv_arr_access. *) + + (* + (** Preamble *) *) + (* invert MARR. crush. *) + + (* unfold Op.eval_addressing in H0. *) + (* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + + (* unfold reg_stack_based_pointers in RSBP. *) + (* pose proof (RSBP r0) as RSBPr0. *) + + (* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. *) + + (* rewrite ARCHI in H1. crush. *) + (* subst. *) + + (* pose proof MASSOC as MASSOC'. *) + (* invert MASSOC'. *) + (* pose proof (H0 r0). *) + (* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) + (* apply H6 in HPler0. *) + (* invert HPler0; try congruence. *) + (* rewrite EQr0 in H8. *) + (* invert H8. *) + (* clear H0. clear H6. *) + + (* unfold check_address_parameter_unsigned in *; *) + (* unfold check_address_parameter_signed in *; crush. *) + + (* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) + (* (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. *) + + (* (** Modular preservation proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) + (* { rewrite HeqOFFSET. *) + (* apply PtrofsExtra.add_mod; crush; try lia. *) + (* rewrite Integers.Ptrofs.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. *) + (* apply PtrofsExtra.of_int_mod. *) + (* rewrite Integers.Int.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. } *) + + (* (** Write bounds proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. *) + (* { destruct (Integers.Ptrofs.unsigned OFFSET *) + (* assert (Z.to_nat *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.divu *) + (* OFFSET *) + (* (Integers.Ptrofs.repr 4))) *) + (* = *) + (* valueToNat x) *) + (* as EXPR_OK by admit *) + (* end. *) + + (* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) + (* inversion MASSOC; revert HeqOFFSET; subst; clear MASSOC; intros HeqOFFSET. *) + + (* econstructor. *) + (* repeat split; crush. *) + (* unfold HTL.empty_stack. *) + (* crush. *) + (* unfold Verilog.merge_arrs. *) + + (* rewrite AssocMap.gcombine. *) + (* 2: { reflexivity. } *) + (* unfold Verilog.arr_assocmap_set. *) + (* rewrite AssocMap.gss. *) + (* unfold Verilog.merge_arr. *) + (* rewrite AssocMap.gss. *) + (* setoid_rewrite H5. *) + (* reflexivity. *) + + (* rewrite combine_length. *) + (* rewrite <- array_set_len. *) + (* unfold arr_repeat. crush. *) + (* apply list_repeat_len. *) + + (* rewrite <- array_set_len. *) + (* unfold arr_repeat. crush. *) + (* rewrite list_repeat_len. *) + (* rewrite H4. reflexivity. *) + + (* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) + (* (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. *) + + (* destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). *) + + (* erewrite Mem.load_store_same. *) + (* 2: { rewrite ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l. *) + (* rewrite e. *) + (* rewrite Integers.Ptrofs.unsigned_repr. *) + (* exact H1. *) + (* apply Integers.Ptrofs.unsigned_range_2. } *) + (* constructor. *) + (* erewrite combine_lookup_second. *) + (* simpl. *) + (* assert (Ple src (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) + (* apply H0 in H13. *) + (* destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H13; eauto. *) + + (* rewrite <- array_set_len. *) + (* unfold arr_repeat. crush. *) + (* rewrite list_repeat_len. auto. *) + + (* assert (4 * ptr / 4 = Integers.Ptrofs.unsigned OFFSET / 4) by (f_equal; assumption). *) + (* rewrite Z.mul_comm in H13. *) + (* rewrite Z_div_mult in H13; try lia. *) + (* replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H13 by reflexivity. *) + (* rewrite <- PtrofsExtra.divu_unsigned in H13; unfold_constants; try lia. *) + (* rewrite H13. rewrite EXPR_OK. *) + (* rewrite array_get_error_set_bound. *) + (* reflexivity. *) + (* unfold arr_length, arr_repeat. simpl. *) + (* rewrite list_repeat_len. lia. *) + + (* erewrite Mem.load_store_other with (m1 := m). *) + (* 2: { exact H1. } *) + (* 2: { right. *) + (* rewrite ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l. *) + (* rewrite Integers.Ptrofs.unsigned_repr. *) + (* simpl. *) + (* destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. *) + (* right. *) + (* apply ZExtra.mod_0_bounds; try lia. *) + (* apply ZLib.Z_mod_mult'. *) + (* rewrite Z2Nat.id in H15; try lia. *) + (* apply Zmult_lt_compat_r with (p := 4) in H15; try lia. *) + (* rewrite ZLib.div_mul_undo in H15; try lia. *) + (* split; try lia. *) + (* apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. *) + (* } *) + + (* rewrite <- EXPR_OK. *) + (* rewrite PtrofsExtra.divu_unsigned; auto; try (unfold_constants; lia). *) + (* destruct (ptr ==Z Integers.Ptrofs.unsigned OFFSET / 4). *) + (* apply Z.mul_cancel_r with (p := 4) in e; try lia. *) + (* rewrite ZLib.div_mul_undo in e; try lia. *) + (* rewrite combine_lookup_first. *) + (* eapply H7; eauto. *) + + (* rewrite <- array_set_len. *) + (* unfold arr_repeat. crush. *) + (* rewrite list_repeat_len. auto. *) + (* rewrite array_gso. *) + (* unfold array_get_error. *) + (* unfold arr_repeat. *) + (* crush. *) + (* apply list_repeat_lookup. *) + (* lia. *) + (* unfold_constants. *) + (* intro. *) + (* apply Z2Nat.inj_iff in H13; try lia. *) + (* apply Z.div_pos; try lia. *) + (* apply Integers.Ptrofs.unsigned_range. *) + + (* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) + (* unfold arr_stack_based_pointers. *) + (* intros. *) + (* destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). *) + + (* crush. *) + (* erewrite Mem.load_store_same. *) + (* 2: { rewrite ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l. *) + (* rewrite e. *) + (* rewrite Integers.Ptrofs.unsigned_repr. *) + (* exact H1. *) + (* apply Integers.Ptrofs.unsigned_range_2. } *) + (* crush. *) + (* destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; try constructor. *) + (* destruct (Archi.ptr64); try discriminate. *) + (* pose proof (RSBP src). rewrite EQ_SRC in H0. *) + (* assumption. *) + + (* simpl. *) + (* erewrite Mem.load_store_other with (m1 := m). *) + (* 2: { exact H1. } *) + (* 2: { right. *) + (* rewrite ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l. *) + (* rewrite Integers.Ptrofs.unsigned_repr. *) + (* simpl. *) + (* destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. *) + (* right. *) + (* apply ZExtra.mod_0_bounds; try lia. *) + (* apply ZLib.Z_mod_mult'. *) + (* invert H0. *) + (* apply Zmult_lt_compat_r with (p := 4) in H14; try lia. *) + (* rewrite ZLib.div_mul_undo in H14; try lia. *) + (* split; try lia. *) + (* apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. *) + (* } *) + (* apply ASBP; assumption. *) + + (* unfold stack_bounds in *. intros. *) + (* simpl. *) + (* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) + (* erewrite Mem.load_store_other with (m1 := m). *) + (* 2: { exact H1. } *) + (* 2: { right. right. simpl. *) + (* rewrite ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l. *) + (* rewrite Integers.Ptrofs.unsigned_repr; crush; try lia. *) + (* apply ZExtra.mod_0_bounds; crush; try lia. } *) + (* crush. *) + (* exploit (BOUNDS ptr); try lia. intros. crush. *) + (* exploit (BOUNDS ptr v); try lia. intros. *) + (* invert H0. *) + (* match goal with | |- ?x = _ => destruct x eqn:EQ end; try reflexivity. *) + (* assert (Mem.valid_access m AST.Mint32 sp' *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) + (* (Integers.Ptrofs.repr ptr))) Writable). *) + (* { pose proof H1. eapply Mem.store_valid_access_2 in H0. *) + (* exact H0. eapply Mem.store_valid_access_3. eassumption. } *) + (* pose proof (Mem.valid_access_store m AST.Mint32 sp' *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) + (* (Integers.Ptrofs.repr ptr))) v). *) + (* apply X in H0. invert H0. congruence. *) + + (* + (** Preamble *) *) + (* invert MARR. crush. *) + + (* unfold Op.eval_addressing in H0. *) + (* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + + (* unfold reg_stack_based_pointers in RSBP. *) + (* pose proof (RSBP r0) as RSBPr0. *) + (* pose proof (RSBP r1) as RSBPr1. *) + + (* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; *) + (* destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. *) + + (* rewrite ARCHI in H1. crush. *) + (* subst. *) + (* clear RSBPr1. *) + + (* pose proof MASSOC as MASSOC'. *) + (* invert MASSOC'. *) + (* pose proof (H0 r0). *) + (* pose proof (H0 r1). *) + (* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) + (* assert (HPler1 : Ple r1 (RTL.max_reg_function f)) *) + (* by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) + (* apply H6 in HPler0. *) + (* apply H8 in HPler1. *) + (* invert HPler0; invert HPler1; try congruence. *) + (* rewrite EQr0 in H9. *) + (* rewrite EQr1 in H11. *) + (* invert H9. invert H11. *) + (* clear H0. clear H6. clear H8. *) + + (* unfold check_address_parameter_signed in *; *) + (* unfold check_address_parameter_unsigned in *; crush. *) + + (* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) + (* (Integers.Ptrofs.of_int *) + (* (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) *) + (* (Integers.Int.repr z0)))) as OFFSET. *) + + (* (** Modular preservation proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) + (* { rewrite HeqOFFSET. *) + (* apply PtrofsExtra.add_mod; crush; try lia. *) + (* rewrite Integers.Ptrofs.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. *) + (* apply PtrofsExtra.of_int_mod. *) + (* apply IntExtra.add_mod; crush. *) + (* apply IntExtra.mul_mod2; crush. *) + (* rewrite Integers.Int.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. *) + (* rewrite Integers.Int.unsigned_repr_eq. *) + (* rewrite <- Zmod_div_mod; crush. } *) + + (* (** Write bounds proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. *) + (* { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. *) + (* assert (Mem.valid_access m AST.Mint32 sp' *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) + (* (Integers.Ptrofs.repr ptr))) Writable). *) + (* { pose proof H1. eapply Mem.store_valid_access_2 in H0. *) + (* exact H0. eapply Mem.store_valid_access_3. eassumption. } *) + (* pose proof (Mem.valid_access_store m AST.Mint32 sp' *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) + (* (Integers.Ptrofs.repr ptr))) v). *) + (* apply X in H0. invert H0. congruence. *) + + (* + invert MARR. crush. *) + + (* unfold Op.eval_addressing in H0. *) + (* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + (* rewrite ARCHI in H0. crush. *) + + (* unfold check_address_parameter_unsigned in *; *) + (* unfold check_address_parameter_signed in *; crush. *) + + (* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) + (* rewrite ZERO in H1. clear ZERO. *) + (* rewrite Integers.Ptrofs.add_zero_l in H1. *) + + (* remember i0 as OFFSET. *) + + (* (** Modular preservation proof *) *) + (* rename H0 into MOD_PRESERVE. *) + + (* (** Write bounds proof *) *) + (* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. *) + (* { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. *) + (* assert (Mem.valid_access m AST.Mint32 sp' *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) + (* (Integers.Ptrofs.repr ptr))) Writable). *) + (* { pose proof H1. eapply Mem.store_valid_access_2 in H0. *) + (* exact H0. eapply Mem.store_valid_access_3. eassumption. } *) + (* pose proof (Mem.valid_access_store m AST.Mint32 sp' *) + (* (Integers.Ptrofs.unsigned *) + (* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) + (* (Integers.Ptrofs.repr ptr))) v). *) + (* apply X in H0. invert H0. congruence. *) + (* Admitted. *) + (* Hint Resolve transl_istore_correct : htlproof. *) + + (* Lemma transl_icond_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) + (* (rs : Registers.Regmap.t Values.val) (m : mem) (cond : Op.condition) (args : list Registers.reg) *) + (* (ifso ifnot : RTL.node) (b : bool) (pc' : RTL.node), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Icond cond args ifso ifnot) -> *) + (* Op.eval_condition cond (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some b -> *) + (* pc' = (if b then ifso else ifnot) -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f sp pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. *) + (* Proof. *) + (* intros s f sp pc rs m cond args ifso ifnot b pc' H H0 H1 R1 MSTATE. *) + (* inv_state. *) + + (* eexists. split. apply Smallstep.plus_one. *) + (* eapply HTL.step_module; eauto. *) + (* apply assumption_32bit. *) + (* eapply Verilog.stmnt_runp_Vnonblock_reg with *) + (* (rhsval := if b then posToValue 32 ifso else posToValue 32 ifnot). *) + (* constructor. *) + + (* simpl. *) + (* destruct b. *) + (* eapply Verilog.erun_Vternary_true. *) + (* eapply eval_cond_correct; eauto. *) + (* constructor. *) + (* apply boolToValue_ValueToBool. *) + (* eapply Verilog.erun_Vternary_false. *) + (* eapply eval_cond_correct; eauto. *) + (* constructor. *) + (* apply boolToValue_ValueToBool. *) + (* constructor. *) + + (* big_tac. *) + + (* invert MARR. *) + (* destruct b; rewrite assumption_32bit; big_tac. *) + + (* Unshelve. *) + (* constructor. *) + (* Qed. *) + (* Hint Resolve transl_icond_correct : htlproof. *) + + (* Lemma transl_ijumptable_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) + (* (rs : Registers.Regmap.t Values.val) (m : mem) (arg : Registers.reg) (tbl : list RTL.node) *) + (* (n : Integers.Int.int) (pc' : RTL.node), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Ijumptable arg tbl) -> *) + (* Registers.Regmap.get arg rs = Values.Vint n -> *) + (* list_nth_z tbl (Integers.Int.unsigned n) = Some pc' -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f sp pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. *) + (* Proof. *) + (* intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. *) + (* Admitted. *) + (* Hint Resolve transl_ijumptable_correct : htlproof. *) + + (* Lemma transl_ireturn_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) *) + (* (pc : positive) (rs : RTL.regset) (m : mem) (or : option Registers.reg) *) + (* (m' : mem), *) + (* (RTL.fn_code f) ! pc = Some (RTL.Ireturn or) -> *) + (* Mem.free m stk 0 (RTL.fn_stacksize f) = Some m' -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) pc rs m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) + (* match_states (RTL.Returnstate s (Registers.regmap_optget or Values.Vundef rs) m') R2. *) + (* Proof. *) + (* intros s f stk pc rs m or m' H H0 R1 MSTATE. *) + (* inv_state. *) + + (* - econstructor. split. *) + (* eapply Smallstep.plus_two. *) + + (* eapply HTL.step_module; eauto. *) + (* apply assumption_32bit. *) + (* constructor. *) + (* econstructor; simpl; trivial. *) + (* econstructor; simpl; trivial. *) + (* constructor. *) + (* econstructor; simpl; trivial. *) + (* constructor. *) + + (* constructor. constructor. *) + + (* unfold state_st_wf in WF; big_tac; eauto. *) + + (* apply HTL.step_finish. *) + (* unfold Verilog.merge_regs. *) + (* unfold_merge; simpl. *) + (* rewrite AssocMap.gso. *) + (* apply AssocMap.gss. lia. *) + (* apply AssocMap.gss. *) + (* rewrite Events.E0_left. reflexivity. *) + + (* constructor; auto. *) + (* constructor. *) + + (* (* FIXME: Duplication *) *) + (* - econstructor. split. *) + (* eapply Smallstep.plus_two. *) + (* eapply HTL.step_module; eauto. *) + (* apply assumption_32bit. *) + (* constructor. *) + (* econstructor; simpl; trivial. *) + (* econstructor; simpl; trivial. *) + (* constructor. constructor. constructor. *) + (* constructor. constructor. constructor. *) + + (* unfold state_st_wf in WF; big_tac; eauto. *) + + (* apply HTL.step_finish. *) + (* unfold Verilog.merge_regs. *) + (* unfold_merge. *) + (* rewrite AssocMap.gso. *) + (* apply AssocMap.gss. simpl; lia. *) + (* apply AssocMap.gss. *) + (* rewrite Events.E0_left. trivial. *) + + (* constructor; auto. *) + + (* simpl. inversion MASSOC. subst. *) + (* unfold find_assocmap, AssocMapExt.get_default. rewrite AssocMap.gso. *) + (* apply H1. eapply RTL.max_reg_function_use. eauto. simpl; tauto. *) + (* assert (HPle : Ple r (RTL.max_reg_function f)). *) + (* eapply RTL.max_reg_function_use. eassumption. simpl; auto. *) + (* apply ZExtra.Ple_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. *) + + (* Unshelve. *) + (* all: constructor. *) + (* Qed. *) + (* Hint Resolve transl_ireturn_correct : htlproof. *) + + (* Lemma transl_callstate_correct: *) + (* forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) *) + (* (m : mem) (m' : Mem.mem') (stk : Values.block), *) + (* Mem.alloc m 0 (RTL.fn_stacksize f) = (m', stk) -> *) + (* forall R1 : HTL.state, *) + (* match_states (RTL.Callstate s (AST.Internal f) args m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) + (* match_states *) + (* (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) (RTL.fn_entrypoint f) *) + (* (RTL.init_regs args (RTL.fn_params f)) m') R2. *) + (* Proof. *) + (* intros s f args m m' stk H R1 MSTATE. *) + + (* inversion MSTATE; subst. inversion TF; subst. *) + (* econstructor. split. apply Smallstep.plus_one. *) + (* eapply HTL.step_call. crush. *) + + (* apply match_state with (sp' := stk); eauto. *) + + (* all: big_tac. *) + + (* apply regs_lessdef_add_greater. *) + (* unfold Plt; lia. *) + (* apply init_reg_assoc_empty. *) + + (* constructor. *) + + (* destruct (Mem.load AST.Mint32 m' stk *) + (* (Integers.Ptrofs.unsigned (Integers.Ptrofs.add *) + (* Integers.Ptrofs.zero *) + (* (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. *) + (* pose proof Mem.load_alloc_same as LOAD_ALLOC. *) + (* pose proof H as ALLOC. *) + (* eapply LOAD_ALLOC in ALLOC. *) + (* 2: { exact LOAD. } *) + (* ptrofs. rewrite LOAD. *) + (* rewrite ALLOC. *) + (* repeat constructor. *) + + (* ptrofs. rewrite LOAD. *) + (* repeat constructor. *) + + (* unfold reg_stack_based_pointers. intros. *) + (* unfold RTL.init_regs; crush. *) + (* destruct (RTL.fn_params f); *) + (* rewrite Registers.Regmap.gi; constructor. *) + + (* unfold arr_stack_based_pointers. intros. *) + (* crush. *) + (* destruct (Mem.load AST.Mint32 m' stk *) + (* (Integers.Ptrofs.unsigned (Integers.Ptrofs.add *) + (* Integers.Ptrofs.zero *) + (* (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. *) + (* pose proof Mem.load_alloc_same as LOAD_ALLOC. *) + (* pose proof H as ALLOC. *) + (* eapply LOAD_ALLOC in ALLOC. *) + (* 2: { exact LOAD. } *) + (* rewrite ALLOC. *) + (* repeat constructor. *) + (* constructor. *) + + (* Transparent Mem.alloc. (* TODO: Since there are opaque there's probably a lemma. *) *) + (* Transparent Mem.load. *) + (* Transparent Mem.store. *) + (* unfold stack_bounds. *) + (* split. *) + + (* unfold Mem.alloc in H. *) + (* invert H. *) + (* crush. *) + (* unfold Mem.load. *) + (* intros. *) + (* match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. *) + (* invert v0. unfold Mem.range_perm in H4. *) + (* unfold Mem.perm in H4. crush. *) + (* unfold Mem.perm_order' in H4. *) + (* small_tac. *) + (* exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. *) + (* rewrite Maps.PMap.gss in H8. *) + (* match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. *) + (* crush. *) + (* apply proj_sumbool_true in H10. lia. *) + + (* unfold Mem.alloc in H. *) + (* invert H. *) + (* crush. *) + (* unfold Mem.store. *) + (* intros. *) + (* match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. *) + (* invert v0. unfold Mem.range_perm in H4. *) + (* unfold Mem.perm in H4. crush. *) + (* unfold Mem.perm_order' in H4. *) + (* small_tac. *) + (* exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. *) + (* rewrite Maps.PMap.gss in H8. *) + (* match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. *) + (* crush. *) + (* apply proj_sumbool_true in H10. lia. *) + (* Opaque Mem.alloc. *) + (* Opaque Mem.load. *) + (* Opaque Mem.store. *) + (* Qed. *) + (* Hint Resolve transl_callstate_correct : htlproof. *) + + (* Lemma transl_returnstate_correct: *) + (* forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) *) + (* (rs : RTL.regset) (s : list RTL.stackframe) (vres : Values.val) (m : mem) *) + (* (R1 : HTL.state), *) + (* match_states (RTL.Returnstate (RTL.Stackframe res0 f sp pc rs :: s) vres m) R1 -> *) + (* exists R2 : HTL.state, *) + (* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) + (* match_states (RTL.State s f sp pc (Registers.Regmap.set res0 vres rs) m) R2. *) + (* Proof. *) + (* intros res0 f sp pc rs s vres m R1 MSTATE. *) + (* inversion MSTATE. inversion MF. *) + (* Qed. *) + (* Hint Resolve transl_returnstate_correct : htlproof. *) + + (* Lemma option_inv : *) + (* forall A x y, *) + (* @Some A x = Some y -> x = y. *) + (* Proof. intros. inversion H. trivial. Qed. *) + + (* Lemma main_tprog_internal : *) + (* forall b, *) + (* Globalenvs.Genv.find_symbol tge tprog.(AST.prog_main) = Some b -> *) + (* exists f, Genv.find_funct_ptr (Genv.globalenv tprog) b = Some (AST.Internal f). *) + (* Proof. *) + (* intros. *) + (* destruct TRANSL. unfold main_is_internal in H1. *) + (* repeat (unfold_match H1). replace b with b0. *) + (* exploit function_ptr_translated; eauto. intros [tf [A B]]. *) + (* unfold transl_fundef, AST.transf_partial_fundef, Errors.bind in B. *) + (* unfold_match B. inv B. econstructor. apply A. *) + + (* apply option_inv. rewrite <- Heqo. rewrite <- H. *) + (* rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). *) + (* trivial. symmetry; eapply Linking.match_program_main; eauto. *) + (* Qed. *) + + (* Lemma transl_initial_states : *) + (* forall s1 : Smallstep.state (RTL.semantics prog), *) + (* Smallstep.initial_state (RTL.semantics prog) s1 -> *) + (* exists s2 : Smallstep.state (HTL.semantics tprog), *) + (* Smallstep.initial_state (HTL.semantics tprog) s2 /\ match_states s1 s2. *) + (* Proof. *) + (* induction 1. *) + (* destruct TRANSL. unfold main_is_internal in H4. *) + (* repeat (unfold_match H4). *) + (* assert (f = AST.Internal f1). apply option_inv. *) + (* rewrite <- Heqo0. rewrite <- H1. replace b with b0. *) + (* auto. apply option_inv. rewrite <- H0. rewrite <- Heqo. *) + (* trivial. *) + (* exploit function_ptr_translated; eauto. *) + (* intros [tf [A B]]. *) + (* unfold transl_fundef, Errors.bind in B. *) + (* unfold AST.transf_partial_fundef, Errors.bind in B. *) + (* repeat (unfold_match B). inversion B. subst. *) + (* exploit main_tprog_internal; eauto; intros. *) + (* rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). *) + (* apply Heqo. symmetry; eapply Linking.match_program_main; eauto. *) + (* inversion H5. *) + (* econstructor; split. econstructor. *) + (* apply (Genv.init_mem_transf_partial TRANSL'); eauto. *) + (* replace (AST.prog_main tprog) with (AST.prog_main prog). *) + (* rewrite symbols_preserved; eauto. *) + (* symmetry; eapply Linking.match_program_main; eauto. *) + (* apply H6. *) + + (* constructor. *) + (* apply transl_module_correct. *) + (* assert (Some (AST.Internal x) = Some (AST.Internal m)). *) + (* replace (AST.fundef HTL.module) with (HTL.fundef). *) + (* rewrite <- H6. setoid_rewrite <- A. trivial. *) + (* trivial. inv H7. assumption. *) + (* Qed. *) + (* Hint Resolve transl_initial_states : htlproof. *) + + (* Lemma transl_final_states : *) + (* forall (s1 : Smallstep.state (RTL.semantics prog)) *) + (* (s2 : Smallstep.state (HTL.semantics tprog)) *) + (* (r : Integers.Int.int), *) + (* match_states s1 s2 -> *) + (* Smallstep.final_state (RTL.semantics prog) s1 r -> *) + (* Smallstep.final_state (HTL.semantics tprog) s2 r. *) + (* Proof. *) + (* intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. *) + (* Qed. *) + (* Hint Resolve transl_final_states : htlproof. *) + + (* Theorem transl_step_correct: *) + (* forall (S1 : RTL.state) t S2, *) + (* RTL.step ge S1 t S2 -> *) + (* forall (R1 : HTL.state), *) + (* match_states S1 R1 -> *) + (* exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states S2 R2. *) + (* Proof. *) + (* induction 1; eauto with htlproof; (intros; inv_state). *) + (* Qed. *) + (* Hint Resolve transl_step_correct : htlproof. *) + +(* Theorem transf_program_correct: *) +(* Smallstep.forward_simulation (RTL.semantics prog) (HTL.semantics tprog). *) +(* Proof. *) +(* Admitted. *) +(* (* eapply Smallstep.forward_simulation_plus; eauto with htlproof. *) *) +(* (* apply senv_preserved. *) *) +(* (* Qed. *) *) + +(* End CORRECTNESS. *) diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index a9626c4..4662cf4 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -148,462 +148,462 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - tr_instr fin rtrn st stk (RTL.Ijumptable r tbl) (Vskip) (Vcase (Vvar r) cexpr (Some Vskip)). Hint Constructors tr_instr : htlspec. -Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts trans : PTree.t stmnt) - (fin rtrn st stk : reg) : Prop := - tr_code_intro : - forall s t, - c!pc = Some i -> - stmnts!pc = Some s -> - trans!pc = Some t -> - tr_instr fin rtrn st stk i s t -> - tr_code c pc i stmnts trans fin rtrn st stk. -Hint Constructors tr_code : htlspec. - -Inductive tr_module (f : RTL.function) : module -> Prop := - tr_module_intro : - forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, - m = (mkmodule f.(RTL.fn_params) - data - control - f.(RTL.fn_entrypoint) - st stk stk_len fin rtrn start rst clk scldecls arrdecls wf) -> - (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> - tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> - stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> - Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> - 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> - st = ((RTL.max_reg_function f) + 1)%positive -> - fin = ((RTL.max_reg_function f) + 2)%positive -> - rtrn = ((RTL.max_reg_function f) + 3)%positive -> - stk = ((RTL.max_reg_function f) + 4)%positive -> - start = ((RTL.max_reg_function f) + 5)%positive -> - rst = ((RTL.max_reg_function f) + 6)%positive -> - clk = ((RTL.max_reg_function f) + 7)%positive -> - tr_module f m. -Hint Constructors tr_module : htlspec. - -Lemma create_reg_datapath_trans : - forall sz s s' x i iop, - create_reg iop sz s = OK x s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_datapath_trans : htlspec. - -Lemma create_reg_controllogic_trans : - forall sz s s' x i iop, - create_reg iop sz s = OK x s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_controllogic_trans : htlspec. - -Lemma declare_reg_datapath_trans : - forall sz s s' x i iop r, - declare_reg iop r sz s = OK x s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_datapath_trans : htlspec. - -Lemma declare_reg_controllogic_trans : - forall sz s s' x i iop r, - declare_reg iop r sz s = OK x s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_reg_controllogic_trans : htlspec. - -Lemma declare_reg_freshreg_trans : - forall sz s s' x i iop r, - declare_reg iop r sz s = OK x s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. inversion 1; auto. Qed. -Hint Resolve declare_reg_freshreg_trans : htlspec. - -Lemma create_arr_datapath_trans : - forall sz ln s s' x i iop, - create_arr iop sz ln s = OK x s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_arr_datapath_trans : htlspec. - -Lemma create_arr_controllogic_trans : - forall sz ln s s' x i iop, - create_arr iop sz ln s = OK x s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. intros. monadInv H. trivial. Qed. -Hint Resolve create_arr_controllogic_trans : htlspec. - -Lemma get_refl_x : - forall s s' x i, - get s = OK x s' i -> - s = x. -Proof. inversion 1. trivial. Qed. -Hint Resolve get_refl_x : htlspec. - -Lemma get_refl_s : - forall s s' x i, - get s = OK x s' i -> - s = s'. -Proof. inversion 1. trivial. Qed. -Hint Resolve get_refl_s : htlspec. - -Ltac inv_incr := - repeat match goal with - | [ H: create_reg _ _ ?s = OK _ ?s' _ |- _ ] => - let H1 := fresh "H" in - assert (H1 := H); eapply create_reg_datapath_trans in H; - eapply create_reg_controllogic_trans in H1 - | [ H: create_arr _ _ _ ?s = OK _ ?s' _ |- _ ] => - let H1 := fresh "H" in - assert (H1 := H); eapply create_arr_datapath_trans in H; - eapply create_arr_controllogic_trans in H1 - | [ H: get ?s = OK _ _ _ |- _ ] => - let H1 := fresh "H" in - assert (H1 := H); apply get_refl_x in H; apply get_refl_s in H1; - subst - | [ H: st_prop _ _ |- _ ] => unfold st_prop in H; destruct H - | [ H: st_incr _ _ |- _ ] => destruct st_incr - end. - -Lemma collect_controllogic_trans : - forall A f l cs cs' ci, - (forall s s' x i y, f y s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic)) -> - @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_controllogic) = cs'.(st_controllogic). -Proof. - induction l; intros; monadInv H0. - - trivial. - - apply H in EQ. rewrite EQ. eauto. -Qed. - -Lemma collect_datapath_trans : - forall A f l cs cs' ci, - (forall s s' x i y, f y s = OK x s' i -> s.(st_datapath) = s'.(st_datapath)) -> - @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_datapath) = cs'.(st_datapath). -Proof. - induction l; intros; monadInv H0. - - trivial. - - apply H in EQ. rewrite EQ. eauto. -Qed. - -Lemma collect_freshreg_trans : - forall A f l cs cs' ci, - (forall s s' x i y, f y s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg)) -> - @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_freshreg) = cs'.(st_freshreg). -Proof. - induction l; intros; monadInv H0. - - trivial. - - apply H in EQ. rewrite EQ. eauto. -Qed. - -Lemma collect_declare_controllogic_trans : - forall io n l s s' i, - HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> - s.(st_controllogic) = s'.(st_controllogic). -Proof. - intros. eapply collect_controllogic_trans; try eassumption. - intros. eapply declare_reg_controllogic_trans. simpl in H0. eassumption. -Qed. - -Lemma collect_declare_datapath_trans : - forall io n l s s' i, - HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> - s.(st_datapath) = s'.(st_datapath). -Proof. - intros. eapply collect_datapath_trans; try eassumption. - intros. eapply declare_reg_datapath_trans. simpl in H0. eassumption. -Qed. - -Lemma collect_declare_freshreg_trans : - forall io n l s s' i, - HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - intros. eapply collect_freshreg_trans; try eassumption. - inversion 1. auto. -Qed. - -Ltac unfold_match H := - match type of H with - | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate - end. - -Lemma translate_eff_addressing_freshreg_trans : - forall op args s r s' i, - translate_eff_addressing op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. -Qed. -Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. - -Lemma translate_comparison_freshreg_trans : - forall op args s r s' i, - translate_comparison op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. -Qed. -Hint Resolve translate_comparison_freshreg_trans : htlspec. - -Lemma translate_comparison_imm_freshreg_trans : - forall op args s r s' i n, - translate_comparison_imm op args n s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. -Qed. -Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. - -Lemma translate_condition_freshreg_trans : - forall op args s r s' i, - translate_condition op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. -Qed. -Hint Resolve translate_condition_freshreg_trans : htlspec. - -Lemma translate_instr_freshreg_trans : - forall op args s r s' i, - translate_instr op args s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. - monadInv H1. eauto with htlspec. -Qed. -Hint Resolve translate_instr_freshreg_trans : htlspec. - -Lemma translate_arr_access_freshreg_trans : - forall mem addr args st s r s' i, - translate_arr_access mem addr args st s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. -Qed. -Hint Resolve translate_arr_access_freshreg_trans : htlspec. - -Lemma add_instr_freshreg_trans : - forall n n' st s r s' i, - add_instr n n' st s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_instr_freshreg_trans : htlspec. - -Lemma add_branch_instr_freshreg_trans : - forall n n0 n1 e s r s' i, - add_branch_instr e n n0 n1 s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_branch_instr_freshreg_trans : htlspec. - -Lemma add_node_skip_freshreg_trans : - forall n1 n2 s r s' i, - add_node_skip n1 n2 s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_node_skip_freshreg_trans : htlspec. - -Lemma add_instr_skip_freshreg_trans : - forall n1 n2 s r s' i, - add_instr_skip n1 n2 s = OK r s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. -Hint Resolve add_instr_skip_freshreg_trans : htlspec. - -Lemma transf_instr_freshreg_trans : - forall fin ret st instr s v s' i, - transf_instr fin ret st instr s = OK v s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - intros. destruct instr eqn:?. subst. unfold transf_instr in H. - destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. - - apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. - apply declare_reg_freshreg_trans in EQ1. congruence. - - apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. - apply declare_reg_freshreg_trans in EQ1. congruence. - - apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. - - apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. - congruence. - - inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence. -Qed. -Hint Resolve transf_instr_freshreg_trans : htlspec. - -Lemma collect_trans_instr_freshreg_trans : - forall fin ret st l s s' i, - HTLMonadExtra.collectlist (transf_instr fin ret st) l s = OK tt s' i -> - s.(st_freshreg) = s'.(st_freshreg). -Proof. - intros. eapply collect_freshreg_trans; try eassumption. - eauto with htlspec. -Qed. - -Ltac rewrite_states := - match goal with - | [ H: ?x ?s = ?x ?s' |- _ ] => - let c1 := fresh "c" in - let c2 := fresh "c" in - remember (?x ?s) as c1; remember (?x ?s') as c2; try subst - end. - -Ltac inv_add_instr' H := - match type of H with - | ?f _ _ _ = OK _ _ _ => unfold f in H - | ?f _ _ _ _ = OK _ _ _ => unfold f in H - | ?f _ _ _ _ _ = OK _ _ _ => unfold f in H - end; repeat unfold_match H; inversion H. - -Ltac inv_add_instr := - lazymatch goal with - | H: context[add_instr_skip _ _ _] |- _ => - inv_add_instr' H - | H: context[add_instr_skip _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - | H: context[add_instr _ _ _ _] |- _ => - inv_add_instr' H - | H: context[add_instr _ _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - | H: context[add_branch_instr _ _ _ _ _] |- _ => - inv_add_instr' H - | H: context[add_branch_instr _ _ _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - | H: context[add_node_skip _ _ _] |- _ => - inv_add_instr' H - | H: context[add_node_skip _ _] |- _ => - monadInv H; inv_incr; inv_add_instr - end. - -Ltac destruct_optional := - match goal with H: option ?r |- _ => destruct H end. - -Lemma iter_expand_instr_spec : - forall l fin rtrn stack s s' i x c, - HTLMonadExtra.collectlist (transf_instr fin rtrn stack) l s = OK x s' i -> - list_norepet (List.map fst l) -> - (forall pc instr, In (pc, instr) l -> c!pc = Some instr) -> - (forall pc instr, In (pc, instr) l -> - c!pc = Some instr -> - tr_code c pc instr s'.(st_datapath) s'.(st_controllogic) fin rtrn s'.(st_st) stack). -Proof. - induction l; simpl; intros; try contradiction. - destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. - destruct (peq pc pc1). - - subst. - destruct instr1 eqn:?; try discriminate; - try destruct_optional; inv_add_instr; econstructor; try assumption. - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. - eapply in_map with (f := fst) in H9. contradiction. - - + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + inversion H2. inversion H14. unfold nonblock. replace (st_st s4) with (st_st s2) by congruence. - econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. - - + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. - econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct H2. - * inversion H2. - replace (st_st s2) with (st_st s0) by congruence. - eauto with htlspec. - * apply in_map with (f := fst) in H2. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct H2. - * inversion H2. - replace (st_st s2) with (st_st s0) by congruence. - eauto with htlspec. - * apply in_map with (f := fst) in H2. contradiction. - - + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. - + inversion H2. - * inversion H14. constructor. congruence. - * apply in_map with (f := fst) in H14. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + inversion H2. - * inversion H9. - replace (st_st s2) with (st_st s0) by congruence. - eauto with htlspec. - * apply in_map with (f := fst) in H9. contradiction. - - + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. - + inversion H2. - * inversion H9. - replace (st_st s2) with (st_st s0) by congruence. - eauto with htlspec. - * apply in_map with (f := fst) in H9. contradiction. - - - eapply IHl. apply EQ0. assumption. - destruct H2. inversion H2. subst. contradiction. - intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. - destruct H2. inv H2. contradiction. assumption. assumption. -Qed. -Hint Resolve iter_expand_instr_spec : htlspec. - -Lemma create_arr_inv : forall w x y z a b c d, - create_arr w x y z = OK (a, b) c d -> - y = b /\ a = z.(st_freshreg) /\ c.(st_freshreg) = Pos.succ (z.(st_freshreg)). -Proof. - inversion 1; split; auto. -Qed. - -Lemma create_reg_inv : forall a b s r s' i, - create_reg a b s = OK r s' i -> - r = s.(st_freshreg) /\ s'.(st_freshreg) = Pos.succ (s.(st_freshreg)). -Proof. - inversion 1; auto. -Qed. - -Theorem transl_module_correct : - forall f m, - transl_module f = Errors.OK m -> tr_module f m. -Proof. - intros until m. - unfold transl_module. - unfold run_mon. - destruct (transf_module f (max_state f)) eqn:?; try discriminate. - intros. inv H. - inversion s; subst. - - unfold transf_module in *. - unfold stack_correct in *. - destruct (0 <=? RTL.fn_stacksize f) eqn:STACK_BOUND_LOW; - destruct (RTL.fn_stacksize f *) +(* stmnts!pc = Some s -> *) +(* trans!pc = Some t -> *) +(* tr_instr fin rtrn st stk i s t -> *) +(* tr_code c pc i stmnts trans fin rtrn st stk. *) +(* Hint Constructors tr_code : htlspec. *) + +(* Inductive tr_module (f : RTL.function) : module -> Prop := *) +(* tr_module_intro : *) +(* forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, *) +(* m = (mkmodule f.(RTL.fn_params) *) +(* data *) +(* control *) +(* f.(RTL.fn_entrypoint) *) +(* st stk stk_len fin rtrn start rst clk scldecls arrdecls wf) -> *) +(* (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> *) +(* tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> *) +(* stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> *) +(* Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> *) +(* 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> *) +(* st = ((RTL.max_reg_function f) + 1)%positive -> *) +(* fin = ((RTL.max_reg_function f) + 2)%positive -> *) +(* rtrn = ((RTL.max_reg_function f) + 3)%positive -> *) +(* stk = ((RTL.max_reg_function f) + 4)%positive -> *) +(* start = ((RTL.max_reg_function f) + 5)%positive -> *) +(* rst = ((RTL.max_reg_function f) + 6)%positive -> *) +(* clk = ((RTL.max_reg_function f) + 7)%positive -> *) +(* tr_module f m. *) +(* Hint Constructors tr_module : htlspec. *) + +(* Lemma create_reg_datapath_trans : *) +(* forall sz s s' x i iop, *) +(* create_reg iop sz s = OK x s' i -> *) +(* s.(st_datapath) = s'.(st_datapath). *) +(* Proof. intros. monadInv H. trivial. Qed. *) +(* Hint Resolve create_reg_datapath_trans : htlspec. *) + +(* Lemma create_reg_controllogic_trans : *) +(* forall sz s s' x i iop, *) +(* create_reg iop sz s = OK x s' i -> *) +(* s.(st_controllogic) = s'.(st_controllogic). *) +(* Proof. intros. monadInv H. trivial. Qed. *) +(* Hint Resolve create_reg_controllogic_trans : htlspec. *) + +(* Lemma declare_reg_datapath_trans : *) +(* forall sz s s' x i iop r, *) +(* declare_reg iop r sz s = OK x s' i -> *) +(* s.(st_datapath) = s'.(st_datapath). *) +(* Proof. intros. monadInv H. trivial. Qed. *) +(* Hint Resolve create_reg_datapath_trans : htlspec. *) + +(* Lemma declare_reg_controllogic_trans : *) +(* forall sz s s' x i iop r, *) +(* declare_reg iop r sz s = OK x s' i -> *) +(* s.(st_controllogic) = s'.(st_controllogic). *) +(* Proof. intros. monadInv H. trivial. Qed. *) +(* Hint Resolve create_reg_controllogic_trans : htlspec. *) + +(* Lemma declare_reg_freshreg_trans : *) +(* forall sz s s' x i iop r, *) +(* declare_reg iop r sz s = OK x s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. inversion 1; auto. Qed. *) +(* Hint Resolve declare_reg_freshreg_trans : htlspec. *) + +(* Lemma create_arr_datapath_trans : *) +(* forall sz ln s s' x i iop, *) +(* create_arr iop sz ln s = OK x s' i -> *) +(* s.(st_datapath) = s'.(st_datapath). *) +(* Proof. intros. monadInv H. trivial. Qed. *) +(* Hint Resolve create_arr_datapath_trans : htlspec. *) + +(* Lemma create_arr_controllogic_trans : *) +(* forall sz ln s s' x i iop, *) +(* create_arr iop sz ln s = OK x s' i -> *) +(* s.(st_controllogic) = s'.(st_controllogic). *) +(* Proof. intros. monadInv H. trivial. Qed. *) +(* Hint Resolve create_arr_controllogic_trans : htlspec. *) + +(* Lemma get_refl_x : *) +(* forall s s' x i, *) +(* get s = OK x s' i -> *) +(* s = x. *) +(* Proof. inversion 1. trivial. Qed. *) +(* Hint Resolve get_refl_x : htlspec. *) + +(* Lemma get_refl_s : *) +(* forall s s' x i, *) +(* get s = OK x s' i -> *) +(* s = s'. *) +(* Proof. inversion 1. trivial. Qed. *) +(* Hint Resolve get_refl_s : htlspec. *) + +(* Ltac inv_incr := *) +(* repeat match goal with *) +(* | [ H: create_reg _ _ ?s = OK _ ?s' _ |- _ ] => *) +(* let H1 := fresh "H" in *) +(* assert (H1 := H); eapply create_reg_datapath_trans in H; *) +(* eapply create_reg_controllogic_trans in H1 *) +(* | [ H: create_arr _ _ _ ?s = OK _ ?s' _ |- _ ] => *) +(* let H1 := fresh "H" in *) +(* assert (H1 := H); eapply create_arr_datapath_trans in H; *) +(* eapply create_arr_controllogic_trans in H1 *) +(* | [ H: get ?s = OK _ _ _ |- _ ] => *) +(* let H1 := fresh "H" in *) +(* assert (H1 := H); apply get_refl_x in H; apply get_refl_s in H1; *) +(* subst *) +(* | [ H: st_prop _ _ |- _ ] => unfold st_prop in H; destruct H *) +(* | [ H: st_incr _ _ |- _ ] => destruct st_incr *) +(* end. *) + +(* Lemma collect_controllogic_trans : *) +(* forall A f l cs cs' ci, *) +(* (forall s s' x i y, f y s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic)) -> *) +(* @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_controllogic) = cs'.(st_controllogic). *) +(* Proof. *) +(* induction l; intros; monadInv H0. *) +(* - trivial. *) +(* - apply H in EQ. rewrite EQ. eauto. *) +(* Qed. *) + +(* Lemma collect_datapath_trans : *) +(* forall A f l cs cs' ci, *) +(* (forall s s' x i y, f y s = OK x s' i -> s.(st_datapath) = s'.(st_datapath)) -> *) +(* @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_datapath) = cs'.(st_datapath). *) +(* Proof. *) +(* induction l; intros; monadInv H0. *) +(* - trivial. *) +(* - apply H in EQ. rewrite EQ. eauto. *) +(* Qed. *) + +(* Lemma collect_freshreg_trans : *) +(* forall A f l cs cs' ci, *) +(* (forall s s' x i y, f y s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg)) -> *) +(* @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_freshreg) = cs'.(st_freshreg). *) +(* Proof. *) +(* induction l; intros; monadInv H0. *) +(* - trivial. *) +(* - apply H in EQ. rewrite EQ. eauto. *) +(* Qed. *) + +(* Lemma collect_declare_controllogic_trans : *) +(* forall io n l s s' i, *) +(* HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> *) +(* s.(st_controllogic) = s'.(st_controllogic). *) +(* Proof. *) +(* intros. eapply collect_controllogic_trans; try eassumption. *) +(* intros. eapply declare_reg_controllogic_trans. simpl in H0. eassumption. *) +(* Qed. *) + +(* Lemma collect_declare_datapath_trans : *) +(* forall io n l s s' i, *) +(* HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> *) +(* s.(st_datapath) = s'.(st_datapath). *) +(* Proof. *) +(* intros. eapply collect_datapath_trans; try eassumption. *) +(* intros. eapply declare_reg_datapath_trans. simpl in H0. eassumption. *) +(* Qed. *) + +(* Lemma collect_declare_freshreg_trans : *) +(* forall io n l s s' i, *) +(* HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* intros. eapply collect_freshreg_trans; try eassumption. *) +(* inversion 1. auto. *) +(* Qed. *) + +(* Ltac unfold_match H := *) +(* match type of H with *) +(* | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate *) +(* end. *) + +(* Lemma translate_eff_addressing_freshreg_trans : *) +(* forall op args s r s' i, *) +(* translate_eff_addressing op args s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. *) +(* Qed. *) +(* Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. *) + +(* Lemma translate_comparison_freshreg_trans : *) +(* forall op args s r s' i, *) +(* translate_comparison op args s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. *) +(* Qed. *) +(* Hint Resolve translate_comparison_freshreg_trans : htlspec. *) + +(* Lemma translate_comparison_imm_freshreg_trans : *) +(* forall op args s r s' i n, *) +(* translate_comparison_imm op args n s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. *) +(* Qed. *) +(* Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. *) + +(* Lemma translate_condition_freshreg_trans : *) +(* forall op args s r s' i, *) +(* translate_condition op args s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. *) +(* Qed. *) +(* Hint Resolve translate_condition_freshreg_trans : htlspec. *) + +(* Lemma translate_instr_freshreg_trans : *) +(* forall op args s r s' i, *) +(* translate_instr op args s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. *) +(* monadInv H1. eauto with htlspec. *) +(* Qed. *) +(* Hint Resolve translate_instr_freshreg_trans : htlspec. *) + +(* Lemma translate_arr_access_freshreg_trans : *) +(* forall mem addr args st s r s' i, *) +(* translate_arr_access mem addr args st s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. *) +(* Qed. *) +(* Hint Resolve translate_arr_access_freshreg_trans : htlspec. *) + +(* Lemma add_instr_freshreg_trans : *) +(* forall n n' st s r s' i, *) +(* add_instr n n' st s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. *) +(* Hint Resolve add_instr_freshreg_trans : htlspec. *) + +(* Lemma add_branch_instr_freshreg_trans : *) +(* forall n n0 n1 e s r s' i, *) +(* add_branch_instr e n n0 n1 s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. *) +(* Hint Resolve add_branch_instr_freshreg_trans : htlspec. *) + +(* Lemma add_node_skip_freshreg_trans : *) +(* forall n1 n2 s r s' i, *) +(* add_node_skip n1 n2 s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. *) +(* Hint Resolve add_node_skip_freshreg_trans : htlspec. *) + +(* Lemma add_instr_skip_freshreg_trans : *) +(* forall n1 n2 s r s' i, *) +(* add_instr_skip n1 n2 s = OK r s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. *) +(* Hint Resolve add_instr_skip_freshreg_trans : htlspec. *) + +(* Lemma transf_instr_freshreg_trans : *) +(* forall fin ret st instr s v s' i, *) +(* transf_instr fin ret st instr s = OK v s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* intros. destruct instr eqn:?. subst. unfold transf_instr in H. *) +(* destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. *) +(* - apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. *) +(* apply declare_reg_freshreg_trans in EQ1. congruence. *) +(* - apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. *) +(* apply declare_reg_freshreg_trans in EQ1. congruence. *) +(* - apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. *) +(* - apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. *) +(* congruence. *) +(* - inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence. *) +(* Qed. *) +(* Hint Resolve transf_instr_freshreg_trans : htlspec. *) + +(* Lemma collect_trans_instr_freshreg_trans : *) +(* forall fin ret st l s s' i, *) +(* HTLMonadExtra.collectlist (transf_instr fin ret st) l s = OK tt s' i -> *) +(* s.(st_freshreg) = s'.(st_freshreg). *) +(* Proof. *) +(* intros. eapply collect_freshreg_trans; try eassumption. *) +(* eauto with htlspec. *) +(* Qed. *) + +(* Ltac rewrite_states := *) +(* match goal with *) +(* | [ H: ?x ?s = ?x ?s' |- _ ] => *) +(* let c1 := fresh "c" in *) +(* let c2 := fresh "c" in *) +(* remember (?x ?s) as c1; remember (?x ?s') as c2; try subst *) +(* end. *) + +(* Ltac inv_add_instr' H := *) +(* match type of H with *) +(* | ?f _ _ _ = OK _ _ _ => unfold f in H *) +(* | ?f _ _ _ _ = OK _ _ _ => unfold f in H *) +(* | ?f _ _ _ _ _ = OK _ _ _ => unfold f in H *) +(* end; repeat unfold_match H; inversion H. *) + +(* Ltac inv_add_instr := *) +(* lazymatch goal with *) +(* | H: context[add_instr_skip _ _ _] |- _ => *) +(* inv_add_instr' H *) +(* | H: context[add_instr_skip _ _] |- _ => *) +(* monadInv H; inv_incr; inv_add_instr *) +(* | H: context[add_instr _ _ _ _] |- _ => *) +(* inv_add_instr' H *) +(* | H: context[add_instr _ _ _] |- _ => *) +(* monadInv H; inv_incr; inv_add_instr *) +(* | H: context[add_branch_instr _ _ _ _ _] |- _ => *) +(* inv_add_instr' H *) +(* | H: context[add_branch_instr _ _ _ _] |- _ => *) +(* monadInv H; inv_incr; inv_add_instr *) +(* | H: context[add_node_skip _ _ _] |- _ => *) +(* inv_add_instr' H *) +(* | H: context[add_node_skip _ _] |- _ => *) +(* monadInv H; inv_incr; inv_add_instr *) +(* end. *) + +(* Ltac destruct_optional := *) +(* match goal with H: option ?r |- _ => destruct H end. *) + +(* Lemma iter_expand_instr_spec : *) +(* forall l fin rtrn stack s s' i x c, *) +(* HTLMonadExtra.collectlist (transf_instr fin rtrn stack) l s = OK x s' i -> *) +(* list_norepet (List.map fst l) -> *) +(* (forall pc instr, In (pc, instr) l -> c!pc = Some instr) -> *) +(* (forall pc instr, In (pc, instr) l -> *) +(* c!pc = Some instr -> *) +(* tr_code c pc instr s'.(st_datapath) s'.(st_controllogic) fin rtrn s'.(st_st) stack). *) +(* Proof. *) +(* induction l; simpl; intros; try contradiction. *) +(* destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. *) +(* destruct (peq pc pc1). *) +(* - subst. *) +(* destruct instr1 eqn:?; try discriminate; *) +(* try destruct_optional; inv_add_instr; econstructor; try assumption. *) +(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. *) +(* eapply in_map with (f := fst) in H9. contradiction. *) + +(* + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) +(* + inversion H2. inversion H14. unfold nonblock. replace (st_st s4) with (st_st s2) by congruence. *) +(* econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. *) + +(* + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) +(* + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. *) +(* econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. *) + +(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct H2. *) +(* * inversion H2. *) +(* replace (st_st s2) with (st_st s0) by congruence. *) +(* eauto with htlspec. *) +(* * apply in_map with (f := fst) in H2. contradiction. *) + +(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct H2. *) +(* * inversion H2. *) +(* replace (st_st s2) with (st_st s0) by congruence. *) +(* eauto with htlspec. *) +(* * apply in_map with (f := fst) in H2. contradiction. *) + +(* + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) +(* + inversion H2. *) +(* * inversion H14. constructor. congruence. *) +(* * apply in_map with (f := fst) in H14. contradiction. *) + +(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + inversion H2. *) +(* * inversion H9. *) +(* replace (st_st s2) with (st_st s0) by congruence. *) +(* eauto with htlspec. *) +(* * apply in_map with (f := fst) in H9. contradiction. *) + +(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) +(* + inversion H2. *) +(* * inversion H9. *) +(* replace (st_st s2) with (st_st s0) by congruence. *) +(* eauto with htlspec. *) +(* * apply in_map with (f := fst) in H9. contradiction. *) + +(* - eapply IHl. apply EQ0. assumption. *) +(* destruct H2. inversion H2. subst. contradiction. *) +(* intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. *) +(* destruct H2. inv H2. contradiction. assumption. assumption. *) +(* Qed. *) +(* Hint Resolve iter_expand_instr_spec : htlspec. *) + +(* Lemma create_arr_inv : forall w x y z a b c d, *) +(* create_arr w x y z = OK (a, b) c d -> *) +(* y = b /\ a = z.(st_freshreg) /\ c.(st_freshreg) = Pos.succ (z.(st_freshreg)). *) +(* Proof. *) +(* inversion 1; split; auto. *) +(* Qed. *) + +(* Lemma create_reg_inv : forall a b s r s' i, *) +(* create_reg a b s = OK r s' i -> *) +(* r = s.(st_freshreg) /\ s'.(st_freshreg) = Pos.succ (s.(st_freshreg)). *) +(* Proof. *) +(* inversion 1; auto. *) +(* Qed. *) + +(* Theorem transl_module_correct : *) +(* forall f m, *) +(* transl_module f = Errors.OK m -> tr_module f m. *) +(* Proof. *) +(* intros until m. *) +(* unfold transl_module. *) +(* unfold run_mon. *) +(* destruct (transf_module f (max_state f)) eqn:?; try discriminate. *) +(* intros. inv H. *) +(* inversion s; subst. *) + +(* unfold transf_module in *. *) +(* unfold stack_correct in *. *) +(* destruct (0 <=? RTL.fn_stacksize f) eqn:STACK_BOUND_LOW; *) +(* destruct (RTL.fn_stacksize f . *) -open Value +open ValueInt open Datatypes open Camlcoq open AST diff --git a/src/verilog/PrintVerilog.ml b/src/verilog/PrintVerilog.ml index 5265c97..db78ad5 100644 --- a/src/verilog/PrintVerilog.ml +++ b/src/verilog/PrintVerilog.ml @@ -17,7 +17,7 @@ *) open Verilog -open Value +open ValueInt open Datatypes open Camlcoq @@ -70,11 +70,17 @@ let unop = function let register a = sprintf "reg_%d" (P.to_int a) -let literal l = sprintf "%d'd%d" (Nat.to_int l.vsize) (Z.to_int (uvalueToZ l)) +let literal l = sprintf "32'd%d" (Z.to_int (uvalueToZ l)) + +let byte n s = sprintf "reg_%d[%d:%d]" (P.to_int s) (7 + n * 8) (n * 8) let rec pprint_expr = function | Vlit l -> literal l | Vvar s -> register s + | Vvarb0 s -> byte 0 s + | Vvarb1 s -> byte 1 s + | Vvarb2 s -> byte 2 s + | Vvarb3 s -> byte 3 s | Vvari (s, i) -> concat [register s; "["; pprint_expr i; "]"] | Vinputvar s -> register s | Vunop (u, e) -> concat ["("; unop u; pprint_expr e; ")"] diff --git a/src/verilog/PrintVerilog.mli b/src/verilog/PrintVerilog.mli index 62bf63f..5fd8fe9 100644 --- a/src/verilog/PrintVerilog.mli +++ b/src/verilog/PrintVerilog.mli @@ -18,8 +18,8 @@ val pprint_stmnt : int -> Verilog.stmnt -> string -val print_value : out_channel -> Value.value -> unit +val print_value : out_channel -> ValueInt.value -> unit val print_program : bool -> out_channel -> Verilog.program -> unit -val print_result : out_channel -> (BinNums.positive * Value.value) list -> unit +val print_result : out_channel -> (BinNums.positive * ValueInt.value) list -> unit diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 064474a..921d9fd 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -29,7 +29,7 @@ Require Import Lia. Import ListNotations. -From coqup Require Import common.Coquplib common.Show verilog.ValueInt AssocMap Array. +From coqup Require Import common.Coquplib common.Show verilog.ValueInt IntegerExtra AssocMap Array. From compcert Require Events. From compcert Require Import Integers Errors Smallstep Globalenvs. @@ -154,9 +154,13 @@ Inductive unop : Type := (** ** Expressions *) Inductive expr : Type := -| Vlit : value -> expr -| Vvar : reg -> expr -| Vvari : reg -> expr -> expr +| Vlit : value -> expr (** literal *) +| Vvar : reg -> expr (** reg *) +| Vvarb0 : reg -> expr (** 1st byte projection of reg *) +| Vvarb1 : reg -> expr +| Vvarb2 : reg -> expr +| Vvarb3 : reg -> expr +| Vvari : reg -> expr -> expr (** array *) | Vinputvar : reg -> expr | Vbinop : binop -> expr -> expr -> expr | Vunop : unop -> expr -> expr @@ -340,6 +344,22 @@ Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop forall fext reg stack v r, reg#r = v -> expr_runp fext reg stack (Vvar r) v + | erun_Vvarb0 : + forall fext reg stack v r, + reg#r = v -> + expr_runp fext reg stack (Vvarb0 r) (IntExtra.ibyte0 v) + | erun_Vvarb1 : + forall fext reg stack v r, + reg#r = v -> + expr_runp fext reg stack (Vvarb1 r) (IntExtra.ibyte1 v) + | erun_Vvarb2 : + forall fext reg stack v r, + reg#r = v -> + expr_runp fext reg stack (Vvarb2 r) (IntExtra.ibyte2 v) + | erun_Vvarb3 : + forall fext reg stack v r, + reg#r = v -> + expr_runp fext reg stack (Vvarb3 r) (IntExtra.ibyte3 v) | erun_Vvari : forall fext reg stack v iexp i r, expr_runp fext reg stack iexp i -> @@ -429,6 +449,7 @@ Definition access_fext (f : fext) (r : reg) : res value := Inductive location : Type := | LocReg (_ : reg) +| LocRegB (_ : reg) (_ : nat) | LocArray (_ : reg) (_ : nat). Inductive location_is : fext -> assocmap -> assocmap_arr -> expr -> location -> Prop := @@ -775,6 +796,10 @@ Proof. repeat (try match goal with | [ H : expr_runp _ _ _ (Vlit _) _ |- _ ] => invert H | [ H : expr_runp _ _ _ (Vvar _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vvarb0 _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vvarb1 _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vvarb2 _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vvarb3 _) _ |- _ ] => invert H | [ H : expr_runp _ _ _ (Vvari _ _) _ |- _ ] => invert H | [ H : expr_runp _ _ _ (Vinputvar _) _ |- _ ] => invert H | [ H : expr_runp _ _ _ (Vbinop _ _ _) _ |- _ ] => invert H -- cgit From ea44bd696dcfb446f5f980f16d7df41b21357698 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Mon, 6 Jul 2020 19:27:51 +0100 Subject: Fix HTLgenspec. --- src/translation/HTLgen.v | 18 +- src/translation/HTLgenspec.v | 925 +++++++++++++++++++++---------------------- 2 files changed, 467 insertions(+), 476 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index 995977c..09af28a 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -414,21 +414,19 @@ Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) := end) (enumerate 0 ns). -Definition add_single_cycle_load (n n' : node) (stack : reg) (addr : expr) (dst : reg) : mon unit := +Definition create_single_cycle_load (stack : reg) (addr : expr) (dst : reg) : stmnt := let l0 := Vnonblock (Vvarb0 dst) (Vvari stack addr) in let l1 := Vnonblock (Vvarb1 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 1)) in let l2 := Vnonblock (Vvarb2 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) in - let l3 := Vnonblock (Vvarb3 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) in - let instr := Vseq l0 $ Vseq l1 $ Vseq l2 $ l3 - in add_instr n n' instr. + let l3 := Vnonblock (Vvarb3 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) + in Vseq l0 $ Vseq l1 $ Vseq l2 $ l3. -Definition add_single_cycle_store (n n' : node) (stack : reg) (addr : expr) (src : reg) : mon unit := +Definition create_single_cycle_store (stack : reg) (addr : expr) (src : reg) : stmnt := let l0 := Vnonblock (Vvari stack addr) (Vvarb0 src) in let l1 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 1)) (Vvarb1 src) in let l2 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb2 src) in - let l3 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb3 src) in - let instr := Vseq l0 $ Vseq l1 $ Vseq l2 $ l3 - in add_instr n n' instr. + let l3 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb3 src) + in Vseq l0 $ Vseq l1 $ Vseq l2 $ l3. Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon unit := match ni with @@ -442,10 +440,10 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni | Iload mem addr args dst n' => do addr' <- translate_eff_addressing addr args; do _ <- declare_reg None dst 32; - add_single_cycle_load n n' stack addr' dst + add_instr n n' $ create_single_cycle_load stack addr' dst | Istore mem addr args src n' => do addr' <- translate_eff_addressing addr args; - add_single_cycle_store n n' stack addr' src + add_instr n n' $ create_single_cycle_store stack addr' src | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.") | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.") | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.") diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index 4662cf4..bbcde14 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -134,476 +134,469 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - tr_instr fin rtrn st stk (RTL.Ireturn (Some r)) (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r))) Vskip | tr_instr_Iload : - forall mem addr args s s' i c dst n, - translate_arr_access mem addr args stk s = OK c s' i -> - tr_instr fin rtrn st stk (RTL.Iload mem addr args dst n) (nonblock dst c) (state_goto st n) + forall mem addr args s s' i e dst n, + translate_eff_addressing addr args s = OK e s' i -> + tr_instr fin rtrn st stk (RTL.Iload mem addr args dst n) + (create_single_cycle_load stk e dst) (state_goto st n) | tr_instr_Istore : - forall mem addr args s s' i c src n, - translate_arr_access mem addr args stk s = OK c s' i -> - tr_instr fin rtrn st stk (RTL.Istore mem addr args src n) (Vnonblock c (Vvar src)) - (state_goto st n) + forall mem addr args s s' i e src n, + translate_eff_addressing addr args s = OK e s' i -> + tr_instr fin rtrn st stk (RTL.Istore mem addr args src n) + (create_single_cycle_store stk e src) (state_goto st n) | tr_instr_Ijumptable : forall cexpr tbl r, cexpr = tbl_to_case_expr st tbl -> tr_instr fin rtrn st stk (RTL.Ijumptable r tbl) (Vskip) (Vcase (Vvar r) cexpr (Some Vskip)). Hint Constructors tr_instr : htlspec. -(* Inductive tr_code (c : RTL.code) (pc : RTL.node) (i : RTL.instruction) (stmnts trans : PTree.t stmnt) *) -(* (fin rtrn st stk : reg) : Prop := *) -(* tr_code_intro : *) -(* forall s t, *) -(* c!pc = Some i -> *) -(* stmnts!pc = Some s -> *) -(* trans!pc = Some t -> *) -(* tr_instr fin rtrn st stk i s t -> *) -(* tr_code c pc i stmnts trans fin rtrn st stk. *) -(* Hint Constructors tr_code : htlspec. *) - -(* Inductive tr_module (f : RTL.function) : module -> Prop := *) -(* tr_module_intro : *) -(* forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, *) -(* m = (mkmodule f.(RTL.fn_params) *) -(* data *) -(* control *) -(* f.(RTL.fn_entrypoint) *) -(* st stk stk_len fin rtrn start rst clk scldecls arrdecls wf) -> *) -(* (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> *) -(* tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> *) -(* stk_len = Z.to_nat (f.(RTL.fn_stacksize) / 4) -> *) -(* Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> *) -(* 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> *) -(* st = ((RTL.max_reg_function f) + 1)%positive -> *) -(* fin = ((RTL.max_reg_function f) + 2)%positive -> *) -(* rtrn = ((RTL.max_reg_function f) + 3)%positive -> *) -(* stk = ((RTL.max_reg_function f) + 4)%positive -> *) -(* start = ((RTL.max_reg_function f) + 5)%positive -> *) -(* rst = ((RTL.max_reg_function f) + 6)%positive -> *) -(* clk = ((RTL.max_reg_function f) + 7)%positive -> *) -(* tr_module f m. *) -(* Hint Constructors tr_module : htlspec. *) - -(* Lemma create_reg_datapath_trans : *) -(* forall sz s s' x i iop, *) -(* create_reg iop sz s = OK x s' i -> *) -(* s.(st_datapath) = s'.(st_datapath). *) -(* Proof. intros. monadInv H. trivial. Qed. *) -(* Hint Resolve create_reg_datapath_trans : htlspec. *) - -(* Lemma create_reg_controllogic_trans : *) -(* forall sz s s' x i iop, *) -(* create_reg iop sz s = OK x s' i -> *) -(* s.(st_controllogic) = s'.(st_controllogic). *) -(* Proof. intros. monadInv H. trivial. Qed. *) -(* Hint Resolve create_reg_controllogic_trans : htlspec. *) - -(* Lemma declare_reg_datapath_trans : *) -(* forall sz s s' x i iop r, *) -(* declare_reg iop r sz s = OK x s' i -> *) -(* s.(st_datapath) = s'.(st_datapath). *) -(* Proof. intros. monadInv H. trivial. Qed. *) -(* Hint Resolve create_reg_datapath_trans : htlspec. *) - -(* Lemma declare_reg_controllogic_trans : *) -(* forall sz s s' x i iop r, *) -(* declare_reg iop r sz s = OK x s' i -> *) -(* s.(st_controllogic) = s'.(st_controllogic). *) -(* Proof. intros. monadInv H. trivial. Qed. *) -(* Hint Resolve create_reg_controllogic_trans : htlspec. *) - -(* Lemma declare_reg_freshreg_trans : *) -(* forall sz s s' x i iop r, *) -(* declare_reg iop r sz s = OK x s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. inversion 1; auto. Qed. *) -(* Hint Resolve declare_reg_freshreg_trans : htlspec. *) - -(* Lemma create_arr_datapath_trans : *) -(* forall sz ln s s' x i iop, *) -(* create_arr iop sz ln s = OK x s' i -> *) -(* s.(st_datapath) = s'.(st_datapath). *) -(* Proof. intros. monadInv H. trivial. Qed. *) -(* Hint Resolve create_arr_datapath_trans : htlspec. *) - -(* Lemma create_arr_controllogic_trans : *) -(* forall sz ln s s' x i iop, *) -(* create_arr iop sz ln s = OK x s' i -> *) -(* s.(st_controllogic) = s'.(st_controllogic). *) -(* Proof. intros. monadInv H. trivial. Qed. *) -(* Hint Resolve create_arr_controllogic_trans : htlspec. *) - -(* Lemma get_refl_x : *) -(* forall s s' x i, *) -(* get s = OK x s' i -> *) -(* s = x. *) -(* Proof. inversion 1. trivial. Qed. *) -(* Hint Resolve get_refl_x : htlspec. *) - -(* Lemma get_refl_s : *) -(* forall s s' x i, *) -(* get s = OK x s' i -> *) -(* s = s'. *) -(* Proof. inversion 1. trivial. Qed. *) -(* Hint Resolve get_refl_s : htlspec. *) - -(* Ltac inv_incr := *) -(* repeat match goal with *) -(* | [ H: create_reg _ _ ?s = OK _ ?s' _ |- _ ] => *) -(* let H1 := fresh "H" in *) -(* assert (H1 := H); eapply create_reg_datapath_trans in H; *) -(* eapply create_reg_controllogic_trans in H1 *) -(* | [ H: create_arr _ _ _ ?s = OK _ ?s' _ |- _ ] => *) -(* let H1 := fresh "H" in *) -(* assert (H1 := H); eapply create_arr_datapath_trans in H; *) -(* eapply create_arr_controllogic_trans in H1 *) -(* | [ H: get ?s = OK _ _ _ |- _ ] => *) -(* let H1 := fresh "H" in *) -(* assert (H1 := H); apply get_refl_x in H; apply get_refl_s in H1; *) -(* subst *) -(* | [ H: st_prop _ _ |- _ ] => unfold st_prop in H; destruct H *) -(* | [ H: st_incr _ _ |- _ ] => destruct st_incr *) -(* end. *) - -(* Lemma collect_controllogic_trans : *) -(* forall A f l cs cs' ci, *) -(* (forall s s' x i y, f y s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic)) -> *) -(* @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_controllogic) = cs'.(st_controllogic). *) -(* Proof. *) -(* induction l; intros; monadInv H0. *) -(* - trivial. *) -(* - apply H in EQ. rewrite EQ. eauto. *) -(* Qed. *) - -(* Lemma collect_datapath_trans : *) -(* forall A f l cs cs' ci, *) -(* (forall s s' x i y, f y s = OK x s' i -> s.(st_datapath) = s'.(st_datapath)) -> *) -(* @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_datapath) = cs'.(st_datapath). *) -(* Proof. *) -(* induction l; intros; monadInv H0. *) -(* - trivial. *) -(* - apply H in EQ. rewrite EQ. eauto. *) -(* Qed. *) - -(* Lemma collect_freshreg_trans : *) -(* forall A f l cs cs' ci, *) -(* (forall s s' x i y, f y s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg)) -> *) -(* @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_freshreg) = cs'.(st_freshreg). *) -(* Proof. *) -(* induction l; intros; monadInv H0. *) -(* - trivial. *) -(* - apply H in EQ. rewrite EQ. eauto. *) -(* Qed. *) - -(* Lemma collect_declare_controllogic_trans : *) -(* forall io n l s s' i, *) -(* HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> *) -(* s.(st_controllogic) = s'.(st_controllogic). *) -(* Proof. *) -(* intros. eapply collect_controllogic_trans; try eassumption. *) -(* intros. eapply declare_reg_controllogic_trans. simpl in H0. eassumption. *) -(* Qed. *) - -(* Lemma collect_declare_datapath_trans : *) -(* forall io n l s s' i, *) -(* HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> *) -(* s.(st_datapath) = s'.(st_datapath). *) -(* Proof. *) -(* intros. eapply collect_datapath_trans; try eassumption. *) -(* intros. eapply declare_reg_datapath_trans. simpl in H0. eassumption. *) -(* Qed. *) - -(* Lemma collect_declare_freshreg_trans : *) -(* forall io n l s s' i, *) -(* HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* intros. eapply collect_freshreg_trans; try eassumption. *) -(* inversion 1. auto. *) -(* Qed. *) - -(* Ltac unfold_match H := *) -(* match type of H with *) -(* | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate *) -(* end. *) - -(* Lemma translate_eff_addressing_freshreg_trans : *) -(* forall op args s r s' i, *) -(* translate_eff_addressing op args s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. *) -(* Qed. *) -(* Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. *) - -(* Lemma translate_comparison_freshreg_trans : *) -(* forall op args s r s' i, *) -(* translate_comparison op args s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. *) -(* Qed. *) -(* Hint Resolve translate_comparison_freshreg_trans : htlspec. *) - -(* Lemma translate_comparison_imm_freshreg_trans : *) -(* forall op args s r s' i n, *) -(* translate_comparison_imm op args n s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. *) -(* Qed. *) -(* Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. *) - -(* Lemma translate_condition_freshreg_trans : *) -(* forall op args s r s' i, *) -(* translate_condition op args s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. *) -(* Qed. *) -(* Hint Resolve translate_condition_freshreg_trans : htlspec. *) - -(* Lemma translate_instr_freshreg_trans : *) -(* forall op args s r s' i, *) -(* translate_instr op args s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. *) -(* monadInv H1. eauto with htlspec. *) -(* Qed. *) -(* Hint Resolve translate_instr_freshreg_trans : htlspec. *) - -(* Lemma translate_arr_access_freshreg_trans : *) -(* forall mem addr args st s r s' i, *) -(* translate_arr_access mem addr args st s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* intros. unfold translate_arr_access in H. repeat (unfold_match H); inv H; eauto with htlspec. *) -(* Qed. *) -(* Hint Resolve translate_arr_access_freshreg_trans : htlspec. *) - -(* Lemma add_instr_freshreg_trans : *) -(* forall n n' st s r s' i, *) -(* add_instr n n' st s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. *) -(* Hint Resolve add_instr_freshreg_trans : htlspec. *) - -(* Lemma add_branch_instr_freshreg_trans : *) -(* forall n n0 n1 e s r s' i, *) -(* add_branch_instr e n n0 n1 s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. *) -(* Hint Resolve add_branch_instr_freshreg_trans : htlspec. *) - -(* Lemma add_node_skip_freshreg_trans : *) -(* forall n1 n2 s r s' i, *) -(* add_node_skip n1 n2 s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. *) -(* Hint Resolve add_node_skip_freshreg_trans : htlspec. *) - -(* Lemma add_instr_skip_freshreg_trans : *) -(* forall n1 n2 s r s' i, *) -(* add_instr_skip n1 n2 s = OK r s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. *) -(* Hint Resolve add_instr_skip_freshreg_trans : htlspec. *) - -(* Lemma transf_instr_freshreg_trans : *) -(* forall fin ret st instr s v s' i, *) -(* transf_instr fin ret st instr s = OK v s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* intros. destruct instr eqn:?. subst. unfold transf_instr in H. *) -(* destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. *) -(* - apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. *) -(* apply declare_reg_freshreg_trans in EQ1. congruence. *) -(* - apply add_instr_freshreg_trans in EQ2. apply translate_arr_access_freshreg_trans in EQ. *) -(* apply declare_reg_freshreg_trans in EQ1. congruence. *) -(* - apply add_instr_freshreg_trans in EQ0. apply translate_arr_access_freshreg_trans in EQ. congruence. *) -(* - apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. *) -(* congruence. *) -(* - inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence. *) -(* Qed. *) -(* Hint Resolve transf_instr_freshreg_trans : htlspec. *) - -(* Lemma collect_trans_instr_freshreg_trans : *) -(* forall fin ret st l s s' i, *) -(* HTLMonadExtra.collectlist (transf_instr fin ret st) l s = OK tt s' i -> *) -(* s.(st_freshreg) = s'.(st_freshreg). *) -(* Proof. *) -(* intros. eapply collect_freshreg_trans; try eassumption. *) -(* eauto with htlspec. *) -(* Qed. *) - -(* Ltac rewrite_states := *) -(* match goal with *) -(* | [ H: ?x ?s = ?x ?s' |- _ ] => *) -(* let c1 := fresh "c" in *) -(* let c2 := fresh "c" in *) -(* remember (?x ?s) as c1; remember (?x ?s') as c2; try subst *) -(* end. *) - -(* Ltac inv_add_instr' H := *) -(* match type of H with *) -(* | ?f _ _ _ = OK _ _ _ => unfold f in H *) -(* | ?f _ _ _ _ = OK _ _ _ => unfold f in H *) -(* | ?f _ _ _ _ _ = OK _ _ _ => unfold f in H *) -(* end; repeat unfold_match H; inversion H. *) - -(* Ltac inv_add_instr := *) -(* lazymatch goal with *) -(* | H: context[add_instr_skip _ _ _] |- _ => *) -(* inv_add_instr' H *) -(* | H: context[add_instr_skip _ _] |- _ => *) -(* monadInv H; inv_incr; inv_add_instr *) -(* | H: context[add_instr _ _ _ _] |- _ => *) -(* inv_add_instr' H *) -(* | H: context[add_instr _ _ _] |- _ => *) -(* monadInv H; inv_incr; inv_add_instr *) -(* | H: context[add_branch_instr _ _ _ _ _] |- _ => *) -(* inv_add_instr' H *) -(* | H: context[add_branch_instr _ _ _ _] |- _ => *) -(* monadInv H; inv_incr; inv_add_instr *) -(* | H: context[add_node_skip _ _ _] |- _ => *) -(* inv_add_instr' H *) -(* | H: context[add_node_skip _ _] |- _ => *) -(* monadInv H; inv_incr; inv_add_instr *) -(* end. *) - -(* Ltac destruct_optional := *) -(* match goal with H: option ?r |- _ => destruct H end. *) - -(* Lemma iter_expand_instr_spec : *) -(* forall l fin rtrn stack s s' i x c, *) -(* HTLMonadExtra.collectlist (transf_instr fin rtrn stack) l s = OK x s' i -> *) -(* list_norepet (List.map fst l) -> *) -(* (forall pc instr, In (pc, instr) l -> c!pc = Some instr) -> *) -(* (forall pc instr, In (pc, instr) l -> *) -(* c!pc = Some instr -> *) -(* tr_code c pc instr s'.(st_datapath) s'.(st_controllogic) fin rtrn s'.(st_st) stack). *) -(* Proof. *) -(* induction l; simpl; intros; try contradiction. *) -(* destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. *) -(* destruct (peq pc pc1). *) -(* - subst. *) -(* destruct instr1 eqn:?; try discriminate; *) -(* try destruct_optional; inv_add_instr; econstructor; try assumption. *) -(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. *) -(* eapply in_map with (f := fst) in H9. contradiction. *) - -(* + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) -(* + inversion H2. inversion H14. unfold nonblock. replace (st_st s4) with (st_st s2) by congruence. *) -(* econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. *) - -(* + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) -(* + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. *) -(* econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. *) - -(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct H2. *) -(* * inversion H2. *) -(* replace (st_st s2) with (st_st s0) by congruence. *) -(* eauto with htlspec. *) -(* * apply in_map with (f := fst) in H2. contradiction. *) - -(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct H2. *) -(* * inversion H2. *) -(* replace (st_st s2) with (st_st s0) by congruence. *) -(* eauto with htlspec. *) -(* * apply in_map with (f := fst) in H2. contradiction. *) - -(* + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. *) -(* + inversion H2. *) -(* * inversion H14. constructor. congruence. *) -(* * apply in_map with (f := fst) in H14. contradiction. *) - -(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + inversion H2. *) -(* * inversion H9. *) -(* replace (st_st s2) with (st_st s0) by congruence. *) -(* eauto with htlspec. *) -(* * apply in_map with (f := fst) in H9. contradiction. *) - -(* + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. *) -(* + inversion H2. *) -(* * inversion H9. *) -(* replace (st_st s2) with (st_st s0) by congruence. *) -(* eauto with htlspec. *) -(* * apply in_map with (f := fst) in H9. contradiction. *) - -(* - eapply IHl. apply EQ0. assumption. *) -(* destruct H2. inversion H2. subst. contradiction. *) -(* intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. *) -(* destruct H2. inv H2. contradiction. assumption. assumption. *) -(* Qed. *) -(* Hint Resolve iter_expand_instr_spec : htlspec. *) - -(* Lemma create_arr_inv : forall w x y z a b c d, *) -(* create_arr w x y z = OK (a, b) c d -> *) -(* y = b /\ a = z.(st_freshreg) /\ c.(st_freshreg) = Pos.succ (z.(st_freshreg)). *) -(* Proof. *) -(* inversion 1; split; auto. *) -(* Qed. *) - -(* Lemma create_reg_inv : forall a b s r s' i, *) -(* create_reg a b s = OK r s' i -> *) -(* r = s.(st_freshreg) /\ s'.(st_freshreg) = Pos.succ (s.(st_freshreg)). *) -(* Proof. *) -(* inversion 1; auto. *) -(* Qed. *) - -(* Theorem transl_module_correct : *) -(* forall f m, *) -(* transl_module f = Errors.OK m -> tr_module f m. *) -(* Proof. *) -(* intros until m. *) -(* unfold transl_module. *) -(* unfold run_mon. *) -(* destruct (transf_module f (max_state f)) eqn:?; try discriminate. *) -(* intros. inv H. *) -(* inversion s; subst. *) - -(* unfold transf_module in *. *) -(* unfold stack_correct in *. *) -(* destruct (0 <=? RTL.fn_stacksize f) eqn:STACK_BOUND_LOW; *) -(* destruct (RTL.fn_stacksize f + stmnts!pc = Some s -> + trans!pc = Some t -> + tr_instr fin rtrn st stk i s t -> + tr_code c pc i stmnts trans fin rtrn st stk. +Hint Constructors tr_code : htlspec. + +Inductive tr_module (f : RTL.function) : module -> Prop := + tr_module_intro : + forall data control fin rtrn st stk stk_len m start rst clk scldecls arrdecls wf, + m = (mkmodule f.(RTL.fn_params) + data + control + f.(RTL.fn_entrypoint) + st stk stk_len fin rtrn start rst clk scldecls arrdecls wf) -> + (forall pc i, Maps.PTree.get pc f.(RTL.fn_code) = Some i -> + tr_code f.(RTL.fn_code) pc i data control fin rtrn st stk) -> + stk_len = Z.to_nat f.(RTL.fn_stacksize) -> + Z.modulo (f.(RTL.fn_stacksize)) 4 = 0 -> + 0 <= f.(RTL.fn_stacksize) < Integers.Ptrofs.modulus -> + st = ((RTL.max_reg_function f) + 1)%positive -> + fin = ((RTL.max_reg_function f) + 2)%positive -> + rtrn = ((RTL.max_reg_function f) + 3)%positive -> + stk = ((RTL.max_reg_function f) + 4)%positive -> + start = ((RTL.max_reg_function f) + 5)%positive -> + rst = ((RTL.max_reg_function f) + 6)%positive -> + clk = ((RTL.max_reg_function f) + 7)%positive -> + tr_module f m. +Hint Constructors tr_module : htlspec. + +Lemma create_reg_datapath_trans : + forall sz s s' x i iop, + create_reg iop sz s = OK x s' i -> + s.(st_datapath) = s'.(st_datapath). +Proof. intros. monadInv H. trivial. Qed. +Hint Resolve create_reg_datapath_trans : htlspec. + +Lemma create_reg_controllogic_trans : + forall sz s s' x i iop, + create_reg iop sz s = OK x s' i -> + s.(st_controllogic) = s'.(st_controllogic). +Proof. intros. monadInv H. trivial. Qed. +Hint Resolve create_reg_controllogic_trans : htlspec. + +Lemma declare_reg_datapath_trans : + forall sz s s' x i iop r, + declare_reg iop r sz s = OK x s' i -> + s.(st_datapath) = s'.(st_datapath). +Proof. intros. monadInv H. trivial. Qed. +Hint Resolve create_reg_datapath_trans : htlspec. + +Lemma declare_reg_controllogic_trans : + forall sz s s' x i iop r, + declare_reg iop r sz s = OK x s' i -> + s.(st_controllogic) = s'.(st_controllogic). +Proof. intros. monadInv H. trivial. Qed. +Hint Resolve create_reg_controllogic_trans : htlspec. + +Lemma declare_reg_freshreg_trans : + forall sz s s' x i iop r, + declare_reg iop r sz s = OK x s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. inversion 1; auto. Qed. +Hint Resolve declare_reg_freshreg_trans : htlspec. + +Lemma create_arr_datapath_trans : + forall sz ln s s' x i iop, + create_arr iop sz ln s = OK x s' i -> + s.(st_datapath) = s'.(st_datapath). +Proof. intros. monadInv H. trivial. Qed. +Hint Resolve create_arr_datapath_trans : htlspec. + +Lemma create_arr_controllogic_trans : + forall sz ln s s' x i iop, + create_arr iop sz ln s = OK x s' i -> + s.(st_controllogic) = s'.(st_controllogic). +Proof. intros. monadInv H. trivial. Qed. +Hint Resolve create_arr_controllogic_trans : htlspec. + +Lemma get_refl_x : + forall s s' x i, + get s = OK x s' i -> + s = x. +Proof. inversion 1. trivial. Qed. +Hint Resolve get_refl_x : htlspec. + +Lemma get_refl_s : + forall s s' x i, + get s = OK x s' i -> + s = s'. +Proof. inversion 1. trivial. Qed. +Hint Resolve get_refl_s : htlspec. + +Ltac inv_incr := + repeat match goal with + | [ H: create_reg _ _ ?s = OK _ ?s' _ |- _ ] => + let H1 := fresh "H" in + assert (H1 := H); eapply create_reg_datapath_trans in H; + eapply create_reg_controllogic_trans in H1 + | [ H: create_arr _ _ _ ?s = OK _ ?s' _ |- _ ] => + let H1 := fresh "H" in + assert (H1 := H); eapply create_arr_datapath_trans in H; + eapply create_arr_controllogic_trans in H1 + | [ H: get ?s = OK _ _ _ |- _ ] => + let H1 := fresh "H" in + assert (H1 := H); apply get_refl_x in H; apply get_refl_s in H1; + subst + | [ H: st_prop _ _ |- _ ] => unfold st_prop in H; destruct H + | [ H: st_incr _ _ |- _ ] => destruct st_incr + end. + +Lemma collect_controllogic_trans : + forall A f l cs cs' ci, + (forall s s' x i y, f y s = OK x s' i -> s.(st_controllogic) = s'.(st_controllogic)) -> + @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_controllogic) = cs'.(st_controllogic). +Proof. + induction l; intros; monadInv H0. + - trivial. + - apply H in EQ. rewrite EQ. eauto. +Qed. + +Lemma collect_datapath_trans : + forall A f l cs cs' ci, + (forall s s' x i y, f y s = OK x s' i -> s.(st_datapath) = s'.(st_datapath)) -> + @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_datapath) = cs'.(st_datapath). +Proof. + induction l; intros; monadInv H0. + - trivial. + - apply H in EQ. rewrite EQ. eauto. +Qed. + +Lemma collect_freshreg_trans : + forall A f l cs cs' ci, + (forall s s' x i y, f y s = OK x s' i -> s.(st_freshreg) = s'.(st_freshreg)) -> + @HTLMonadExtra.collectlist A f l cs = OK tt cs' ci -> cs.(st_freshreg) = cs'.(st_freshreg). +Proof. + induction l; intros; monadInv H0. + - trivial. + - apply H in EQ. rewrite EQ. eauto. +Qed. + +Lemma collect_declare_controllogic_trans : + forall io n l s s' i, + HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> + s.(st_controllogic) = s'.(st_controllogic). +Proof. + intros. eapply collect_controllogic_trans; try eassumption. + intros. eapply declare_reg_controllogic_trans. simpl in H0. eassumption. +Qed. + +Lemma collect_declare_datapath_trans : + forall io n l s s' i, + HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> + s.(st_datapath) = s'.(st_datapath). +Proof. + intros. eapply collect_datapath_trans; try eassumption. + intros. eapply declare_reg_datapath_trans. simpl in H0. eassumption. +Qed. + +Lemma collect_declare_freshreg_trans : + forall io n l s s' i, + HTLMonadExtra.collectlist (fun r : reg => declare_reg io r n) l s = OK tt s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. eapply collect_freshreg_trans; try eassumption. + inversion 1. auto. +Qed. + +Ltac unfold_match H := + match type of H with + | context[match ?g with _ => _ end] => destruct g eqn:?; try discriminate + end. + +Lemma translate_eff_addressing_freshreg_trans : + forall op args s r s' i, + translate_eff_addressing op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. + +Lemma translate_comparison_freshreg_trans : + forall op args s r s' i, + translate_comparison op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_comparison_freshreg_trans : htlspec. + +Lemma translate_comparison_imm_freshreg_trans : + forall op args s r s' i n, + translate_comparison_imm op args n s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. + +Lemma translate_condition_freshreg_trans : + forall op args s r s' i, + translate_condition op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. +Qed. +Hint Resolve translate_condition_freshreg_trans : htlspec. + +Lemma translate_instr_freshreg_trans : + forall op args s r s' i, + translate_instr op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; eauto with htlspec. + monadInv H1. eauto with htlspec. +Qed. +Hint Resolve translate_instr_freshreg_trans : htlspec. + +Lemma add_instr_freshreg_trans : + forall n n' st s r s' i, + add_instr n n' st s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_instr in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_instr_freshreg_trans : htlspec. + +Lemma add_branch_instr_freshreg_trans : + forall n n0 n1 e s r s' i, + add_branch_instr e n n0 n1 s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_branch_instr in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_branch_instr_freshreg_trans : htlspec. + +Lemma add_node_skip_freshreg_trans : + forall n1 n2 s r s' i, + add_node_skip n1 n2 s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_node_skip in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_node_skip_freshreg_trans : htlspec. + +Lemma add_instr_skip_freshreg_trans : + forall n1 n2 s r s' i, + add_instr_skip n1 n2 s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. intros. unfold add_instr_skip in H. repeat (unfold_match H). inv H. auto. Qed. +Hint Resolve add_instr_skip_freshreg_trans : htlspec. + +Lemma transf_instr_freshreg_trans : + forall fin ret st instr s v s' i, + transf_instr fin ret st instr s = OK v s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. destruct instr eqn:?. subst. unfold transf_instr in H. + destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. + - apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. + apply declare_reg_freshreg_trans in EQ1. congruence. + - apply add_instr_freshreg_trans in EQ2. apply translate_eff_addressing_freshreg_trans in EQ. + apply declare_reg_freshreg_trans in EQ1. congruence. + - apply add_instr_freshreg_trans in EQ0. apply translate_eff_addressing_freshreg_trans in EQ. + congruence. + - apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. + congruence. + - inv EQ. apply add_node_skip_freshreg_trans in EQ0. congruence. +Qed. +Hint Resolve transf_instr_freshreg_trans : htlspec. + +Lemma collect_trans_instr_freshreg_trans : + forall fin ret st l s s' i, + HTLMonadExtra.collectlist (transf_instr fin ret st) l s = OK tt s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + intros. eapply collect_freshreg_trans; try eassumption. + eauto with htlspec. +Qed. + +Ltac rewrite_states := + match goal with + | [ H: ?x ?s = ?x ?s' |- _ ] => + let c1 := fresh "c" in + let c2 := fresh "c" in + remember (?x ?s) as c1; remember (?x ?s') as c2; try subst + end. + +Ltac inv_add_instr' H := + match type of H with + | ?f _ _ _ = OK _ _ _ => unfold f in H + | ?f _ _ _ _ = OK _ _ _ => unfold f in H + | ?f _ _ _ _ _ = OK _ _ _ => unfold f in H + end; repeat unfold_match H; inversion H. + +Ltac inv_add_instr := + lazymatch goal with + | H: context[add_instr_skip _ _ _] |- _ => + inv_add_instr' H + | H: context[add_instr_skip _ _] |- _ => + monadInv H; inv_incr; inv_add_instr + | H: context[add_instr _ _ _ _] |- _ => + inv_add_instr' H + | H: context[add_instr _ _ _] |- _ => + monadInv H; inv_incr; inv_add_instr + | H: context[add_branch_instr _ _ _ _ _] |- _ => + inv_add_instr' H + | H: context[add_branch_instr _ _ _ _] |- _ => + monadInv H; inv_incr; inv_add_instr + | H: context[add_node_skip _ _ _] |- _ => + inv_add_instr' H + | H: context[add_node_skip _ _] |- _ => + monadInv H; inv_incr; inv_add_instr + end. + +Ltac destruct_optional := + match goal with H: option ?r |- _ => destruct H end. + +Lemma iter_expand_instr_spec : + forall l fin rtrn stack s s' i x c, + HTLMonadExtra.collectlist (transf_instr fin rtrn stack) l s = OK x s' i -> + list_norepet (List.map fst l) -> + (forall pc instr, In (pc, instr) l -> c!pc = Some instr) -> + (forall pc instr, In (pc, instr) l -> + c!pc = Some instr -> + tr_code c pc instr s'.(st_datapath) s'.(st_controllogic) fin rtrn s'.(st_st) stack). +Proof. + induction l; simpl; intros; try contradiction. + destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr. + destruct (peq pc pc1). + - subst. + destruct instr1 eqn:?; try discriminate; + try destruct_optional; inv_add_instr; econstructor; try assumption. + + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. + eapply in_map with (f := fst) in H9. contradiction. + + + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + + inversion H2. inversion H14. unfold nonblock. replace (st_st s4) with (st_st s2) by congruence. + econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + + + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. + econstructor. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + + + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct H2. + * inversion H2. + replace (st_st s2) with (st_st s0) by congruence. + eauto with htlspec. + * apply in_map with (f := fst) in H2. contradiction. + + + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct H2. + * inversion H2. + replace (st_st s2) with (st_st s0) by congruence. + eauto with htlspec. + * apply in_map with (f := fst) in H2. contradiction. + + + destruct o with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + + inversion H2. + * inversion H14. constructor. congruence. + * apply in_map with (f := fst) in H14. contradiction. + + + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + inversion H2. + * inversion H9. + replace (st_st s2) with (st_st s0) by congruence. + eauto with htlspec. + * apply in_map with (f := fst) in H9. contradiction. + + + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + + inversion H2. + * inversion H9. + replace (st_st s2) with (st_st s0) by congruence. + eauto with htlspec. + * apply in_map with (f := fst) in H9. contradiction. + + - eapply IHl. apply EQ0. assumption. + destruct H2. inversion H2. subst. contradiction. + intros. specialize H1 with pc0 instr0. destruct H1. tauto. trivial. + destruct H2. inv H2. contradiction. assumption. assumption. +Qed. +Hint Resolve iter_expand_instr_spec : htlspec. + +Lemma create_arr_inv : forall w x y z a b c d, + create_arr w x y z = OK (a, b) c d -> + y = b /\ a = z.(st_freshreg) /\ c.(st_freshreg) = Pos.succ (z.(st_freshreg)). +Proof. + inversion 1; split; auto. +Qed. + +Lemma create_reg_inv : forall a b s r s' i, + create_reg a b s = OK r s' i -> + r = s.(st_freshreg) /\ s'.(st_freshreg) = Pos.succ (s.(st_freshreg)). +Proof. + inversion 1; auto. +Qed. + +Theorem transl_module_correct : + forall f m, + transl_module f = Errors.OK m -> tr_module f m. +Proof. + intros until m. + unfold transl_module. + unfold run_mon. + destruct (transf_module f (max_state f)) eqn:?; try discriminate. + intros. inv H. + inversion s; subst. + + unfold transf_module in *. + unfold stack_correct in *. + destruct (0 <=? RTL.fn_stacksize f) eqn:STACK_BOUND_LOW; + destruct (RTL.fn_stacksize f Date: Mon, 6 Jul 2020 20:29:36 +0100 Subject: Remove alignment requirement for lessdef. --- src/verilog/ValueInt.v | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/verilog/ValueInt.v b/src/verilog/ValueInt.v index aa99fbd..80c512f 100644 --- a/src/verilog/ValueInt.v +++ b/src/verilog/ValueInt.v @@ -77,13 +77,10 @@ Definition ptrToValue (i : ptrofs) : value := Ptrofs.to_int i. Definition valueToPtr (i : value) : Integers.ptrofs := Ptrofs.of_int i. -Search Ptrofs.of_int Ptrofs.to_int. Definition valToValue (v : Values.val) : option value := match v with | Values.Vint i => Some (intToValue i) - | Values.Vptr b off => if Z.eqb (Z.modulo (uvalueToZ (ptrToValue off)) 4) 0%Z - then Some (ptrToValue off) - else None + | Values.Vptr b off => Some (ptrToValue off) | Values.Vundef => Some (ZToValue 0%Z) | _ => None end. @@ -117,7 +114,6 @@ Inductive val_value_lessdef: val -> value -> Prop := | val_value_lessdef_ptr: forall b off v', off = valueToPtr v' -> - (Z.modulo (uvalueToZ v') 4) = 0%Z -> val_value_lessdef (Vptr b off) v' | lessdef_undef: forall v, val_value_lessdef Vundef v. @@ -162,8 +158,6 @@ Proof. destruct v; try discriminate; constructor. unfold valToValue in H. inversion H. unfold valueToInt. unfold intToValue in H1. auto. - inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0); try discriminate. - inv H1. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial. - inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0) eqn:?; try discriminate. - inv H1. apply Z.eqb_eq. apply Heqb0. + inv H. symmetry. + unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial. Qed. -- cgit From e1d9c228bece9926d42e49d3d8b7f4a1fe726b44 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Mon, 6 Jul 2020 20:54:40 +0100 Subject: Check chunk size during translation. --- src/translation/HTLgen.v | 30 +++++++++++++++++++----------- src/translation/HTLgenspec.v | 22 ++++++++++++++-------- 2 files changed, 33 insertions(+), 19 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index 65b6627..04de548 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -442,17 +442,25 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni do _ <- declare_reg None dst 32; add_instr n n' (nonblock dst instr) else error (Errors.msg "State is larger than 2^32.") - | Iload mem addr args dst n' => - if Z.leb (Z.pos n') Integers.Int.max_unsigned - then do addr' <- translate_eff_addressing addr args; - do _ <- declare_reg None dst 32; - add_instr n n' $ create_single_cycle_load stack addr' dst - else error (Errors.msg "State is larger than 2^32.") - | Istore mem addr args src n' => - if Z.leb (Z.pos n') Integers.Int.max_unsigned - then do addr' <- translate_eff_addressing addr args; - add_instr n n' $ create_single_cycle_store stack addr' src - else error (Errors.msg "State is larger than 2^32.") + | Iload chunk addr args dst n' => + match chunk with + | Mint32 => + if Z.leb (Z.pos n') Integers.Int.max_unsigned + then do addr' <- translate_eff_addressing addr args; + do _ <- declare_reg None dst 32; + add_instr n n' $ create_single_cycle_load stack addr' dst + else error (Errors.msg "State is larger than 2^32.") + | _ => error (Errors.msg "Iload invalid chunk size.") + end + | Istore chunk addr args src n' => + match chunk with + | Mint32 => + if Z.leb (Z.pos n') Integers.Int.max_unsigned + then do addr' <- translate_eff_addressing addr args; + add_instr n n' $ create_single_cycle_store stack addr' src + else error (Errors.msg "State is larger than 2^32.") + | _ => error (Errors.msg "Istore invalid chunk size.") + end | Icall _ _ _ _ _ => error (Errors.msg "Calls are not implemented.") | Itailcall _ _ _ => error (Errors.msg "Tailcalls are not implemented.") | Ibuiltin _ _ _ _ => error (Errors.msg "Builtin functions not implemented.") diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index aba5d0c..dda91ca 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -138,16 +138,18 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - tr_instr fin rtrn st stk (RTL.Ireturn (Some r)) (Vseq (block fin (Vlit (ZToValue 1%Z))) (block rtrn (Vvar r))) Vskip | tr_instr_Iload : - forall mem addr args s s' i e dst n, + forall chunk addr args s s' i e dst n, Z.pos n <= Int.max_unsigned -> + chunk = AST.Mint32 -> translate_eff_addressing addr args s = OK e s' i -> - tr_instr fin rtrn st stk (RTL.Iload mem addr args dst n) + tr_instr fin rtrn st stk (RTL.Iload chunk addr args dst n) (create_single_cycle_load stk e dst) (state_goto st n) | tr_instr_Istore : - forall mem addr args s s' i e src n, + forall chunk addr args s s' i e src n, Z.pos n <= Int.max_unsigned -> + chunk = AST.Mint32 -> translate_eff_addressing addr args s = OK e s' i -> - tr_instr fin rtrn st stk (RTL.Istore mem addr args src n) + tr_instr fin rtrn st stk (RTL.Istore chunk addr args src n) (create_single_cycle_store stk e src) (state_goto st n) | tr_instr_Ijumptable : forall cexpr tbl r, @@ -415,10 +417,12 @@ Proof. destruct i0; try (monadInv H); try (unfold_match H); eauto with htlspec. - monadInv H. apply add_instr_freshreg_trans in EQ2. apply translate_instr_freshreg_trans in EQ. apply declare_reg_freshreg_trans in EQ1. congruence. - - monadInv H. apply add_instr_freshreg_trans in EQ2. + - destruct (Z.pos n0 <=? Int.max_unsigned); try discriminate. + monadInv H. apply add_instr_freshreg_trans in EQ2. apply translate_eff_addressing_freshreg_trans in EQ. apply declare_reg_freshreg_trans in EQ1. congruence. - - monadInv H. apply add_instr_freshreg_trans in EQ0. + - destruct (Z.pos n0 <=? Int.max_unsigned); try discriminate. + monadInv H. apply add_instr_freshreg_trans in EQ0. apply translate_eff_addressing_freshreg_trans in EQ. congruence. - monadInv H. apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. @@ -491,7 +495,8 @@ Proof. destruct (peq pc pc1). - subst. destruct instr1 eqn:?; try discriminate; - try destruct_optional; inv_add_instr; econstructor; try assumption. + try destruct_optional; try (destruct m; try discriminate); + inv_add_instr; econstructor; try assumption. + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + destruct o0 with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. + inversion H2. inversion H9. rewrite H. apply tr_instr_Inop. @@ -508,6 +513,7 @@ Proof. + destruct o0 with pc1; destruct H16; simpl in *; rewrite AssocMap.gss in H14; eauto; congruence. + inversion H2. inversion H14. rewrite <- e2. replace (st_st s2) with (st_st s0) by congruence. econstructor. apply Z.leb_le; assumption. + reflexivity. apply EQ1. eapply in_map with (f := fst) in H14. contradiction. + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. @@ -516,7 +522,7 @@ Proof. * inversion H2. replace (st_st s2) with (st_st s0) by congruence. econstructor. apply Z.leb_le; assumption. - eauto with htlspec. + eauto with htlspec. eassumption. * apply in_map with (f := fst) in H2. contradiction. + destruct o with pc1; destruct H11; simpl in *; rewrite AssocMap.gss in H9; eauto; congruence. -- cgit From b0e1a1383890d9b0a14ffaabce4c3d6453eb0a9c Mon Sep 17 00:00:00 2001 From: James Pollard Date: Mon, 6 Jul 2020 21:05:05 +0100 Subject: Reduce number of array addressing modes. --- src/translation/HTLgen.v | 16 ++++++++++++++-- src/translation/HTLgenspec.v | 17 +++++++++++++---- 2 files changed, 27 insertions(+), 6 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index 04de548..35203f8 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -402,6 +402,18 @@ Definition add_branch_instr (e: expr) (n n1 n2: node) : mon unit := (* | _, _, _ => error (Errors.msg "HTLgen: translate_arr_access unsuported addressing") *) (* end. *) +Definition translate_arr_addressing (a: Op.addressing) (args: list reg) : mon expr := + match a, args with (* TODO: We should be more methodical here; what are the possibilities?*) + | Op.Aindexed off, r1::nil => + ret (boplitz Vadd r1 off) + | Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) + ret (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) + | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) + let a := Integers.Ptrofs.unsigned a in + ret (Vlit (ZToValue a)) + | _, _ => error (Errors.msg "Veriloggen: translate_arr_addressing unsuported addressing") + end. + Fixpoint enumerate (i : nat) (ns : list node) {struct ns} : list (nat * node) := match ns with | n :: ns' => (i, n) :: enumerate (i+1) ns' @@ -446,7 +458,7 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni match chunk with | Mint32 => if Z.leb (Z.pos n') Integers.Int.max_unsigned - then do addr' <- translate_eff_addressing addr args; + then do addr' <- translate_arr_addressing addr args; do _ <- declare_reg None dst 32; add_instr n n' $ create_single_cycle_load stack addr' dst else error (Errors.msg "State is larger than 2^32.") @@ -456,7 +468,7 @@ Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon uni match chunk with | Mint32 => if Z.leb (Z.pos n') Integers.Int.max_unsigned - then do addr' <- translate_eff_addressing addr args; + then do addr' <- translate_arr_addressing addr args; add_instr n n' $ create_single_cycle_store stack addr' src else error (Errors.msg "State is larger than 2^32.") | _ => error (Errors.msg "Istore invalid chunk size.") diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index dda91ca..1b04b1f 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -141,14 +141,14 @@ Inductive tr_instr (fin rtrn st stk : reg) : RTL.instruction -> stmnt -> stmnt - forall chunk addr args s s' i e dst n, Z.pos n <= Int.max_unsigned -> chunk = AST.Mint32 -> - translate_eff_addressing addr args s = OK e s' i -> + translate_arr_addressing addr args s = OK e s' i -> tr_instr fin rtrn st stk (RTL.Iload chunk addr args dst n) (create_single_cycle_load stk e dst) (state_goto st n) | tr_instr_Istore : forall chunk addr args s s' i e src n, Z.pos n <= Int.max_unsigned -> chunk = AST.Mint32 -> - translate_eff_addressing addr args s = OK e s' i -> + translate_arr_addressing addr args s = OK e s' i -> tr_instr fin rtrn st stk (RTL.Istore chunk addr args src n) (create_single_cycle_store stk e src) (state_goto st n) | tr_instr_Ijumptable : @@ -343,6 +343,15 @@ Proof. Qed. Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. +Lemma translate_arr_addressing_freshreg_trans : + forall op args s r s' i, + translate_arr_addressing op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_eff_addressing_freshreg_trans : htlspec. + Lemma translate_comparison_freshreg_trans : forall op args s r s' i, translate_comparison op args s = OK r s' i -> @@ -419,11 +428,11 @@ Proof. apply declare_reg_freshreg_trans in EQ1. congruence. - destruct (Z.pos n0 <=? Int.max_unsigned); try discriminate. monadInv H. apply add_instr_freshreg_trans in EQ2. - apply translate_eff_addressing_freshreg_trans in EQ. + apply translate_arr_addressing_freshreg_trans in EQ. apply declare_reg_freshreg_trans in EQ1. congruence. - destruct (Z.pos n0 <=? Int.max_unsigned); try discriminate. monadInv H. apply add_instr_freshreg_trans in EQ0. - apply translate_eff_addressing_freshreg_trans in EQ. congruence. + apply translate_arr_addressing_freshreg_trans in EQ. congruence. - monadInv H. apply translate_condition_freshreg_trans in EQ. apply add_branch_instr_freshreg_trans in EQ0. congruence. -- cgit From 897b2b15a810e996895dda0d863dcefb27dfabaf Mon Sep 17 00:00:00 2001 From: James Pollard Date: Mon, 6 Jul 2020 23:20:00 +0100 Subject: Concatenation style loads. --- src/translation/HTLgen.v | 8 ++--- src/verilog/PrintVerilog.ml | 10 +++++- src/verilog/Verilog.v | 85 +++++++++++++++++++++++---------------------- 3 files changed, 54 insertions(+), 49 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index 35203f8..d1c1363 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -427,17 +427,13 @@ Definition tbl_to_case_expr (st : reg) (ns : list node) : list (expr * stmnt) := (enumerate 0 ns). Definition create_single_cycle_load (stack : reg) (addr : expr) (dst : reg) : stmnt := - let l0 := Vnonblock (Vvarb0 dst) (Vvari stack addr) in - let l1 := Vnonblock (Vvarb1 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 1)) in - let l2 := Vnonblock (Vvarb2 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) in - let l3 := Vnonblock (Vvarb3 dst) (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) - in Vseq l0 $ Vseq l1 $ Vseq l2 $ l3. + Vnonblock (Vvar dst) (Vload stack addr). Definition create_single_cycle_store (stack : reg) (addr : expr) (src : reg) : stmnt := let l0 := Vnonblock (Vvari stack addr) (Vvarb0 src) in let l1 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 1)) (Vvarb1 src) in let l2 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb2 src) in - let l3 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 2)) (Vvarb3 src) + let l3 := Vnonblock (Vvari stack $ Vbinop Vadd addr (Vlit $ ZToValue 3)) (Vvarb3 src) in Vseq l0 $ Vseq l1 $ Vseq l2 $ l3. Definition transf_instr (fin rtrn stack: reg) (ni: node * instruction) : mon unit := diff --git a/src/verilog/PrintVerilog.ml b/src/verilog/PrintVerilog.ml index db78ad5..7f3eb29 100644 --- a/src/verilog/PrintVerilog.ml +++ b/src/verilog/PrintVerilog.ml @@ -72,9 +72,16 @@ let register a = sprintf "reg_%d" (P.to_int a) let literal l = sprintf "32'd%d" (Z.to_int (uvalueToZ l)) +let literal_int i = sprintf "32'd%d" i + let byte n s = sprintf "reg_%d[%d:%d]" (P.to_int s) (7 + n * 8) (n * 8) -let rec pprint_expr = function + +let rec pprint_expr = + let array_byte r i = function + | 0 -> concat [register r; "["; pprint_expr i; "]"] + | n -> concat [register r; "["; pprint_expr i; " + "; literal_int n; "][7:0]"] + in function | Vlit l -> literal l | Vvar s -> register s | Vvarb0 s -> byte 0 s @@ -86,6 +93,7 @@ let rec pprint_expr = function | Vunop (u, e) -> concat ["("; unop u; pprint_expr e; ")"] | Vbinop (op, a, b) -> concat [pprint_binop (pprint_expr a) (pprint_expr b) op] | Vternary (c, t, f) -> concat ["("; pprint_expr c; " ? "; pprint_expr t; " : "; pprint_expr f; ")"] + | Vload (s, i) -> concat ["{"; array_byte s i 3; ", "; array_byte s i 2; ", "; array_byte s i 1; ", "; array_byte s i 0; "}"] let rec pprint_stmnt i = let pprint_case (e, s) = concat [ indent (i + 1); pprint_expr e; ": begin\n"; pprint_stmnt (i + 2) s; diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 108ac72..94e6184 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -164,7 +164,8 @@ Inductive expr : Type := | Vinputvar : reg -> expr | Vbinop : binop -> expr -> expr -> expr | Vunop : unop -> expr -> expr -| Vternary : expr -> expr -> expr -> expr. +| Vternary : expr -> expr -> expr -> expr +| Vload : reg -> expr -> expr. (** 4-byte concatenation load *) Definition posToExpr (p : positive) : expr := Vlit (posToValue p). @@ -338,61 +339,61 @@ Definition unop_run (op : unop) (v1 : value) : value := Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop := | erun_Vlit : - forall fext reg stack v, - expr_runp fext reg stack (Vlit v) v + forall fext asr asa v, + expr_runp fext asr asa (Vlit v) v | erun_Vvar : - forall fext reg stack v r, - reg#r = v -> - expr_runp fext reg stack (Vvar r) v + forall fext asr asa v r, + asr#r = v -> + expr_runp fext asr asa (Vvar r) v | erun_Vvarb0 : - forall fext reg stack v r, - reg#r = v -> - expr_runp fext reg stack (Vvarb0 r) (IntExtra.ibyte0 v) + forall fext asr asa v r, + asr#r = v -> + expr_runp fext asr asa (Vvarb0 r) (IntExtra.ibyte0 v) | erun_Vvarb1 : - forall fext reg stack v r, - reg#r = v -> - expr_runp fext reg stack (Vvarb1 r) (IntExtra.ibyte1 v) + forall fext asr asa v r, + asr#r = v -> + expr_runp fext asr asa (Vvarb1 r) (IntExtra.ibyte1 v) | erun_Vvarb2 : - forall fext reg stack v r, - reg#r = v -> - expr_runp fext reg stack (Vvarb2 r) (IntExtra.ibyte2 v) + forall fext asr asa v r, + asr#r = v -> + expr_runp fext asr asa (Vvarb2 r) (IntExtra.ibyte2 v) | erun_Vvarb3 : - forall fext reg stack v r, - reg#r = v -> - expr_runp fext reg stack (Vvarb3 r) (IntExtra.ibyte3 v) + forall fext asr asa v r, + asr#r = v -> + expr_runp fext asr asa (Vvarb3 r) (IntExtra.ibyte3 v) | erun_Vvari : - forall fext reg stack v iexp i r, - expr_runp fext reg stack iexp i -> - arr_assocmap_lookup stack r (valueToNat i) = Some v -> - expr_runp fext reg stack (Vvari r iexp) v + forall fext asr asa v iexp i r, + expr_runp fext asr asa iexp i -> + arr_assocmap_lookup asa r (valueToNat i) = Some v -> + expr_runp fext asr asa (Vvari r iexp) v | erun_Vinputvar : - forall fext reg stack r v, + forall fext asr asa r v, fext!r = Some v -> - expr_runp fext reg stack (Vinputvar r) v + expr_runp fext asr asa (Vinputvar r) v | erun_Vbinop : - forall fext reg stack op l r lv rv resv, - expr_runp fext reg stack l lv -> - expr_runp fext reg stack r rv -> + forall fext asr asa op l r lv rv resv, + expr_runp fext asr asa l lv -> + expr_runp fext asr asa r rv -> Some resv = binop_run op lv rv -> - expr_runp fext reg stack (Vbinop op l r) resv + expr_runp fext asr asa (Vbinop op l r) resv | erun_Vunop : - forall fext reg stack u vu op oper resv, - expr_runp fext reg stack u vu -> + forall fext asr asa u vu op oper resv, + expr_runp fext asr asa u vu -> oper = unop_run op -> resv = oper vu -> - expr_runp fext reg stack (Vunop op u) resv + expr_runp fext asr asa (Vunop op u) resv | erun_Vternary_true : - forall fext reg stack c ts fs vc vt, - expr_runp fext reg stack c vc -> - expr_runp fext reg stack ts vt -> + forall fext asr asa c ts fs vc vt, + expr_runp fext asr asa c vc -> + expr_runp fext asr asa ts vt -> valueToBool vc = true -> - expr_runp fext reg stack (Vternary c ts fs) vt + expr_runp fext asr asa (Vternary c ts fs) vt | erun_Vternary_false : - forall fext reg stack c ts fs vc vf, - expr_runp fext reg stack c vc -> - expr_runp fext reg stack fs vf -> + forall fext asr asa c ts fs vc vf, + expr_runp fext asr asa c vc -> + expr_runp fext asr asa fs vf -> valueToBool vc = false -> - expr_runp fext reg stack (Vternary c ts fs) vf. + expr_runp fext asr asa (Vternary c ts fs) vf. Hint Constructors expr_runp : verilog. Definition handle_opt {A : Type} (err : errmsg) (val : option A) @@ -449,12 +450,11 @@ Definition access_fext (f : fext) (r : reg) : res value := Inductive location : Type := | LocReg (_ : reg) -| LocRegB (_ : reg) (_ : nat) | LocArray (_ : reg) (_ : nat). Inductive location_is : fext -> assocmap -> assocmap_arr -> expr -> location -> Prop := -| Base : forall f asr asa r, location_is f asr asa (Vvar r) (LocReg r) -| Indexed : forall f asr asa r iexp iv, +| Reg : forall f asr asa r, location_is f asr asa (Vvar r) (LocReg r) +| RegIndexed : forall f asr asa r iexp iv, expr_runp f asr asa iexp iv -> location_is f asr asa (Vvari r iexp) (LocArray r (valueToNat iv)). @@ -807,6 +807,7 @@ Proof. | [ H : expr_runp _ _ _ (Vbinop _ _ _) _ |- _ ] => invert H | [ H : expr_runp _ _ _ (Vunop _ _) _ |- _ ] => invert H | [ H : expr_runp _ _ _ (Vternary _ _ _) _ |- _ ] => invert H + | [ H : expr_runp _ _ _ (Vload _ _) _ |- _ ] => invert H | [ H1 : forall asr asa v, expr_runp _ asr asa ?e v -> _, H2 : expr_runp _ _ _ ?e _ |- _ ] => -- cgit From 128b5d3a20647db3d0b17cc918d17fe5cadc07ff Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 6 Jul 2020 23:27:05 +0100 Subject: Add top level backward simulation --- src/Compiler.v | 127 ++++++++++++++++++++++++++++++----- src/translation/HTLgenproof.v | 149 ++++++++++++++++++++++-------------------- src/verilog/ValueInt.v | 10 +-- 3 files changed, 191 insertions(+), 95 deletions(-) diff --git a/src/Compiler.v b/src/Compiler.v index 17d8921..05353f9 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -16,6 +16,8 @@ * along with this program. If not, see . *) +From coqup Require Import HTLgenproof. + From compcert.common Require Import Errors Linking. @@ -49,8 +51,9 @@ From coqup Require Verilog Veriloggen Veriloggenproof - HTLgen - HTLgenproof. + HTLgen. + +From compcert Require Import Smallstep. Parameter print_RTL: Z -> RTL.program -> unit. Parameter print_HTL: HTL.program -> unit. @@ -85,7 +88,9 @@ Definition transf_backend (r : RTL.program) : res Verilog.program := @@ print print_HTL @@ Veriloggen.transl_program. -Definition transf_frontend (p: Csyntax.program) : res RTL.program := +Check mkpass. + +Definition transf_hls (p : Csyntax.program) : res Verilog.program := OK p @@@ SimplExpr.transl_program @@@ SimplLocals.transf_program @@ -93,11 +98,6 @@ Definition transf_frontend (p: Csyntax.program) : res RTL.program := @@@ Cminorgen.transl_program @@@ Selection.sel_program @@@ RTLgen.transl_program - @@ print (print_RTL 0). - -Definition transf_hls (p : Csyntax.program) : res Verilog.program := - OK p - @@@ transf_frontend @@@ transf_backend. Local Open Scope linking_scope. @@ -110,27 +110,30 @@ Definition CompCert's_passes := ::: mkpass Selectionproof.match_prog ::: mkpass RTLgenproof.match_prog ::: mkpass Inliningproof.match_prog - ::: mkpass HTLgenproof.match_prog + ::: (@mkpass _ _ HTLgenproof.match_prog (HTLgenproof.TransfHTLLink HTLgen.transl_program)) ::: mkpass Veriloggenproof.match_prog ::: pass_nil _. -Definition match_prog: Csyntax.program -> RTL.program -> Prop := +Definition match_prog: Csyntax.program -> Verilog.program -> Prop := pass_match (compose_passes CompCert's_passes). -Theorem transf_frontend_match: +Theorem transf_hls_match: forall p tp, - transf_frontend p = OK tp -> + transf_hls p = OK tp -> match_prog p tp. Proof. intros p tp T. - unfold transf_frontend in T. simpl in T. + unfold transf_hls in T. simpl in T. destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. - rewrite ! compose_print_identity in T. destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. + unfold transf_backend in T. simpl in T. rewrite ! compose_print_identity in T. + destruct (Inlining.transf_program p6) as [p7|e] eqn:P7; simpl in T; try discriminate. + destruct (HTLgen.transl_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. + set (p9 := Veriloggen.transl_program p8) in *. unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. @@ -138,5 +141,99 @@ Proof. exists p4; split. apply Cminorgenproof.transf_program_match; auto. exists p5; split. apply Selectionproof.transf_program_match; auto. exists p6; split. apply RTLgenproof.transf_program_match; auto. - inversion T. reflexivity. + exists p7; split. apply Inliningproof.transf_program_match; auto. + exists p8; split. apply HTLgenproof.transf_program_match; auto. + exists p9; split. apply Veriloggenproof.transf_program_match; auto. + inv T. reflexivity. +Qed. + +Remark forward_simulation_identity: + forall sem, forward_simulation sem sem. +Proof. + intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. +- auto. +- exists s1; auto. +- subst s2; auto. +- subst s2. exists s1'; auto. +Qed. + +Theorem cstrategy_semantic_preservation: + forall p tp, + match_prog p tp -> + forward_simulation (Cstrategy.semantics p) (Verilog.semantics tp) + /\ backward_simulation (atomic (Cstrategy.semantics p)) (Verilog.semantics tp). +Proof. + intros p tp M. unfold match_prog, pass_match in M; simpl in M. +Ltac DestructM := + match goal with + [ H: exists p, _ /\ _ |- _ ] => + let p := fresh "p" in let M := fresh "M" in let MM := fresh "MM" in + destruct H as (p & M & MM); clear H + end. + repeat DestructM. subst tp. + assert (F: forward_simulation (Cstrategy.semantics p) (Verilog.semantics p9)). + { + eapply compose_forward_simulations. + eapply SimplExprproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply SimplLocalsproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Cshmgenproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Cminorgenproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Selectionproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply RTLgenproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Inliningproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply HTLgenproof.transf_program_correct. eassumption. + eapply Veriloggenproof.transf_program_correct; eassumption. + } + split. auto. + apply forward_to_backward_simulation. + apply factor_forward_simulation. auto. eapply sd_traces. eapply Verilog.semantics_determinate. + apply atomic_receptive. apply Cstrategy.semantics_strongly_receptive. + apply Verilog.semantics_determinate. +Qed. + +Theorem c_semantic_preservation: + forall p tp, + match_prog p tp -> + backward_simulation (Csem.semantics p) (Verilog.semantics tp). +Proof. + intros. + apply compose_backward_simulation with (atomic (Cstrategy.semantics p)). + eapply sd_traces; eapply Verilog.semantics_determinate. + apply factor_backward_simulation. + apply Cstrategy.strategy_simulation. + apply Csem.semantics_single_events. + eapply ssr_well_behaved; eapply Cstrategy.semantics_strongly_receptive. + exact (proj2 (cstrategy_semantic_preservation _ _ H)). +Qed. + +Theorem transf_c_program_correct: + forall p tp, + transf_hls p = OK tp -> + backward_simulation (Csem.semantics p) (Verilog.semantics tp). +Proof. + intros. apply c_semantic_preservation. apply transf_hls_match; auto. +Qed. + +Theorem separate_transf_c_program_correct: + forall c_units asm_units c_program, + nlist_forall2 (fun cu tcu => transf_hls cu = OK tcu) c_units asm_units -> + link_list c_units = Some c_program -> + exists asm_program, + link_list asm_units = Some asm_program + /\ backward_simulation (Csem.semantics c_program) (Verilog.semantics asm_program). +Proof. + intros. + assert (nlist_forall2 match_prog c_units asm_units). + { eapply nlist_forall2_imply. eauto. simpl; intros. apply transf_hls_match; auto. } + assert (exists asm_program, link_list asm_units = Some asm_program /\ match_prog c_program asm_program). + { eapply link_list_compose_passes; eauto. } + destruct H2 as (asm_program & P & Q). + exists asm_program; split; auto. apply c_semantic_preservation; auto. Qed. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 338e77d..2e91b99 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -17,7 +17,7 @@ *) From compcert Require RTL Registers AST. -From compcert Require Import Integers Globalenvs Memory. +From compcert Require Import Integers Globalenvs Memory Linking. From coqup Require Import Coquplib HTLgenspec HTLgen ValueInt AssocMap Array IntegerExtra ZExtra. From coqup Require HTL Verilog. @@ -124,11 +124,17 @@ Definition match_prog (p: RTL.program) (tp: HTL.program) := Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp /\ main_is_internal p = true. -Definition match_prog_matches : - forall p tp, - match_prog p tp -> - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. - Proof. intros. unfold match_prog in H. tauto. Qed. +Instance TransfHTLLink (tr_fun: RTL.program -> Errors.res HTL.program): + TransfLink (fun (p1: RTL.program) (p2: HTL.program) => match_prog p1 p2). +Proof. + Admitted. + +Definition match_prog' (p: RTL.program) (tp: HTL.program) := + Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. + +Lemma match_prog_matches : + forall p tp, match_prog p tp -> match_prog' p tp. +Proof. unfold match_prog. tauto. Qed. Lemma transf_program_match: forall p tp, HTLgen.transl_program p = Errors.OK tp -> match_prog p tp. @@ -368,6 +374,47 @@ Section CORRECTNESS. rewrite H. auto. Qed. + Lemma op_stack_based : + forall F V sp v m args rs op ge pc' res0 pc f e fin rtrn st stk, + tr_instr fin rtrn st stk (RTL.Iop op args res0 pc') + (Verilog.Vnonblock (Verilog.Vvar res0) e) + (state_goto st pc') -> + reg_stack_based_pointers sp rs -> + (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> + @Op.eval_operation F V ge (Values.Vptr sp Ptrofs.zero) op + (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> + stack_based v sp. + Proof. + Ltac solve_no_ptr := + match goal with + | H: reg_stack_based_pointers ?sp ?rs |- stack_based (Registers.Regmap.get ?r ?rs) _ => + solve [apply H] + | H1: reg_stack_based_pointers ?sp ?rs, H2: Registers.Regmap.get _ _ = Values.Vptr ?b ?i + |- context[Values.Vptr ?b _] => + let H := fresh "H" in + assert (H: stack_based (Values.Vptr b i) sp) by (rewrite <- H2; apply H1); simplify; solve [auto] + | |- context[Registers.Regmap.get ?lr ?lrs] => + destruct (Registers.Regmap.get lr lrs) eqn:?; simplify; auto + | |- stack_based (?f _) _ => unfold f + | |- stack_based (?f _ _) _ => unfold f + | |- stack_based (?f _ _ _) _ => unfold f + | |- stack_based (?f _ _ _ _) _ => unfold f + | H: ?f _ _ = Some _ |- _ => + unfold f in H; repeat (unfold_match H); inv H + | H: ?f _ _ _ _ _ _ = Some _ |- _ => + unfold f in H; repeat (unfold_match H); inv H + | H: map (fun r : positive => Registers.Regmap.get r _) ?args = _ |- _ => + destruct args; inv H + | |- context[if ?c then _ else _] => destruct c; try discriminate + | H: match _ with _ => _ end = Some _ |- _ => repeat (unfold_match H) + | |- context[match ?g with _ => _ end] => destruct g; try discriminate + | |- _ => simplify; solve [auto] + end. + intros F V sp v m args rs op g pc' res0 pc f e fin rtrn st stk INSTR RSBP SEL EVAL. + inv INSTR. unfold translate_instr in H5. + unfold_match H5; repeat (unfold_match H5); repeat (simplify; solve_no_ptr). + Qed. + Lemma eval_correct : forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> @@ -396,11 +443,11 @@ Section CORRECTNESS. apply H in HPle. apply H in HPle0. eexists. split. econstructor; eauto. constructor. trivial. constructor. trivial. simplify. inv HPle. inv HPle0; constructor; auto. - + inv HPle0. constructor. unfold valueToPtr. Search Integers.Ptrofs.sub Integers.int. - pose proof Integers.Ptrofs.agree32_sub. unfold Integers.Ptrofs.agree32 in H3. - Print Integers.Ptrofs.agree32. unfold Ptrofs.of_int. simpl. - apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H3 in H4. - rewrite Ptrofs.unsigned_repr. apply H4. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + + inv HPle0. constructor. unfold valueToPtr. + pose proof Integers.Ptrofs.agree32_sub. unfold Integers.Ptrofs.agree32 in H2. + unfold Ptrofs.of_int. simpl. + apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H2 in H3. + rewrite Ptrofs.unsigned_repr. apply H3. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. apply Int.unsigned_range_2. auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. @@ -532,7 +579,7 @@ Section CORRECTNESS. match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. Proof. intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. - inv_state. + inv_state. inv MARR. exploit eval_correct; eauto. intros. inversion H1. inversion H2. econstructor. split. apply Smallstep.plus_one. @@ -543,74 +590,32 @@ Section CORRECTNESS. constructor; trivial. econstructor; simpl; eauto. simpl. econstructor. econstructor. - apply H3. simplify. + apply H5. simplify. all: big_tac. - assert (Ple res0 (RTL.max_reg_function f)) + assert (HPle: Ple res0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in H10. lia. + unfold Ple in HPle. lia. apply regs_lessdef_add_match. assumption. apply regs_lessdef_add_greater. unfold Plt; lia. assumption. - assert (Ple res0 (RTL.max_reg_function f)) + assert (HPle: Ple res0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in H12; lia. - Admitted. -(* unfold_merge. simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - - (*match_states*) - assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. - rewrite <- H1. - constructor; auto. - unfold_merge. - apply regs_lessdef_add_match. - constructor. - apply regs_lessdef_add_greater. - apply greater_than_max_func. - assumption. - - unfold state_st_wf. intros. inversion H2. subst. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - - + econstructor. split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - econstructor; simpl; trivial. - constructor; trivial. - econstructor; simpl; eauto. - eapply eval_correct; eauto. - constructor. rewrite valueToInt_intToValue. trivial. - unfold_merge. simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - - match_states - assert (pc' = valueToPos (posToValue 32 pc')). auto using assumption_32bit. - rewrite <- H1. - constructor. - unfold_merge. - apply regs_lessdef_add_match. - constructor. - symmetry. apply valueToInt_intToValue. - apply regs_lessdef_add_greater. - apply greater_than_max_func. - assumption. assumption. - - unfold state_st_wf. intros. inversion H2. subst. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. - apply st_greater_than_res. - assumption. - Admitted.*) + unfold Ple in HPle; lia. + eapply op_stack_based; eauto. + inv CONST. constructor; simplify. rewrite AssocMap.gso. rewrite AssocMap.gso. + assumption. lia. + assert (HPle: Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + unfold Ple in HPle. lia. + rewrite AssocMap.gso. rewrite AssocMap.gso. + assumption. lia. + assert (HPle: Ple res0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_def; eauto; simpl; auto). + unfold Ple in HPle. lia. + Unshelve. trivial. + Qed. Hint Resolve transl_iop_correct : htlproof. Ltac tac := diff --git a/src/verilog/ValueInt.v b/src/verilog/ValueInt.v index aa99fbd..f0f6de6 100644 --- a/src/verilog/ValueInt.v +++ b/src/verilog/ValueInt.v @@ -81,9 +81,7 @@ Search Ptrofs.of_int Ptrofs.to_int. Definition valToValue (v : Values.val) : option value := match v with | Values.Vint i => Some (intToValue i) - | Values.Vptr b off => if Z.eqb (Z.modulo (uvalueToZ (ptrToValue off)) 4) 0%Z - then Some (ptrToValue off) - else None + | Values.Vptr b off => Some (ptrToValue off) | Values.Vundef => Some (ZToValue 0%Z) | _ => None end. @@ -117,7 +115,6 @@ Inductive val_value_lessdef: val -> value -> Prop := | val_value_lessdef_ptr: forall b off v', off = valueToPtr v' -> - (Z.modulo (uvalueToZ v') 4) = 0%Z -> val_value_lessdef (Vptr b off) v' | lessdef_undef: forall v, val_value_lessdef Vundef v. @@ -162,8 +159,5 @@ Proof. destruct v; try discriminate; constructor. unfold valToValue in H. inversion H. unfold valueToInt. unfold intToValue in H1. auto. - inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0); try discriminate. - inv H1. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial. - inv H. destruct (uvalueToZ (ptrToValue i) mod 4 =? 0) eqn:?; try discriminate. - inv H1. apply Z.eqb_eq. apply Heqb0. + inv H. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial. Qed. -- cgit From bfb722caf2d46867779222b45615481e9020f0aa Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 6 Jul 2020 23:28:28 +0100 Subject: Rename asm to verilog --- src/Compiler.v | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Compiler.v b/src/Compiler.v index 05353f9..db3a810 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -222,18 +222,19 @@ Proof. Qed. Theorem separate_transf_c_program_correct: - forall c_units asm_units c_program, - nlist_forall2 (fun cu tcu => transf_hls cu = OK tcu) c_units asm_units -> + forall c_units verilog_units c_program, + nlist_forall2 (fun cu tcu => transf_hls cu = OK tcu) c_units verilog_units -> link_list c_units = Some c_program -> - exists asm_program, - link_list asm_units = Some asm_program - /\ backward_simulation (Csem.semantics c_program) (Verilog.semantics asm_program). + exists verilog_program, + link_list verilog_units = Some verilog_program + /\ backward_simulation (Csem.semantics c_program) (Verilog.semantics verilog_program). Proof. intros. - assert (nlist_forall2 match_prog c_units asm_units). + assert (nlist_forall2 match_prog c_units verilog_units). { eapply nlist_forall2_imply. eauto. simpl; intros. apply transf_hls_match; auto. } - assert (exists asm_program, link_list asm_units = Some asm_program /\ match_prog c_program asm_program). + assert (exists verilog_program, link_list verilog_units = Some verilog_program + /\ match_prog c_program verilog_program). { eapply link_list_compose_passes; eauto. } - destruct H2 as (asm_program & P & Q). - exists asm_program; split; auto. apply c_semantic_preservation; auto. + destruct H2 as (verilog_program & P & Q). + exists verilog_program; split; auto. apply c_semantic_preservation; auto. Qed. -- cgit From aea11ef02422b8302779676a31adcf6dafbff0dd Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Tue, 7 Jul 2020 00:55:52 +0100 Subject: Proof of TransfHTLLink DONE --- src/translation/HTLgenproof.v | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 2e91b99..12a1a70 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -127,7 +127,20 @@ Definition match_prog (p: RTL.program) (tp: HTL.program) := Instance TransfHTLLink (tr_fun: RTL.program -> Errors.res HTL.program): TransfLink (fun (p1: RTL.program) (p2: HTL.program) => match_prog p1 p2). Proof. - Admitted. + red. intros. exfalso. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + apply link_prog_inv in H. + + unfold match_prog in *. + unfold main_is_internal in *. simplify. repeat (unfold_match H4). + repeat (unfold_match H3). simplify. + subst. rewrite H0 in *. specialize (H (AST.prog_main p2)). + exploit H. + apply Genv.find_def_symbol. exists b. split. + assumption. Search Genv.find_def. apply Genv.find_funct_ptr_iff. eassumption. + apply Genv.find_def_symbol. exists b0. split. + assumption. Search Genv.find_def. apply Genv.find_funct_ptr_iff. eassumption. + intros. inv H3. inv H5. destruct H6. inv H5. +Qed. Definition match_prog' (p: RTL.program) (tp: HTL.program) := Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. -- cgit From 45a955c6f2f238aeb4955ae4525efabcf822f31a Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Tue, 7 Jul 2020 03:09:49 +0100 Subject: A few operations left --- src/translation/HTLgenproof.v | 118 +++++++++++++++++++++++++++++++----------- 1 file changed, 88 insertions(+), 30 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 12a1a70..27eb9e5 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -136,9 +136,9 @@ Proof. subst. rewrite H0 in *. specialize (H (AST.prog_main p2)). exploit H. apply Genv.find_def_symbol. exists b. split. - assumption. Search Genv.find_def. apply Genv.find_funct_ptr_iff. eassumption. + assumption. apply Genv.find_funct_ptr_iff. eassumption. apply Genv.find_def_symbol. exists b0. split. - assumption. Search Genv.find_def. apply Genv.find_funct_ptr_iff. eassumption. + assumption. apply Genv.find_funct_ptr_iff. eassumption. intros. inv H3. inv H5. destruct H6. inv H5. Qed. @@ -428,6 +428,15 @@ Section CORRECTNESS. unfold_match H5; repeat (unfold_match H5); repeat (simplify; solve_no_ptr). Qed. + Lemma int_inj : + forall x y, + Int.unsigned x = Int.unsigned y -> + x = y. + Proof. + intros. rewrite <- Int.repr_unsigned at 1. rewrite <- Int.repr_unsigned. + rewrite <- H. trivial. + Qed. + Lemma eval_correct : forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> @@ -437,36 +446,85 @@ Section CORRECTNESS. translate_instr op args s = OK e s' i -> exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. Proof. + Ltac eval_correct_tac := + match goal with + | |- context[valueToPtr] => unfold valueToPtr + | |- context[valueToInt] => unfold valueToInt + | |- context[bop] => unfold bop + | |- context[boplit] => unfold boplit + | |- val_value_lessdef Values.Vundef _ => solve [constructor] + | H : val_value_lessdef _ _ |- val_value_lessdef (Values.Vint _) _ => constructor; inv H + | |- val_value_lessdef (Values.Vint _) _ => constructor; auto + | H : context[RTL.max_reg_function ?f] + |- context[_ (Registers.Regmap.get ?r ?rs) (Registers.Regmap.get ?r0 ?rs)] => + let HPle1 := fresh "HPle" in + let HPle2 := fresh "HPle" in + assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + assert (HPle2 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H in HPle1; apply H in HPle2; eexists; split; + [econstructor; eauto; constructor; trivial | inv HPle1; inv HPle2; try (constructor; auto)] + | H : context[RTL.max_reg_function ?f] + |- context[_ (Registers.Regmap.get ?r ?rs) _] => + let HPle1 := fresh "HPle" in + assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H in HPle1; eexists; split; + [econstructor; eauto; constructor; trivial | inv HPle1; try (constructor; auto)] + | H : _ :: _ = _ :: _ |- _ => inv H + | |- context[match ?d with _ => _ end] => destruct d eqn:?; try discriminate + | |- Verilog.expr_runp _ _ _ _ _ => econstructor + | |- val_value_lessdef (?f _ _) _ => unfold f + | |- val_value_lessdef (?f _) _ => unfold f + | H : ?f (Registers.Regmap.get _ _) _ = Some _ |- _ => + unfold f in H; repeat (unfold_match H) + | H1 : Registers.Regmap.get ?r ?rs = Values.Vint _, H2 : val_value_lessdef (Registers.Regmap.get ?r ?rs) _ + |- _ => rewrite H1 in H2; inv H2 + | |- _ => eexists; split; try constructor; solve [eauto] + | H : context[RTL.max_reg_function ?f] |- context[_ (Verilog.Vvar ?r) (Verilog.Vvar ?r0)] => + let HPle1 := fresh "H" in + let HPle2 := fresh "H" in + assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + assert (HPle2 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H in HPle1; apply H in HPle2; eexists; split; try constructor; eauto + | H : context[RTL.max_reg_function ?f] |- context[Verilog.Vvar ?r] => + let HPle := fresh "H" in + assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H in HPle; eexists; split; try constructor; eauto + | |- context[if ?c then _ else _] => destruct c eqn:?; try discriminate + end. intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; - unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); simplify. - - inv Heql. - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H in HPle. eexists. split; try constructor; eauto. - - eexists. split. constructor. constructor. auto. - - inv Heql. - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H in HPle. - eexists. split. econstructor; eauto. constructor. trivial. - unfold Verilog.unop_run. unfold Values.Val.neg. destruct (Registers.Regmap.get r rs) eqn:?; constructor. - inv HPle. auto. - - inv Heql. - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - assert (HPle0 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H in HPle. apply H in HPle0. - eexists. split. econstructor; eauto. constructor. trivial. - constructor. trivial. simplify. inv HPle. inv HPle0; constructor; auto. - + inv HPle0. constructor. unfold valueToPtr. - pose proof Integers.Ptrofs.agree32_sub. unfold Integers.Ptrofs.agree32 in H2. - unfold Ptrofs.of_int. simpl. - apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H2 in H3. - rewrite Ptrofs.unsigned_repr. apply H3. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. - auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. - replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. - Admitted. + unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL; + repeat (simplify; eval_correct_tac; unfold valueToInt in *). + - pose proof Integers.Ptrofs.agree32_sub as H2; unfold Integers.Ptrofs.agree32 in H2. + unfold Ptrofs.of_int. simpl. + apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H2 in H3. + rewrite Ptrofs.unsigned_repr. apply H3. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + apply Int.unsigned_range_2. + auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. + replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + apply Int.unsigned_range_2. + - pose proof Integers.Ptrofs.agree32_sub as AGR; unfold Integers.Ptrofs.agree32 in AGR. + assert (ARCH: Archi.ptr64 = false) by auto. eapply AGR in ARCH. + apply int_inj. unfold Ptrofs.to_int. rewrite Int.unsigned_repr. + apply ARCH. Search Ptrofs.unsigned. pose proof Ptrofs.unsigned_range_2. + replace Ptrofs.max_unsigned with Int.max_unsigned; auto. + pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. + eapply H2 in ARCH. apply ARCH. + pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. + eapply H2 in ARCH. apply ARCH. + - admit. + - admit. + - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. + - rewrite Heqb in Heqb0. discriminate. + - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. + - rewrite Heqb in Heqb0. discriminate. + - admit. + - admit. (* ror *) + - admit. (* addressing *) + - admit. (* eval_condition *) + - admit. (* select *) + Admitted. Lemma eval_cond_correct : forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, -- cgit From 855ca59a303efd32f1979f4e508edb4ddb43adac Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Tue, 7 Jul 2020 09:47:40 +0100 Subject: No admitted in Deterministic proof --- src/translation/HTLgenproof.v | 4 ++-- src/verilog/Value.v | 2 +- src/verilog/Verilog.v | 18 +++++++----------- 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 27eb9e5..51c0fa1 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -513,8 +513,8 @@ Section CORRECTNESS. eapply H2 in ARCH. apply ARCH. pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. eapply H2 in ARCH. apply ARCH. - - admit. - - admit. + - admit. (* mulhs *) + - admit. (* mulhu *) - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. - rewrite Heqb in Heqb0. discriminate. - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. diff --git a/src/verilog/Value.v b/src/verilog/Value.v index 2718a46..af2b822 100644 --- a/src/verilog/Value.v +++ b/src/verilog/Value.v @@ -468,7 +468,7 @@ Qed. Lemma ZToValue_eq : forall w1, - (mkvalue 32 w1) = (ZToValue 32 (wordToZ w1)). Admitted. + (mkvalue 32 w1) = (ZToValue 32 (wordToZ w1)). Abort. Lemma wordsize_32 : Int.wordsize = 32%nat. diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 9659189..78b057d 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -245,7 +245,7 @@ Definition program := AST.program fundef unit. Definition posToLit (p : positive) : expr := Vlit (posToValue p). -Definition fext := assocmap. +Definition fext := unit. Definition fextclk := nat -> fext. (** ** State @@ -345,10 +345,6 @@ Inductive expr_runp : fext -> assocmap -> assocmap_arr -> expr -> value -> Prop expr_runp fext reg stack iexp i -> arr_assocmap_lookup stack r (valueToNat i) = Some v -> expr_runp fext reg stack (Vvari r iexp) v - | erun_Vinputvar : - forall fext reg stack r v, - fext!r = Some v -> - expr_runp fext reg stack (Vinputvar r) v | erun_Vbinop : forall fext reg stack op l r lv rv resv, expr_runp fext reg stack l lv -> @@ -391,11 +387,11 @@ Definition handle_def {A : Type} (a : A) (val : option A) Local Open Scope error_monad_scope. -Definition access_fext (f : fext) (r : reg) : res value := +(*Definition access_fext (f : fext) (r : reg) : res value := match AssocMap.get r f with | Some v => OK v | _ => OK (ZToValue 0) - end. + end.*) (* TODO FIX Vvar case without default *) (*Fixpoint expr_run (assoc : assocmap) (e : expr) @@ -650,11 +646,11 @@ Fixpoint mi_run (f : fextclk) (assoc : assocmap) (m : list module_item) (n : nat assumed to be the starting state of the module, and may have to be changed if other arguments to the module are also to be supported. *) -Definition initial_fextclk (m : module) : fextclk := +(*Definition initial_fextclk (m : module) : fextclk := fun x => match x with | S O => (AssocMap.set (mod_reset m) (ZToValue 1) empty_assocmap) | _ => (AssocMap.set (mod_reset m) (ZToValue 0) empty_assocmap) - end. + end.*) (*Definition module_run (n : nat) (m : module) : res assocmap := mi_run (initial_fextclk m) empty_assocmap (mod_body m) n.*) @@ -886,11 +882,11 @@ Lemma semantics_determinate : Proof. intros. constructor; set (ge := Globalenvs.Genv.globalenv p); simplify. - invert H; invert H0; constructor. (* Traces are always empty *) - - invert H; invert H0; crush. assert (f = f0) by admit; subst. + - invert H; invert H0; crush. assert (f = f0) by (destruct f; destruct f0; auto); subst. pose proof (mis_stepp_determinate H5 H15). crush. - constructor. invert H; crush. - invert H; invert H0; unfold ge0, ge1 in *; crush. - red; simplify; intro; invert H0; invert H; crush. - invert H; invert H0; crush. -Admitted. +Qed. -- cgit From b3208d9a581e7575c41d545964f4f85c6f3b4d66 Mon Sep 17 00:00:00 2001 From: James Pollard Date: Tue, 7 Jul 2020 13:24:59 +0100 Subject: Get Coqup compiling again on dev-nadesh. --- src/Compiler.v | 4 +- src/translation/HTLgen.v | 4 +- src/translation/HTLgenproof.v | 3867 +++++++++++++++++++++-------------------- 3 files changed, 1938 insertions(+), 1937 deletions(-) diff --git a/src/Compiler.v b/src/Compiler.v index 26e2f1f..0a8617d 100644 --- a/src/Compiler.v +++ b/src/Compiler.v @@ -149,8 +149,8 @@ Proof. exists p7; split. apply Inliningproof.transf_program_match; auto. exists p8; split. apply HTLgenproof.transf_program_match; auto. exists p9; split. apply Veriloggenproof.transf_program_match; auto. - inv T. reflexivity. -Qed. + (* inv T. reflexivity. *) +Admitted. Remark forward_simulation_identity: forall sem, forward_simulation sem sem. diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index 32b6e04..babbc01 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -275,8 +275,8 @@ Definition translate_condition (c : Op.condition) (args : list reg) : mon expr : | Op.Ccompu c, _ => translate_comparison c args | Op.Ccompimm c i, _ => translate_comparison_imm c args i | Op.Ccompuimm c i, _ => translate_comparison_imm c args i - | Op.Cmaskzero n, r::nil => ret (Vbinop Veq (boplit Vand r n) (Vlit (ZToValue 32 0))) - | Op.Cmasknotzero n, r::nil => ret (Vbinop Vne (boplit Vand r n) (Vlit (ZToValue 32 0))) + | Op.Cmaskzero n, r::nil => ret (Vbinop Veq (boplit Vand r n) (Vlit (ZToValue 0))) + | Op.Cmasknotzero n, r::nil => ret (Vbinop Vne (boplit Vand r n) (Vlit (ZToValue 0))) | _, _ => error (Errors.msg "Htlgen: condition instruction not implemented: other") end. diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 51c0fa1..813a94b 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -342,1942 +342,1943 @@ Section CORRECTNESS. Hypothesis TRANSL : match_prog prog tprog. - Lemma TRANSL' : - Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog. - Proof. intros; apply match_prog_matches; assumption. Qed. - - Let ge : RTL.genv := Globalenvs.Genv.globalenv prog. - Let tge : HTL.genv := Globalenvs.Genv.globalenv tprog. - - Lemma symbols_preserved: - forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. - Proof. intros. eapply (Genv.find_symbol_match TRANSL'). Qed. - - Lemma function_ptr_translated: - forall (b: Values.block) (f: RTL.fundef), - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Errors.OK tf. - Proof. - intros. exploit (Genv.find_funct_ptr_match TRANSL'); eauto. - intros (cu & tf & P & Q & R); exists tf; auto. - Qed. - - Lemma functions_translated: - forall (v: Values.val) (f: RTL.fundef), - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transl_fundef f = Errors.OK tf. - Proof. - intros. exploit (Genv.find_funct_match TRANSL'); eauto. - intros (cu & tf & P & Q & R); exists tf; auto. - Qed. - - Lemma senv_preserved: - Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). - Proof - (Genv.senv_transf_partial TRANSL'). - Hint Resolve senv_preserved : htlproof. - - Lemma ptrofs_inj : - forall a b, - Ptrofs.unsigned a = Ptrofs.unsigned b -> a = b. - Proof. - intros. rewrite <- Ptrofs.repr_unsigned. symmetry. rewrite <- Ptrofs.repr_unsigned. - rewrite H. auto. - Qed. - - Lemma op_stack_based : - forall F V sp v m args rs op ge pc' res0 pc f e fin rtrn st stk, - tr_instr fin rtrn st stk (RTL.Iop op args res0 pc') - (Verilog.Vnonblock (Verilog.Vvar res0) e) - (state_goto st pc') -> - reg_stack_based_pointers sp rs -> - (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> - @Op.eval_operation F V ge (Values.Vptr sp Ptrofs.zero) op - (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> - stack_based v sp. - Proof. - Ltac solve_no_ptr := - match goal with - | H: reg_stack_based_pointers ?sp ?rs |- stack_based (Registers.Regmap.get ?r ?rs) _ => - solve [apply H] - | H1: reg_stack_based_pointers ?sp ?rs, H2: Registers.Regmap.get _ _ = Values.Vptr ?b ?i - |- context[Values.Vptr ?b _] => - let H := fresh "H" in - assert (H: stack_based (Values.Vptr b i) sp) by (rewrite <- H2; apply H1); simplify; solve [auto] - | |- context[Registers.Regmap.get ?lr ?lrs] => - destruct (Registers.Regmap.get lr lrs) eqn:?; simplify; auto - | |- stack_based (?f _) _ => unfold f - | |- stack_based (?f _ _) _ => unfold f - | |- stack_based (?f _ _ _) _ => unfold f - | |- stack_based (?f _ _ _ _) _ => unfold f - | H: ?f _ _ = Some _ |- _ => - unfold f in H; repeat (unfold_match H); inv H - | H: ?f _ _ _ _ _ _ = Some _ |- _ => - unfold f in H; repeat (unfold_match H); inv H - | H: map (fun r : positive => Registers.Regmap.get r _) ?args = _ |- _ => - destruct args; inv H - | |- context[if ?c then _ else _] => destruct c; try discriminate - | H: match _ with _ => _ end = Some _ |- _ => repeat (unfold_match H) - | |- context[match ?g with _ => _ end] => destruct g; try discriminate - | |- _ => simplify; solve [auto] - end. - intros F V sp v m args rs op g pc' res0 pc f e fin rtrn st stk INSTR RSBP SEL EVAL. - inv INSTR. unfold translate_instr in H5. - unfold_match H5; repeat (unfold_match H5); repeat (simplify; solve_no_ptr). - Qed. - - Lemma int_inj : - forall x y, - Int.unsigned x = Int.unsigned y -> - x = y. - Proof. - intros. rewrite <- Int.repr_unsigned at 1. rewrite <- Int.repr_unsigned. - rewrite <- H. trivial. - Qed. - - Lemma eval_correct : - forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, - match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> - (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> - Op.eval_operation ge sp op - (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> - translate_instr op args s = OK e s' i -> - exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. - Proof. - Ltac eval_correct_tac := - match goal with - | |- context[valueToPtr] => unfold valueToPtr - | |- context[valueToInt] => unfold valueToInt - | |- context[bop] => unfold bop - | |- context[boplit] => unfold boplit - | |- val_value_lessdef Values.Vundef _ => solve [constructor] - | H : val_value_lessdef _ _ |- val_value_lessdef (Values.Vint _) _ => constructor; inv H - | |- val_value_lessdef (Values.Vint _) _ => constructor; auto - | H : context[RTL.max_reg_function ?f] - |- context[_ (Registers.Regmap.get ?r ?rs) (Registers.Regmap.get ?r0 ?rs)] => - let HPle1 := fresh "HPle" in - let HPle2 := fresh "HPle" in - assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - assert (HPle2 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H in HPle1; apply H in HPle2; eexists; split; - [econstructor; eauto; constructor; trivial | inv HPle1; inv HPle2; try (constructor; auto)] - | H : context[RTL.max_reg_function ?f] - |- context[_ (Registers.Regmap.get ?r ?rs) _] => - let HPle1 := fresh "HPle" in - assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H in HPle1; eexists; split; - [econstructor; eauto; constructor; trivial | inv HPle1; try (constructor; auto)] - | H : _ :: _ = _ :: _ |- _ => inv H - | |- context[match ?d with _ => _ end] => destruct d eqn:?; try discriminate - | |- Verilog.expr_runp _ _ _ _ _ => econstructor - | |- val_value_lessdef (?f _ _) _ => unfold f - | |- val_value_lessdef (?f _) _ => unfold f - | H : ?f (Registers.Regmap.get _ _) _ = Some _ |- _ => - unfold f in H; repeat (unfold_match H) - | H1 : Registers.Regmap.get ?r ?rs = Values.Vint _, H2 : val_value_lessdef (Registers.Regmap.get ?r ?rs) _ - |- _ => rewrite H1 in H2; inv H2 - | |- _ => eexists; split; try constructor; solve [eauto] - | H : context[RTL.max_reg_function ?f] |- context[_ (Verilog.Vvar ?r) (Verilog.Vvar ?r0)] => - let HPle1 := fresh "H" in - let HPle2 := fresh "H" in - assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - assert (HPle2 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H in HPle1; apply H in HPle2; eexists; split; try constructor; eauto - | H : context[RTL.max_reg_function ?f] |- context[Verilog.Vvar ?r] => - let HPle := fresh "H" in - assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H in HPle; eexists; split; try constructor; eauto - | |- context[if ?c then _ else _] => destruct c eqn:?; try discriminate - end. - intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. - inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; - unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL; - repeat (simplify; eval_correct_tac; unfold valueToInt in *). - - pose proof Integers.Ptrofs.agree32_sub as H2; unfold Integers.Ptrofs.agree32 in H2. - unfold Ptrofs.of_int. simpl. - apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H2 in H3. - rewrite Ptrofs.unsigned_repr. apply H3. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. - auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. - replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - apply Int.unsigned_range_2. - - pose proof Integers.Ptrofs.agree32_sub as AGR; unfold Integers.Ptrofs.agree32 in AGR. - assert (ARCH: Archi.ptr64 = false) by auto. eapply AGR in ARCH. - apply int_inj. unfold Ptrofs.to_int. rewrite Int.unsigned_repr. - apply ARCH. Search Ptrofs.unsigned. pose proof Ptrofs.unsigned_range_2. - replace Ptrofs.max_unsigned with Int.max_unsigned; auto. - pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. - eapply H2 in ARCH. apply ARCH. - pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. - eapply H2 in ARCH. apply ARCH. - - admit. (* mulhs *) - - admit. (* mulhu *) - - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. - - rewrite Heqb in Heqb0. discriminate. - - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. - - rewrite Heqb in Heqb0. discriminate. - - admit. - - admit. (* ror *) - - admit. (* addressing *) - - admit. (* eval_condition *) - - admit. (* select *) - Admitted. - - Lemma eval_cond_correct : - forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, - translate_condition cond args s1 = OK c s' i -> - Op.eval_condition - cond - (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) - m = Some b -> - Verilog.expr_runp f asr asa c (boolToValue b). - Admitted. - - (** The proof of semantic preservation for the translation of instructions - is a simulation argument based on diagrams of the following form: -<< - match_states - code st rs ---------------- State m st assoc - || | - || | - || | - \/ v - code st rs' --------------- State m st assoc' - match_states ->> - where [tr_code c data control fin rtrn st] is assumed to hold. - - The precondition and postcondition is that that should hold is [match_assocmaps rs assoc]. - *) - - Definition transl_instr_prop (instr : RTL.instruction) : Prop := - forall m asr asa fin rtrn st stmt trans res, - tr_instr fin rtrn st (m.(HTL.mod_stk)) instr stmt trans -> - exists asr' asa', - HTL.step tge (HTL.State res m st asr asa) Events.E0 (HTL.State res m st asr' asa'). - - Opaque combine. - - Ltac tac0 := - match goal with - | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs - | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr - | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge - | [ |- context[reg_stack_based_pointers] ] => unfold reg_stack_based_pointers; intros - | [ |- context[Verilog.arr_assocmap_set _ _ _ _] ] => unfold Verilog.arr_assocmap_set - - | [ |- context[HTL.empty_stack] ] => unfold HTL.empty_stack - - | [ |- context[_ # ?d <- _ ! ?d] ] => rewrite AssocMap.gss - | [ |- context[_ # ?d <- _ ! ?s] ] => rewrite AssocMap.gso - | [ |- context[(AssocMap.empty _) ! _] ] => rewrite AssocMap.gempty - - | [ |- context[array_get_error _ (combine Verilog.merge_cell (arr_repeat None _) _)] ] => - rewrite combine_lookup_first - - | [ |- state_st_wf _ _ ] => unfold state_st_wf; inversion 1 - | [ |- context[match_states _ _] ] => econstructor; auto - | [ |- match_arrs _ _ _ _ _ ] => econstructor; auto - | [ |- match_assocmaps _ _ _ # _ <- (posToValue _) ] => - apply regs_lessdef_add_greater; [> unfold Plt; lia | assumption] - - | [ H : ?asa ! ?r = Some _ |- Verilog.arr_assocmap_lookup ?asa ?r _ = Some _ ] => - unfold Verilog.arr_assocmap_lookup; setoid_rewrite H; f_equal - | [ |- context[(AssocMap.combine _ _ _) ! _] ] => - try (rewrite AssocMap.gcombine; [> | reflexivity]) - - | [ |- context[Registers.Regmap.get ?d (Registers.Regmap.set ?d _ _)] ] => - rewrite Registers.Regmap.gss - | [ |- context[Registers.Regmap.get ?s (Registers.Regmap.set ?d _ _)] ] => - destruct (Pos.eq_dec s d) as [EQ|EQ]; - [> rewrite EQ | rewrite Registers.Regmap.gso; auto] - - | [ H : opt_val_value_lessdef _ _ |- _ ] => invert H - | [ H : context[Z.of_nat (Z.to_nat _)] |- _ ] => rewrite Z2Nat.id in H; [> solve crush |] - | [ H : _ ! _ = Some _ |- _] => setoid_rewrite H - end. - - Ltac small_tac := repeat (crush; try array; try ptrofs); crush; auto. - Ltac big_tac := repeat (crush; try array; try ptrofs; try tac0); crush; auto. - - Lemma transl_inop_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : RTL.regset) (m : mem) (pc' : RTL.node), - (RTL.fn_code f) ! pc = Some (RTL.Inop pc') -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. - Proof. - intros s f sp pc rs m pc' H R1 MSTATE. - inv_state. - - unfold match_prog in TRANSL. - econstructor. - split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. - (* processing of state *) - econstructor. - crush. - econstructor. - econstructor. - econstructor. - - all: invert MARR; big_tac. - - inv CONST; constructor; simplify; rewrite AssocMap.gso; auto; lia. - - Unshelve. auto. - Qed. - Hint Resolve transl_inop_correct : htlproof. - - Lemma transl_iop_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (op : Op.operation) (args : list Registers.reg) - (res0 : Registers.reg) (pc' : RTL.node) (v : Values.val), - (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> - Op.eval_operation ge sp op (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. - Proof. - intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. - inv_state. inv MARR. - exploit eval_correct; eauto. intros. inversion H1. inversion H2. - econstructor. split. - apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - inv CONST. assumption. - inv CONST. assumption. - econstructor; simpl; trivial. - constructor; trivial. - econstructor; simpl; eauto. - simpl. econstructor. econstructor. - apply H5. simplify. - - all: big_tac. - - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - - unfold Ple in HPle. lia. - apply regs_lessdef_add_match. assumption. - apply regs_lessdef_add_greater. unfold Plt; lia. assumption. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle; lia. - eapply op_stack_based; eauto. - inv CONST. constructor; simplify. rewrite AssocMap.gso. rewrite AssocMap.gso. - assumption. lia. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle. lia. - rewrite AssocMap.gso. rewrite AssocMap.gso. - assumption. lia. - assert (HPle: Ple res0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_def; eauto; simpl; auto). - unfold Ple in HPle. lia. - Unshelve. trivial. - Qed. - Hint Resolve transl_iop_correct : htlproof. - - Ltac tac := - repeat match goal with - | [ _ : error _ _ = OK _ _ _ |- _ ] => discriminate - | [ _ : context[if (?x && ?y) then _ else _] |- _ ] => - let EQ1 := fresh "EQ" in - let EQ2 := fresh "EQ" in - destruct x eqn:EQ1; destruct y eqn:EQ2; simpl in * - | [ _ : context[if ?x then _ else _] |- _ ] => - let EQ := fresh "EQ" in - destruct x eqn:EQ; simpl in * - | [ H : ret _ _ = _ |- _ ] => invert H - | [ _ : context[match ?x with | _ => _ end] |- _ ] => destruct x - end. - - Ltac inv_arr_access := - match goal with - | [ _ : translate_arr_access ?chunk ?addr ?args _ _ = OK ?c _ _ |- _] => - destruct c, chunk, addr, args; crush; tac; crush - end. - - Lemma transl_iload_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) - (addr : Op.addressing) (args : list Registers.reg) (dst : Registers.reg) - (pc' : RTL.node) (a v : Values.val), - (RTL.fn_code f) ! pc = Some (RTL.Iload chunk addr args dst pc') -> - Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> - Mem.loadv chunk m a = Some v -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc' (Registers.Regmap.set dst v rs) m) R2. - Proof. - intros s f sp pc rs m chunk addr args dst pc' a v H H0 H1 R1 MSTATE. - inv_state. inv_arr_access. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. - - rewrite ARCHI in H1. crush. - subst. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - apply H6 in HPler0. - invert HPler0; try congruence. - rewrite EQr0 in H8. - invert H8. - clear H0. clear H6. - - unfold check_address_parameter_signed in *; - unfold check_address_parameter_unsigned in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. - - (** Modular preservation proof *) - (*assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Read bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - rewrite <- EXPR_OK. - - specialize (H7 (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4)))). - exploit H7; big_tac. - - (** RSBP preservation *) - unfold arr_stack_based_pointers in ASBP. - specialize (ASBP (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). - exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - pose proof (RSBP r1) as RSBPr1. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; - destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. - - rewrite ARCHI in H1. crush. - subst. - clear RSBPr1. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - pose proof (H0 r1). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - assert (HPler1 : Ple r1 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H6 in HPler0. - apply H8 in HPler1. - invert HPler0; invert HPler1; try congruence. - rewrite EQr0 in H9. - rewrite EQr1 in H11. - invert H9. invert H11. - clear H0. clear H6. clear H8. - - unfold check_address_parameter_signed in *; - unfold check_address_parameter_unsigned in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int - (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) - (Integers.Int.repr z0)))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - apply IntExtra.add_mod; crush. - apply IntExtra.mul_mod2; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Read bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - rewrite <- EXPR_OK. - - specialize (H7 (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4)))). - exploit H7; big_tac. - - (** RSBP preservation *) - unfold arr_stack_based_pointers in ASBP. - specialize (ASBP (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). - exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption. - - + invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - rewrite ARCHI in H0. crush. - - unfold check_address_parameter_unsigned in *; - unfold check_address_parameter_signed in *; crush. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - rewrite ZERO in H1. clear ZERO. - rewrite Integers.Ptrofs.add_zero_l in H1. - - remember i0 as OFFSET. - - (** Modular preservation proof *) - rename H0 into MOD_PRESERVE. - - (** Read bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - rewrite <- EXPR_OK. - - specialize (H7 (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4)))). - exploit H7; big_tac. - - (** RSBP preservation *) - unfold arr_stack_based_pointers in ASBP. - specialize (ASBP (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). - exploit ASBP; big_tac. - rewrite NORMALISE in H0. rewrite H1 in H0. assumption.*) - Admitted. - Hint Resolve transl_iload_correct : htlproof. - - Lemma transl_istore_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) - (addr : Op.addressing) (args : list Registers.reg) (src : Registers.reg) - (pc' : RTL.node) (a : Values.val) (m' : mem), - (RTL.fn_code f) ! pc = Some (RTL.Istore chunk addr args src pc') -> - Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> - Mem.storev chunk m a (Registers.Regmap.get src rs) = Some m' -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m') R2. - Proof. -(* intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. - inv_state. inv_arr_access. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. - - rewrite ARCHI in H1. crush. - subst. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - apply H6 in HPler0. - invert HPler0; try congruence. - rewrite EQr0 in H8. - invert H8. - clear H0. clear H6. - - unfold check_address_parameter_unsigned in *; - unfold check_address_parameter_signed in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Write bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET - assert (Z.to_nat - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.divu - OFFSET - (Integers.Ptrofs.repr 4))) - = - valueToNat x) - as EXPR_OK by admit - end. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - inversion MASSOC; revert HeqOFFSET; subst; clear MASSOC; intros HeqOFFSET. - - econstructor. - repeat split; crush. - unfold HTL.empty_stack. - crush. - unfold Verilog.merge_arrs. - - rewrite AssocMap.gcombine. - 2: { reflexivity. } - unfold Verilog.arr_assocmap_set. - rewrite AssocMap.gss. - unfold Verilog.merge_arr. - rewrite AssocMap.gss. - setoid_rewrite H5. - reflexivity. - - rewrite combine_length. - rewrite <- array_set_len. - unfold arr_repeat. crush. - apply list_repeat_len. - - rewrite <- array_set_len. - unfold arr_repeat. crush. - rewrite list_repeat_len. - rewrite H4. reflexivity. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. - - destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). - - erewrite Mem.load_store_same. - 2: { rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite e. - rewrite Integers.Ptrofs.unsigned_repr. - exact H1. - apply Integers.Ptrofs.unsigned_range_2. } - constructor. - erewrite combine_lookup_second. - simpl. - assert (Ple src (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto); - apply H0 in H13. - destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H13; eauto. - - rewrite <- array_set_len. - unfold arr_repeat. crush. - rewrite list_repeat_len. auto. - - assert (4 * ptr / 4 = Integers.Ptrofs.unsigned OFFSET / 4) by (f_equal; assumption). - rewrite Z.mul_comm in H13. - rewrite Z_div_mult in H13; try lia. - replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H13 by reflexivity. - rewrite <- PtrofsExtra.divu_unsigned in H13; unfold_constants; try lia. - rewrite H13. rewrite EXPR_OK. - rewrite array_get_error_set_bound. - reflexivity. - unfold arr_length, arr_repeat. simpl. - rewrite list_repeat_len. lia. - - erewrite Mem.load_store_other with (m1 := m). - 2: { exact H1. } - 2: { right. - rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite Integers.Ptrofs.unsigned_repr. - simpl. - destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. - right. - apply ZExtra.mod_0_bounds; try lia. - apply ZLib.Z_mod_mult'. - rewrite Z2Nat.id in H15; try lia. - apply Zmult_lt_compat_r with (p := 4) in H15; try lia. - rewrite ZLib.div_mul_undo in H15; try lia. - split; try lia. - apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. - } - - rewrite <- EXPR_OK. - rewrite PtrofsExtra.divu_unsigned; auto; try (unfold_constants; lia). - destruct (ptr ==Z Integers.Ptrofs.unsigned OFFSET / 4). - apply Z.mul_cancel_r with (p := 4) in e; try lia. - rewrite ZLib.div_mul_undo in e; try lia. - rewrite combine_lookup_first. - eapply H7; eauto. - - rewrite <- array_set_len. - unfold arr_repeat. crush. - rewrite list_repeat_len. auto. - rewrite array_gso. - unfold array_get_error. - unfold arr_repeat. - crush. - apply list_repeat_lookup. - lia. - unfold_constants. - intro. - apply Z2Nat.inj_iff in H13; try lia. - apply Z.div_pos; try lia. - apply Integers.Ptrofs.unsigned_range. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - unfold arr_stack_based_pointers. - intros. - destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). - - crush. - erewrite Mem.load_store_same. - 2: { rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite e. - rewrite Integers.Ptrofs.unsigned_repr. - exact H1. - apply Integers.Ptrofs.unsigned_range_2. } - crush. - destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; try constructor. - destruct (Archi.ptr64); try discriminate. - pose proof (RSBP src). rewrite EQ_SRC in H0. - assumption. - - simpl. - erewrite Mem.load_store_other with (m1 := m). - 2: { exact H1. } - 2: { right. - rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite Integers.Ptrofs.unsigned_repr. - simpl. - destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. - right. - apply ZExtra.mod_0_bounds; try lia. - apply ZLib.Z_mod_mult'. - invert H0. - apply Zmult_lt_compat_r with (p := 4) in H14; try lia. - rewrite ZLib.div_mul_undo in H14; try lia. - split; try lia. - apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. - } - apply ASBP; assumption. - - unfold stack_bounds in *. intros. - simpl. - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - erewrite Mem.load_store_other with (m1 := m). - 2: { exact H1. } - 2: { right. right. simpl. - rewrite ZERO. - rewrite Integers.Ptrofs.add_zero_l. - rewrite Integers.Ptrofs.unsigned_repr; crush; try lia. - apply ZExtra.mod_0_bounds; crush; try lia. } - crush. - exploit (BOUNDS ptr); try lia. intros. crush. - exploit (BOUNDS ptr v); try lia. intros. - invert H0. - match goal with | |- ?x = _ => destruct x eqn:EQ end; try reflexivity. - assert (Mem.valid_access m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H0. - exact H0. eapply Mem.store_valid_access_3. eassumption. } - pose proof (Mem.valid_access_store m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence. - - + (** Preamble *) - invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - - unfold reg_stack_based_pointers in RSBP. - pose proof (RSBP r0) as RSBPr0. - pose proof (RSBP r1) as RSBPr1. - - destruct (Registers.Regmap.get r0 rs) eqn:EQr0; - destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. - - rewrite ARCHI in H1. crush. - subst. - clear RSBPr1. - - pose proof MASSOC as MASSOC'. - invert MASSOC'. - pose proof (H0 r0). - pose proof (H0 r1). - assert (HPler0 : Ple r0 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; crush; eauto). - assert (HPler1 : Ple r1 (RTL.max_reg_function f)) - by (eapply RTL.max_reg_function_use; eauto; simpl; auto). - apply H6 in HPler0. - apply H8 in HPler1. - invert HPler0; invert HPler1; try congruence. - rewrite EQr0 in H9. - rewrite EQr1 in H11. - invert H9. invert H11. - clear H0. clear H6. clear H8. - - unfold check_address_parameter_signed in *; - unfold check_address_parameter_unsigned in *; crush. - - remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) - (Integers.Ptrofs.of_int - (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) - (Integers.Int.repr z0)))) as OFFSET. - - (** Modular preservation proof *) - assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. - { rewrite HeqOFFSET. - apply PtrofsExtra.add_mod; crush; try lia. - rewrite Integers.Ptrofs.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - apply PtrofsExtra.of_int_mod. - apply IntExtra.add_mod; crush. - apply IntExtra.mul_mod2; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. - rewrite Integers.Int.unsigned_repr_eq. - rewrite <- Zmod_div_mod; crush. } - - (** Write bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. - assert (Mem.valid_access m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H0. - exact H0. eapply Mem.store_valid_access_3. eassumption. } - pose proof (Mem.valid_access_store m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence. - - + invert MARR. crush. - - unfold Op.eval_addressing in H0. - destruct (Archi.ptr64) eqn:ARCHI; crush. - rewrite ARCHI in H0. crush. - - unfold check_address_parameter_unsigned in *; - unfold check_address_parameter_signed in *; crush. - - assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. - rewrite ZERO in H1. clear ZERO. - rewrite Integers.Ptrofs.add_zero_l in H1. - - remember i0 as OFFSET. - - (** Modular preservation proof *) - rename H0 into MOD_PRESERVE. - - (** Write bounds proof *) - assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. - { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. - assert (Mem.valid_access m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) Writable). - { pose proof H1. eapply Mem.store_valid_access_2 in H0. - exact H0. eapply Mem.store_valid_access_3. eassumption. } - pose proof (Mem.valid_access_store m AST.Mint32 sp' - (Integers.Ptrofs.unsigned - (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) - (Integers.Ptrofs.repr ptr))) v). - apply X in H0. invert H0. congruence.*) - Admitted. - Hint Resolve transl_istore_correct : htlproof. - - Lemma transl_icond_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (cond : Op.condition) (args : list Registers.reg) - (ifso ifnot : RTL.node) (b : bool) (pc' : RTL.node), - (RTL.fn_code f) ! pc = Some (RTL.Icond cond args ifso ifnot) -> - Op.eval_condition cond (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some b -> - pc' = (if b then ifso else ifnot) -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. - Proof. - intros s f sp pc rs m cond args ifso ifnot b pc' H H0 H1 R1 MSTATE. - inv_state. - - eexists. split. apply Smallstep.plus_one. - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. -(* eapply Verilog.stmnt_runp_Vnonblock_reg with - (rhsval := if b then posToValue 32 ifso else posToValue 32 ifnot). - constructor. - - simpl. - destruct b. - eapply Verilog.erun_Vternary_true. - eapply eval_cond_correct; eauto. - constructor. - apply boolToValue_ValueToBool. - eapply Verilog.erun_Vternary_false. - eapply eval_cond_correct; eauto. - constructor. - apply boolToValue_ValueToBool. - constructor. - - big_tac. - - invert MARR. - destruct b; rewrite assumption_32bit; big_tac. - - Unshelve. - constructor. - Qed.*) - Admitted. - Hint Resolve transl_icond_correct : htlproof. - - Lemma transl_ijumptable_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) - (rs : Registers.Regmap.t Values.val) (m : mem) (arg : Registers.reg) (tbl : list RTL.node) - (n : Integers.Int.int) (pc' : RTL.node), - (RTL.fn_code f) ! pc = Some (RTL.Ijumptable arg tbl) -> - Registers.Regmap.get arg rs = Values.Vint n -> - list_nth_z tbl (Integers.Int.unsigned n) = Some pc' -> - forall R1 : HTL.state, - match_states (RTL.State s f sp pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. - Proof. - intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. - Admitted. - Hint Resolve transl_ijumptable_correct : htlproof. - - Lemma transl_ireturn_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) - (pc : positive) (rs : RTL.regset) (m : mem) (or : option Registers.reg) - (m' : mem), - (RTL.fn_code f) ! pc = Some (RTL.Ireturn or) -> - Mem.free m stk 0 (RTL.fn_stacksize f) = Some m' -> - forall R1 : HTL.state, - match_states (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) pc rs m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.Returnstate s (Registers.regmap_optget or Values.Vundef rs) m') R2. - Proof. - intros s f stk pc rs m or m' H H0 R1 MSTATE. - inv_state. - - - econstructor. split. - eapply Smallstep.plus_two. - - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. - constructor. - econstructor; simpl; trivial. - econstructor; simpl; trivial. - constructor. - econstructor; simpl; trivial. - constructor. - - constructor. constructor. - - unfold state_st_wf in WF; big_tac; eauto. - destruct wf as [HCTRL HDATA]. apply HCTRL. - apply AssocMapExt.elements_iff. eexists. - match goal with H: control ! pc = Some _ |- _ => apply H end. - - apply HTL.step_finish. - unfold Verilog.merge_regs. - unfold_merge; simpl. - rewrite AssocMap.gso. - apply AssocMap.gss. lia. - apply AssocMap.gss. - rewrite Events.E0_left. reflexivity. - - constructor; auto. - constructor. - - (* FIXME: Duplication *) - - econstructor. split. - eapply Smallstep.plus_two. - eapply HTL.step_module; eauto. - inv CONST; assumption. - inv CONST; assumption. - constructor. - econstructor; simpl; trivial. - econstructor; simpl; trivial. - constructor. constructor. constructor. - constructor. constructor. constructor. - - unfold state_st_wf in WF; big_tac; eauto. - - destruct wf as [HCTRL HDATA]. apply HCTRL. - apply AssocMapExt.elements_iff. eexists. - match goal with H: control ! pc = Some _ |- _ => apply H end. - - apply HTL.step_finish. - unfold Verilog.merge_regs. - unfold_merge. - rewrite AssocMap.gso. - apply AssocMap.gss. simpl; lia. - apply AssocMap.gss. - rewrite Events.E0_left. trivial. - - constructor; auto. - - simpl. inversion MASSOC. subst. - unfold find_assocmap, AssocMapExt.get_default. rewrite AssocMap.gso. - apply H1. eapply RTL.max_reg_function_use. eauto. simpl; tauto. - assert (HPle : Ple r (RTL.max_reg_function f)). - eapply RTL.max_reg_function_use. eassumption. simpl; auto. - apply ZExtra.Ple_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. - - Unshelve. - all: constructor. - Qed. - Hint Resolve transl_ireturn_correct : htlproof. - - Lemma transl_callstate_correct: - forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) - (m : mem) (m' : Mem.mem') (stk : Values.block), - Mem.alloc m 0 (RTL.fn_stacksize f) = (m', stk) -> - forall R1 : HTL.state, - match_states (RTL.Callstate s (AST.Internal f) args m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states - (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) (RTL.fn_entrypoint f) - (RTL.init_regs args (RTL.fn_params f)) m') R2. - Proof. - intros s f args m m' stk H R1 MSTATE. - - inversion MSTATE; subst. inversion TF; subst. - econstructor. split. apply Smallstep.plus_one. - eapply HTL.step_call. crush. - - apply match_state with (sp' := stk); eauto. - - all: big_tac. - - apply regs_lessdef_add_greater. unfold Plt; lia. - apply regs_lessdef_add_greater. unfold Plt; lia. - apply regs_lessdef_add_greater. unfold Plt; lia. - apply init_reg_assoc_empty. - - constructor. - - destruct (Mem.load AST.Mint32 m' stk - (Integers.Ptrofs.unsigned (Integers.Ptrofs.add - Integers.Ptrofs.zero - (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. - pose proof Mem.load_alloc_same as LOAD_ALLOC. - pose proof H as ALLOC. - eapply LOAD_ALLOC in ALLOC. - 2: { exact LOAD. } - ptrofs. rewrite LOAD. - rewrite ALLOC. - repeat constructor. - - ptrofs. rewrite LOAD. - repeat constructor. - - unfold reg_stack_based_pointers. intros. - unfold RTL.init_regs; crush. - destruct (RTL.fn_params f); - rewrite Registers.Regmap.gi; constructor. - - unfold arr_stack_based_pointers. intros. - crush. - destruct (Mem.load AST.Mint32 m' stk - (Integers.Ptrofs.unsigned (Integers.Ptrofs.add - Integers.Ptrofs.zero - (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. - pose proof Mem.load_alloc_same as LOAD_ALLOC. - pose proof H as ALLOC. - eapply LOAD_ALLOC in ALLOC. - 2: { exact LOAD. } - rewrite ALLOC. - repeat constructor. - constructor. - - Transparent Mem.alloc. (* TODO: Since there are opaque there's probably a lemma. *) - Transparent Mem.load. - Transparent Mem.store. - unfold stack_bounds. - split. - - unfold Mem.alloc in H. - invert H. - crush. - unfold Mem.load. - intros. - match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H4. - unfold Mem.perm in H4. crush. - unfold Mem.perm_order' in H4. - small_tac. - exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. - rewrite Maps.PMap.gss in H8. - match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. - crush. - apply proj_sumbool_true in H10. lia. - - unfold Mem.alloc in H. - invert H. - crush. - unfold Mem.store. - intros. - match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. - invert v0. unfold Mem.range_perm in H4. - unfold Mem.perm in H4. crush. - unfold Mem.perm_order' in H4. - small_tac. - exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. - rewrite Maps.PMap.gss in H8. - match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. - crush. - apply proj_sumbool_true in H10. lia. - constructor. simplify. rewrite AssocMap.gss. - simplify. rewrite AssocMap.gso. apply AssocMap.gss. simplify. lia. - Opaque Mem.alloc. - Opaque Mem.load. - Opaque Mem.store. - Qed. - Hint Resolve transl_callstate_correct : htlproof. - - Lemma transl_returnstate_correct: - forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) - (rs : RTL.regset) (s : list RTL.stackframe) (vres : Values.val) (m : mem) - (R1 : HTL.state), - match_states (RTL.Returnstate (RTL.Stackframe res0 f sp pc rs :: s) vres m) R1 -> - exists R2 : HTL.state, - Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ - match_states (RTL.State s f sp pc (Registers.Regmap.set res0 vres rs) m) R2. - Proof. - intros res0 f sp pc rs s vres m R1 MSTATE. - inversion MSTATE. inversion MF. - Qed. - Hint Resolve transl_returnstate_correct : htlproof. - - Lemma option_inv : - forall A x y, - @Some A x = Some y -> x = y. - Proof. intros. inversion H. trivial. Qed. - - Lemma main_tprog_internal : - forall b, - Globalenvs.Genv.find_symbol tge tprog.(AST.prog_main) = Some b -> - exists f, Genv.find_funct_ptr (Genv.globalenv tprog) b = Some (AST.Internal f). - Proof. - intros. - destruct TRANSL. unfold main_is_internal in H1. - repeat (unfold_match H1). replace b with b0. - exploit function_ptr_translated; eauto. intros [tf [A B]]. - unfold transl_fundef, AST.transf_partial_fundef, Errors.bind in B. - unfold_match B. inv B. econstructor. apply A. - - apply option_inv. rewrite <- Heqo. rewrite <- H. - rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - trivial. symmetry; eapply Linking.match_program_main; eauto. - Qed. - - Lemma transl_initial_states : - forall s1 : Smallstep.state (RTL.semantics prog), - Smallstep.initial_state (RTL.semantics prog) s1 -> - exists s2 : Smallstep.state (HTL.semantics tprog), - Smallstep.initial_state (HTL.semantics tprog) s2 /\ match_states s1 s2. - Proof. - induction 1. - destruct TRANSL. unfold main_is_internal in H4. - repeat (unfold_match H4). - assert (f = AST.Internal f1). apply option_inv. - rewrite <- Heqo0. rewrite <- H1. replace b with b0. - auto. apply option_inv. rewrite <- H0. rewrite <- Heqo. - trivial. - exploit function_ptr_translated; eauto. - intros [tf [A B]]. - unfold transl_fundef, Errors.bind in B. - unfold AST.transf_partial_fundef, Errors.bind in B. - repeat (unfold_match B). inversion B. subst. - exploit main_tprog_internal; eauto; intros. - rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). - apply Heqo. symmetry; eapply Linking.match_program_main; eauto. - inversion H5. - econstructor; split. econstructor. - apply (Genv.init_mem_transf_partial TRANSL'); eauto. - replace (AST.prog_main tprog) with (AST.prog_main prog). - rewrite symbols_preserved; eauto. - symmetry; eapply Linking.match_program_main; eauto. - apply H6. - - constructor. - apply transl_module_correct. - assert (Some (AST.Internal x) = Some (AST.Internal m)). - replace (AST.fundef HTL.module) with (HTL.fundef). - rewrite <- H6. setoid_rewrite <- A. trivial. - trivial. inv H7. assumption. - Qed. - Hint Resolve transl_initial_states : htlproof. - - Lemma transl_final_states : - forall (s1 : Smallstep.state (RTL.semantics prog)) - (s2 : Smallstep.state (HTL.semantics tprog)) - (r : Integers.Int.int), - match_states s1 s2 -> - Smallstep.final_state (RTL.semantics prog) s1 r -> - Smallstep.final_state (HTL.semantics tprog) s2 r. - Proof. - intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. - Qed. - Hint Resolve transl_final_states : htlproof. - - Theorem transl_step_correct: - forall (S1 : RTL.state) t S2, - RTL.step ge S1 t S2 -> - forall (R1 : HTL.state), - match_states S1 R1 -> - exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states S2 R2. - Proof. - induction 1; eauto with htlproof; (intros; inv_state). - Qed. - Hint Resolve transl_step_correct : htlproof. +(* Lemma TRANSL' : *) +(* Linking.match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq prog tprog. *) +(* Proof. intros; apply match_prog_matches; assumption. Qed. *) + +(* Let ge : RTL.genv := Globalenvs.Genv.globalenv prog. *) +(* Let tge : HTL.genv := Globalenvs.Genv.globalenv tprog. *) + +(* Lemma symbols_preserved: *) +(* forall (s: AST.ident), Genv.find_symbol tge s = Genv.find_symbol ge s. *) +(* Proof. intros. eapply (Genv.find_symbol_match TRANSL'). Qed. *) + +(* Lemma function_ptr_translated: *) +(* forall (b: Values.block) (f: RTL.fundef), *) +(* Genv.find_funct_ptr ge b = Some f -> *) +(* exists tf, *) +(* Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Errors.OK tf. *) +(* Proof. *) +(* intros. exploit (Genv.find_funct_ptr_match TRANSL'); eauto. *) +(* intros (cu & tf & P & Q & R); exists tf; auto. *) +(* Qed. *) + +(* Lemma functions_translated: *) +(* forall (v: Values.val) (f: RTL.fundef), *) +(* Genv.find_funct ge v = Some f -> *) +(* exists tf, *) +(* Genv.find_funct tge v = Some tf /\ transl_fundef f = Errors.OK tf. *) +(* Proof. *) +(* intros. exploit (Genv.find_funct_match TRANSL'); eauto. *) +(* intros (cu & tf & P & Q & R); exists tf; auto. *) +(* Qed. *) + +(* Lemma senv_preserved: *) +(* Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). *) +(* Proof *) +(* (Genv.senv_transf_partial TRANSL'). *) +(* Hint Resolve senv_preserved : htlproof. *) + +(* Lemma ptrofs_inj : *) +(* forall a b, *) +(* Ptrofs.unsigned a = Ptrofs.unsigned b -> a = b. *) +(* Proof. *) +(* intros. rewrite <- Ptrofs.repr_unsigned. symmetry. rewrite <- Ptrofs.repr_unsigned. *) +(* rewrite H. auto. *) +(* Qed. *) + +(* Lemma op_stack_based : *) +(* forall F V sp v m args rs op ge pc' res0 pc f e fin rtrn st stk, *) +(* tr_instr fin rtrn st stk (RTL.Iop op args res0 pc') *) +(* (Verilog.Vnonblock (Verilog.Vvar res0) e) *) +(* (state_goto st pc') -> *) +(* reg_stack_based_pointers sp rs -> *) +(* (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> *) +(* @Op.eval_operation F V ge (Values.Vptr sp Ptrofs.zero) op *) +(* (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> *) +(* stack_based v sp. *) +(* Proof. *) +(* Ltac solve_no_ptr := *) +(* match goal with *) +(* | H: reg_stack_based_pointers ?sp ?rs |- stack_based (Registers.Regmap.get ?r ?rs) _ => *) +(* solve [apply H] *) +(* | H1: reg_stack_based_pointers ?sp ?rs, H2: Registers.Regmap.get _ _ = Values.Vptr ?b ?i *) +(* |- context[Values.Vptr ?b _] => *) +(* let H := fresh "H" in *) +(* assert (H: stack_based (Values.Vptr b i) sp) by (rewrite <- H2; apply H1); simplify; solve [auto] *) +(* | |- context[Registers.Regmap.get ?lr ?lrs] => *) +(* destruct (Registers.Regmap.get lr lrs) eqn:?; simplify; auto *) +(* | |- stack_based (?f _) _ => unfold f *) +(* | |- stack_based (?f _ _) _ => unfold f *) +(* | |- stack_based (?f _ _ _) _ => unfold f *) +(* | |- stack_based (?f _ _ _ _) _ => unfold f *) +(* | H: ?f _ _ = Some _ |- _ => *) +(* unfold f in H; repeat (unfold_match H); inv H *) +(* | H: ?f _ _ _ _ _ _ = Some _ |- _ => *) +(* unfold f in H; repeat (unfold_match H); inv H *) +(* | H: map (fun r : positive => Registers.Regmap.get r _) ?args = _ |- _ => *) +(* destruct args; inv H *) +(* | |- context[if ?c then _ else _] => destruct c; try discriminate *) +(* | H: match _ with _ => _ end = Some _ |- _ => repeat (unfold_match H) *) +(* | |- context[match ?g with _ => _ end] => destruct g; try discriminate *) +(* | |- _ => simplify; solve [auto] *) +(* end. *) +(* intros F V sp v m args rs op g pc' res0 pc f e fin rtrn st stk INSTR RSBP SEL EVAL. *) +(* inv INSTR. unfold translate_instr in H5. *) +(* unfold_match H5; repeat (unfold_match H5); repeat (simplify; solve_no_ptr). *) +(* Qed. *) + +(* Lemma int_inj : *) +(* forall x y, *) +(* Int.unsigned x = Int.unsigned y -> *) +(* x = y. *) +(* Proof. *) +(* intros. rewrite <- Int.repr_unsigned at 1. rewrite <- Int.repr_unsigned. *) +(* rewrite <- H. trivial. *) +(* Qed. *) + +(* Lemma eval_correct : *) +(* forall s sp op rs m v e asr asa f f' stk s' i pc res0 pc' args res ml st, *) +(* match_states (RTL.State stk f sp pc rs m) (HTL.State res ml st asr asa) -> *) +(* (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> *) +(* Op.eval_operation ge sp op *) +(* (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) m = Some v -> *) +(* translate_instr op args s = OK e s' i -> *) +(* exists v', Verilog.expr_runp f' asr asa e v' /\ val_value_lessdef v v'. *) +(* Proof. *) +(* Ltac eval_correct_tac := *) +(* match goal with *) +(* | |- context[valueToPtr] => unfold valueToPtr *) +(* | |- context[valueToInt] => unfold valueToInt *) +(* | |- context[bop] => unfold bop *) +(* | |- context[boplit] => unfold boplit *) +(* | |- val_value_lessdef Values.Vundef _ => solve [constructor] *) +(* | H : val_value_lessdef _ _ |- val_value_lessdef (Values.Vint _) _ => constructor; inv H *) +(* | |- val_value_lessdef (Values.Vint _) _ => constructor; auto *) +(* | H : context[RTL.max_reg_function ?f] *) +(* |- context[_ (Registers.Regmap.get ?r ?rs) (Registers.Regmap.get ?r0 ?rs)] => *) +(* let HPle1 := fresh "HPle" in *) +(* let HPle2 := fresh "HPle" in *) +(* assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* assert (HPle2 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* apply H in HPle1; apply H in HPle2; eexists; split; *) +(* [econstructor; eauto; constructor; trivial | inv HPle1; inv HPle2; try (constructor; auto)] *) +(* | H : context[RTL.max_reg_function ?f] *) +(* |- context[_ (Registers.Regmap.get ?r ?rs) _] => *) +(* let HPle1 := fresh "HPle" in *) +(* assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* apply H in HPle1; eexists; split; *) +(* [econstructor; eauto; constructor; trivial | inv HPle1; try (constructor; auto)] *) +(* | H : _ :: _ = _ :: _ |- _ => inv H *) +(* | |- context[match ?d with _ => _ end] => destruct d eqn:?; try discriminate *) +(* | |- Verilog.expr_runp _ _ _ _ _ => econstructor *) +(* | |- val_value_lessdef (?f _ _) _ => unfold f *) +(* | |- val_value_lessdef (?f _) _ => unfold f *) +(* | H : ?f (Registers.Regmap.get _ _) _ = Some _ |- _ => *) +(* unfold f in H; repeat (unfold_match H) *) +(* | H1 : Registers.Regmap.get ?r ?rs = Values.Vint _, H2 : val_value_lessdef (Registers.Regmap.get ?r ?rs) _ *) +(* |- _ => rewrite H1 in H2; inv H2 *) +(* | |- _ => eexists; split; try constructor; solve [eauto] *) +(* | H : context[RTL.max_reg_function ?f] |- context[_ (Verilog.Vvar ?r) (Verilog.Vvar ?r0)] => *) +(* let HPle1 := fresh "H" in *) +(* let HPle2 := fresh "H" in *) +(* assert (HPle1 : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* assert (HPle2 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* apply H in HPle1; apply H in HPle2; eexists; split; try constructor; eauto *) +(* | H : context[RTL.max_reg_function ?f] |- context[Verilog.Vvar ?r] => *) +(* let HPle := fresh "H" in *) +(* assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* apply H in HPle; eexists; split; try constructor; eauto *) +(* | |- context[if ?c then _ else _] => destruct c eqn:?; try discriminate *) +(* end. *) +(* intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. *) +(* inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; *) +(* unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL; *) +(* repeat (simplify; eval_correct_tac; unfold valueToInt in *) +(* - pose proof Integers.Ptrofs.agree32_sub as H2; unfold Integers.Ptrofs.agree32 in H2. *) +(* unfold Ptrofs.of_int. simpl. *) +(* apply ptrofs_inj. assert (Archi.ptr64 = false) by auto. eapply H2 in H3. *) +(* rewrite Ptrofs.unsigned_repr. apply H3. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* apply Int.unsigned_range_2. *) +(* auto. rewrite Ptrofs.unsigned_repr. replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* apply Int.unsigned_range_2. rewrite Ptrofs.unsigned_repr. auto. *) +(* replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* apply Int.unsigned_range_2. *) +(* - pose proof Integers.Ptrofs.agree32_sub as AGR; unfold Integers.Ptrofs.agree32 in AGR. *) +(* assert (ARCH: Archi.ptr64 = false) by auto. eapply AGR in ARCH. *) +(* apply int_inj. unfold Ptrofs.to_int. rewrite Int.unsigned_repr. *) +(* apply ARCH. Search Ptrofs.unsigned. pose proof Ptrofs.unsigned_range_2. *) +(* replace Ptrofs.max_unsigned with Int.max_unsigned; auto. *) +(* pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. *) +(* eapply H2 in ARCH. apply ARCH. *) +(* pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. *) +(* eapply H2 in ARCH. apply ARCH. *) +(* - admit. (* mulhs *) *) +(* - admit. (* mulhu *) *) +(* - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. *) +(* - rewrite Heqb in Heqb0. discriminate. *) +(* - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. *) +(* - rewrite Heqb in Heqb0. discriminate. *) +(* - admit. *) +(* - admit. (* ror *) *) +(* - admit. (* addressing *) *) +(* - admit. (* eval_condition *) *) +(* - admit. (* select *) *) +(* Admitted. *) + +(* Lemma eval_cond_correct : *) +(* forall cond (args : list Registers.reg) s1 c s' i rs args m b f asr asa, *) +(* translate_condition cond args s1 = OK c s' i -> *) +(* Op.eval_condition *) +(* cond *) +(* (List.map (fun r : BinNums.positive => Registers.Regmap.get r rs) args) *) +(* m = Some b -> *) +(* Verilog.expr_runp f asr asa c (boolToValue b). *) +(* Admitted. *) + +(* (** The proof of semantic preservation for the translation of instructions *) +(* is a simulation argument based on diagrams of the following form: *) +(* << *) +(* match_states *) +(* code st rs ---------------- State m st assoc *) +(* || | *) +(* || | *) +(* || | *) +(* \/ v *) +(* code st rs' --------------- State m st assoc' *) +(* match_states *) +(* >> *) +(* where [tr_code c data control fin rtrn st] is assumed to hold. *) + +(* The precondition and postcondition is that that should hold is [match_assocmaps rs assoc]. *) +(* *) *) + +(* Definition transl_instr_prop (instr : RTL.instruction) : Prop := *) +(* forall m asr asa fin rtrn st stmt trans res, *) +(* tr_instr fin rtrn st (m.(HTL.mod_stk)) instr stmt trans -> *) +(* exists asr' asa', *) +(* HTL.step tge (HTL.State res m st asr asa) Events.E0 (HTL.State res m st asr' asa'). *) + +(* Opaque combine. *) + +(* Ltac tac0 := *) +(* match goal with *) +(* | [ |- context[Verilog.merge_arrs _ _] ] => unfold Verilog.merge_arrs *) +(* | [ |- context[Verilog.merge_arr] ] => unfold Verilog.merge_arr *) +(* | [ |- context[Verilog.merge_regs _ _] ] => unfold Verilog.merge_regs; crush; unfold_merge *) +(* | [ |- context[reg_stack_based_pointers] ] => unfold reg_stack_based_pointers; intros *) +(* | [ |- context[Verilog.arr_assocmap_set _ _ _ _] ] => unfold Verilog.arr_assocmap_set *) + +(* | [ |- context[HTL.empty_stack] ] => unfold HTL.empty_stack *) + +(* | [ |- context[_ # ?d <- _ ! ?d] ] => rewrite AssocMap.gss *) +(* | [ |- context[_ # ?d <- _ ! ?s] ] => rewrite AssocMap.gso *) +(* | [ |- context[(AssocMap.empty _) ! _] ] => rewrite AssocMap.gempty *) + +(* | [ |- context[array_get_error _ (combine Verilog.merge_cell (arr_repeat None _) _)] ] => *) +(* rewrite combine_lookup_first *) + +(* | [ |- state_st_wf _ _ ] => unfold state_st_wf; inversion 1 *) +(* | [ |- context[match_states _ _] ] => econstructor; auto *) +(* | [ |- match_arrs _ _ _ _ _ ] => econstructor; auto *) +(* | [ |- match_assocmaps _ _ _ # _ <- (posToValue _) ] => *) +(* apply regs_lessdef_add_greater; [> unfold Plt; lia | assumption] *) + +(* | [ H : ?asa ! ?r = Some _ |- Verilog.arr_assocmap_lookup ?asa ?r _ = Some _ ] => *) +(* unfold Verilog.arr_assocmap_lookup; setoid_rewrite H; f_equal *) +(* | [ |- context[(AssocMap.combine _ _ _) ! _] ] => *) +(* try (rewrite AssocMap.gcombine; [> | reflexivity]) *) + +(* | [ |- context[Registers.Regmap.get ?d (Registers.Regmap.set ?d _ _)] ] => *) +(* rewrite Registers.Regmap.gss *) +(* | [ |- context[Registers.Regmap.get ?s (Registers.Regmap.set ?d _ _)] ] => *) +(* destruct (Pos.eq_dec s d) as [EQ|EQ]; *) +(* [> rewrite EQ | rewrite Registers.Regmap.gso; auto] *) + +(* | [ H : opt_val_value_lessdef _ _ |- _ ] => invert H *) +(* | [ H : context[Z.of_nat (Z.to_nat _)] |- _ ] => rewrite Z2Nat.id in H; [> solve crush |] *) +(* | [ H : _ ! _ = Some _ |- _] => setoid_rewrite H *) +(* end. *) + +(* Ltac small_tac := repeat (crush; try array; try ptrofs); crush; auto. *) +(* Ltac big_tac := repeat (crush; try array; try ptrofs; try tac0); crush; auto. *) + +(* Lemma transl_inop_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) +(* (rs : RTL.regset) (m : mem) (pc' : RTL.node), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Inop pc') -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f sp pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. *) +(* Proof. *) +(* intros s f sp pc rs m pc' H R1 MSTATE. *) +(* inv_state. *) + +(* unfold match_prog in TRANSL. *) +(* econstructor. *) +(* split. *) +(* apply Smallstep.plus_one. *) +(* eapply HTL.step_module; eauto. *) +(* inv CONST; assumption. *) +(* inv CONST; assumption. *) +(* (* processing of state *) *) +(* econstructor. *) +(* crush. *) +(* econstructor. *) +(* econstructor. *) +(* econstructor. *) + +(* all: invert MARR; big_tac. *) + +(* inv CONST; constructor; simplify; rewrite AssocMap.gso; auto; lia. *) + +(* Unshelve. auto. *) +(* Qed. *) +(* Hint Resolve transl_inop_correct : htlproof. *) + +(* Lemma transl_iop_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) +(* (rs : Registers.Regmap.t Values.val) (m : mem) (op : Op.operation) (args : list Registers.reg) *) +(* (res0 : Registers.reg) (pc' : RTL.node) (v : Values.val), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Iop op args res0 pc') -> *) +(* Op.eval_operation ge sp op (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some v -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f sp pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) +(* match_states (RTL.State s f sp pc' (Registers.Regmap.set res0 v rs) m) R2. *) +(* Proof. *) +(* intros s f sp pc rs m op args res0 pc' v H H0 R1 MSTATE. *) +(* inv_state. inv MARR. *) +(* exploit eval_correct; eauto. intros. inversion H1. inversion H2. *) +(* econstructor. split. *) +(* apply Smallstep.plus_one. *) +(* eapply HTL.step_module; eauto. *) +(* inv CONST. assumption. *) +(* inv CONST. assumption. *) +(* econstructor; simpl; trivial. *) +(* constructor; trivial. *) +(* econstructor; simpl; eauto. *) +(* simpl. econstructor. econstructor. *) +(* apply H5. simplify. *) + +(* all: big_tac. *) + +(* assert (HPle: Ple res0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_def; eauto; simpl; auto). *) + +(* unfold Ple in HPle. lia. *) +(* apply regs_lessdef_add_match. assumption. *) +(* apply regs_lessdef_add_greater. unfold Plt; lia. assumption. *) +(* assert (HPle: Ple res0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_def; eauto; simpl; auto). *) +(* unfold Ple in HPle; lia. *) +(* eapply op_stack_based; eauto. *) +(* inv CONST. constructor; simplify. rewrite AssocMap.gso. rewrite AssocMap.gso. *) +(* assumption. lia. *) +(* assert (HPle: Ple res0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_def; eauto; simpl; auto). *) +(* unfold Ple in HPle. lia. *) +(* rewrite AssocMap.gso. rewrite AssocMap.gso. *) +(* assumption. lia. *) +(* assert (HPle: Ple res0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_def; eauto; simpl; auto). *) +(* unfold Ple in HPle. lia. *) +(* Unshelve. trivial. *) +(* Qed. *) +(* Hint Resolve transl_iop_correct : htlproof. *) + +(* Ltac tac := *) +(* repeat match goal with *) +(* | [ _ : error _ _ = OK _ _ _ |- _ ] => discriminate *) +(* | [ _ : context[if (?x && ?y) then _ else _] |- _ ] => *) +(* let EQ1 := fresh "EQ" in *) +(* let EQ2 := fresh "EQ" in *) +(* destruct x eqn:EQ1; destruct y eqn:EQ2; simpl in * *) +(* | [ _ : context[if ?x then _ else _] |- _ ] => *) +(* let EQ := fresh "EQ" in *) +(* destruct x eqn:EQ; simpl in * *) +(* | [ H : ret _ _ = _ |- _ ] => invert H *) +(* | [ _ : context[match ?x with | _ => _ end] |- _ ] => destruct x *) +(* end. *) + +(* Ltac inv_arr_access := *) +(* match goal with *) +(* | [ _ : translate_arr_access ?chunk ?addr ?args _ _ = OK ?c _ _ |- _] => *) +(* destruct c, chunk, addr, args; crush; tac; crush *) +(* end. *) + +(* Lemma transl_iload_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) +(* (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) *) +(* (addr : Op.addressing) (args : list Registers.reg) (dst : Registers.reg) *) +(* (pc' : RTL.node) (a v : Values.val), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Iload chunk addr args dst pc') -> *) +(* Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> *) +(* Mem.loadv chunk m a = Some v -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f sp pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) +(* match_states (RTL.State s f sp pc' (Registers.Regmap.set dst v rs) m) R2. *) +(* Proof. *) +(* intros s f sp pc rs m chunk addr args dst pc' a v H H0 H1 R1 MSTATE. *) +(* inv_state. inv_arr_access. *) + +(* + (** Preamble *) *) +(* invert MARR. crush. *) + +(* unfold Op.eval_addressing in H0. *) +(* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + +(* unfold reg_stack_based_pointers in RSBP. *) +(* pose proof (RSBP r0) as RSBPr0. *) + +(* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. *) + +(* rewrite ARCHI in H1. crush. *) +(* subst. *) + +(* pose proof MASSOC as MASSOC'. *) +(* invert MASSOC'. *) +(* pose proof (H0 r0). *) +(* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) +(* apply H6 in HPler0. *) +(* invert HPler0; try congruence. *) +(* rewrite EQr0 in H8. *) +(* invert H8. *) +(* clear H0. clear H6. *) + +(* unfold check_address_parameter_signed in *; *) +(* unfold check_address_parameter_unsigned in *; crush. *) + +(* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) +(* (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. *) + +(* (** Modular preservation proof *) *) +(* (*assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) +(* { rewrite HeqOFFSET. *) +(* apply PtrofsExtra.add_mod; crush. *) +(* rewrite Integers.Ptrofs.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. *) +(* apply PtrofsExtra.of_int_mod. *) +(* rewrite Integers.Int.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. } *) + +(* (** Read bounds proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. *) +(* { destruct (Integers.Ptrofs.unsigned OFFSET *) +(* assert (Z.to_nat *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4))) *) +(* = *) +(* valueToNat x) *) +(* as EXPR_OK by admit *) +(* end. *) +(* rewrite <- EXPR_OK. *) + +(* specialize (H7 (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4)))). *) +(* exploit H7; big_tac. *) + +(* (** RSBP preservation *) *) +(* unfold arr_stack_based_pointers in ASBP. *) +(* specialize (ASBP (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). *) +(* exploit ASBP; big_tac. *) +(* rewrite NORMALISE in H0. rewrite H1 in H0. assumption. *) + +(* + (** Preamble *) *) +(* invert MARR. crush. *) + +(* unfold Op.eval_addressing in H0. *) +(* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + +(* unfold reg_stack_based_pointers in RSBP. *) +(* pose proof (RSBP r0) as RSBPr0. *) +(* pose proof (RSBP r1) as RSBPr1. *) + +(* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; *) +(* destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. *) + +(* rewrite ARCHI in H1. crush. *) +(* subst. *) +(* clear RSBPr1. *) + +(* pose proof MASSOC as MASSOC'. *) +(* invert MASSOC'. *) +(* pose proof (H0 r0). *) +(* pose proof (H0 r1). *) +(* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) +(* assert (HPler1 : Ple r1 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) +(* apply H6 in HPler0. *) +(* apply H8 in HPler1. *) +(* invert HPler0; invert HPler1; try congruence. *) +(* rewrite EQr0 in H9. *) +(* rewrite EQr1 in H11. *) +(* invert H9. invert H11. *) +(* clear H0. clear H6. clear H8. *) + +(* unfold check_address_parameter_signed in *; *) +(* unfold check_address_parameter_unsigned in *; crush. *) + +(* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) +(* (Integers.Ptrofs.of_int *) +(* (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) *) +(* (Integers.Int.repr z0)))) as OFFSET. *) + +(* (** Modular preservation proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) +(* { rewrite HeqOFFSET. *) +(* apply PtrofsExtra.add_mod; crush; try lia. *) +(* rewrite Integers.Ptrofs.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. *) +(* apply PtrofsExtra.of_int_mod. *) +(* apply IntExtra.add_mod; crush. *) +(* apply IntExtra.mul_mod2; crush. *) +(* rewrite Integers.Int.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. *) +(* rewrite Integers.Int.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. } *) + +(* (** Read bounds proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. *) +(* { destruct (Integers.Ptrofs.unsigned OFFSET *) +(* assert (Z.to_nat *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4))) *) +(* = *) +(* valueToNat x) *) +(* as EXPR_OK by admit *) +(* end. *) +(* rewrite <- EXPR_OK. *) + +(* specialize (H7 (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4)))). *) +(* exploit H7; big_tac. *) + +(* (** RSBP preservation *) *) +(* unfold arr_stack_based_pointers in ASBP. *) +(* specialize (ASBP (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). *) +(* exploit ASBP; big_tac. *) +(* rewrite NORMALISE in H0. rewrite H1 in H0. assumption. *) + +(* + invert MARR. crush. *) + +(* unfold Op.eval_addressing in H0. *) +(* destruct (Archi.ptr64) eqn:ARCHI; crush. *) +(* rewrite ARCHI in H0. crush. *) + +(* unfold check_address_parameter_unsigned in *; *) +(* unfold check_address_parameter_signed in *; crush. *) + +(* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) +(* rewrite ZERO in H1. clear ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l in H1. *) + +(* remember i0 as OFFSET. *) + +(* (** Modular preservation proof *) *) +(* rename H0 into MOD_PRESERVE. *) + +(* (** Read bounds proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as READ_BOUND_HIGH. *) +(* { destruct (Integers.Ptrofs.unsigned OFFSET *) +(* assert (Z.to_nat *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4))) *) +(* = *) +(* valueToNat x) *) +(* as EXPR_OK by admit *) +(* end. *) +(* rewrite <- EXPR_OK. *) + +(* specialize (H7 (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4)))). *) +(* exploit H7; big_tac. *) + +(* (** RSBP preservation *) *) +(* unfold arr_stack_based_pointers in ASBP. *) +(* specialize (ASBP (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu OFFSET (Integers.Ptrofs.repr 4)))). *) +(* exploit ASBP; big_tac. *) +(* rewrite NORMALISE in H0. rewrite H1 in H0. assumption.*) *) +(* Admitted. *) +(* Hint Resolve transl_iload_correct : htlproof. *) + +(* Lemma transl_istore_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) +(* (rs : Registers.Regmap.t Values.val) (m : mem) (chunk : AST.memory_chunk) *) +(* (addr : Op.addressing) (args : list Registers.reg) (src : Registers.reg) *) +(* (pc' : RTL.node) (a : Values.val) (m' : mem), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Istore chunk addr args src pc') -> *) +(* Op.eval_addressing ge sp addr (map (fun r : positive => Registers.Regmap.get r rs) args) = Some a -> *) +(* Mem.storev chunk m a (Registers.Regmap.get src rs) = Some m' -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f sp pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m') R2. *) +(* Proof. *) +(* (* intros s f sp pc rs m chunk addr args src pc' a m' H H0 H1 R1 MSTATES. *) +(* inv_state. inv_arr_access. *) + +(* + (** Preamble *) *) +(* invert MARR. crush. *) + +(* unfold Op.eval_addressing in H0. *) +(* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + +(* unfold reg_stack_based_pointers in RSBP. *) +(* pose proof (RSBP r0) as RSBPr0. *) + +(* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; crush. *) + +(* rewrite ARCHI in H1. crush. *) +(* subst. *) + +(* pose proof MASSOC as MASSOC'. *) +(* invert MASSOC'. *) +(* pose proof (H0 r0). *) +(* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) +(* apply H6 in HPler0. *) +(* invert HPler0; try congruence. *) +(* rewrite EQr0 in H8. *) +(* invert H8. *) +(* clear H0. clear H6. *) + +(* unfold check_address_parameter_unsigned in *; *) +(* unfold check_address_parameter_signed in *; crush. *) + +(* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) +(* (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. *) + +(* (** Modular preservation proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) +(* { rewrite HeqOFFSET. *) +(* apply PtrofsExtra.add_mod; crush; try lia. *) +(* rewrite Integers.Ptrofs.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. *) +(* apply PtrofsExtra.of_int_mod. *) +(* rewrite Integers.Int.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. } *) + +(* (** Write bounds proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. *) +(* { destruct (Integers.Ptrofs.unsigned OFFSET *) +(* assert (Z.to_nat *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.divu *) +(* OFFSET *) +(* (Integers.Ptrofs.repr 4))) *) +(* = *) +(* valueToNat x) *) +(* as EXPR_OK by admit *) +(* end. *) + +(* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) +(* inversion MASSOC; revert HeqOFFSET; subst; clear MASSOC; intros HeqOFFSET. *) + +(* econstructor. *) +(* repeat split; crush. *) +(* unfold HTL.empty_stack. *) +(* crush. *) +(* unfold Verilog.merge_arrs. *) + +(* rewrite AssocMap.gcombine. *) +(* 2: { reflexivity. } *) +(* unfold Verilog.arr_assocmap_set. *) +(* rewrite AssocMap.gss. *) +(* unfold Verilog.merge_arr. *) +(* rewrite AssocMap.gss. *) +(* setoid_rewrite H5. *) +(* reflexivity. *) + +(* rewrite combine_length. *) +(* rewrite <- array_set_len. *) +(* unfold arr_repeat. crush. *) +(* apply list_repeat_len. *) + +(* rewrite <- array_set_len. *) +(* unfold arr_repeat. crush. *) +(* rewrite list_repeat_len. *) +(* rewrite H4. reflexivity. *) + +(* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) +(* (Integers.Ptrofs.of_int (Integers.Int.repr z))) as OFFSET. *) + +(* destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). *) + +(* erewrite Mem.load_store_same. *) +(* 2: { rewrite ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l. *) +(* rewrite e. *) +(* rewrite Integers.Ptrofs.unsigned_repr. *) +(* exact H1. *) +(* apply Integers.Ptrofs.unsigned_range_2. } *) +(* constructor. *) +(* erewrite combine_lookup_second. *) +(* simpl. *) +(* assert (Ple src (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; simpl; auto); *) +(* apply H0 in H13. *) +(* destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; constructor; invert H13; eauto. *) + +(* rewrite <- array_set_len. *) +(* unfold arr_repeat. crush. *) +(* rewrite list_repeat_len. auto. *) + +(* assert (4 * ptr / 4 = Integers.Ptrofs.unsigned OFFSET / 4) by (f_equal; assumption). *) +(* rewrite Z.mul_comm in H13. *) +(* rewrite Z_div_mult in H13; try lia. *) +(* replace 4 with (Integers.Ptrofs.unsigned (Integers.Ptrofs.repr 4)) in H13 by reflexivity. *) +(* rewrite <- PtrofsExtra.divu_unsigned in H13; unfold_constants; try lia. *) +(* rewrite H13. rewrite EXPR_OK. *) +(* rewrite array_get_error_set_bound. *) +(* reflexivity. *) +(* unfold arr_length, arr_repeat. simpl. *) +(* rewrite list_repeat_len. lia. *) + +(* erewrite Mem.load_store_other with (m1 := m). *) +(* 2: { exact H1. } *) +(* 2: { right. *) +(* rewrite ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l. *) +(* rewrite Integers.Ptrofs.unsigned_repr. *) +(* simpl. *) +(* destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. *) +(* right. *) +(* apply ZExtra.mod_0_bounds; try lia. *) +(* apply ZLib.Z_mod_mult'. *) +(* rewrite Z2Nat.id in H15; try lia. *) +(* apply Zmult_lt_compat_r with (p := 4) in H15; try lia. *) +(* rewrite ZLib.div_mul_undo in H15; try lia. *) +(* split; try lia. *) +(* apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. *) +(* } *) + +(* rewrite <- EXPR_OK. *) +(* rewrite PtrofsExtra.divu_unsigned; auto; try (unfold_constants; lia). *) +(* destruct (ptr ==Z Integers.Ptrofs.unsigned OFFSET / 4). *) +(* apply Z.mul_cancel_r with (p := 4) in e; try lia. *) +(* rewrite ZLib.div_mul_undo in e; try lia. *) +(* rewrite combine_lookup_first. *) +(* eapply H7; eauto. *) + +(* rewrite <- array_set_len. *) +(* unfold arr_repeat. crush. *) +(* rewrite list_repeat_len. auto. *) +(* rewrite array_gso. *) +(* unfold array_get_error. *) +(* unfold arr_repeat. *) +(* crush. *) +(* apply list_repeat_lookup. *) +(* lia. *) +(* unfold_constants. *) +(* intro. *) +(* apply Z2Nat.inj_iff in H13; try lia. *) +(* apply Z.div_pos; try lia. *) +(* apply Integers.Ptrofs.unsigned_range. *) + +(* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) +(* unfold arr_stack_based_pointers. *) +(* intros. *) +(* destruct (4 * ptr ==Z Integers.Ptrofs.unsigned OFFSET). *) + +(* crush. *) +(* erewrite Mem.load_store_same. *) +(* 2: { rewrite ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l. *) +(* rewrite e. *) +(* rewrite Integers.Ptrofs.unsigned_repr. *) +(* exact H1. *) +(* apply Integers.Ptrofs.unsigned_range_2. } *) +(* crush. *) +(* destruct (Registers.Regmap.get src rs) eqn:EQ_SRC; try constructor. *) +(* destruct (Archi.ptr64); try discriminate. *) +(* pose proof (RSBP src). rewrite EQ_SRC in H0. *) +(* assumption. *) + +(* simpl. *) +(* erewrite Mem.load_store_other with (m1 := m). *) +(* 2: { exact H1. } *) +(* 2: { right. *) +(* rewrite ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l. *) +(* rewrite Integers.Ptrofs.unsigned_repr. *) +(* simpl. *) +(* destruct (Z_le_gt_dec (4 * ptr + 4) (Integers.Ptrofs.unsigned OFFSET)); eauto. *) +(* right. *) +(* apply ZExtra.mod_0_bounds; try lia. *) +(* apply ZLib.Z_mod_mult'. *) +(* invert H0. *) +(* apply Zmult_lt_compat_r with (p := 4) in H14; try lia. *) +(* rewrite ZLib.div_mul_undo in H14; try lia. *) +(* split; try lia. *) +(* apply Z.le_trans with (m := RTL.fn_stacksize f); crush; lia. *) +(* } *) +(* apply ASBP; assumption. *) + +(* unfold stack_bounds in *. intros. *) +(* simpl. *) +(* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) +(* erewrite Mem.load_store_other with (m1 := m). *) +(* 2: { exact H1. } *) +(* 2: { right. right. simpl. *) +(* rewrite ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l. *) +(* rewrite Integers.Ptrofs.unsigned_repr; crush; try lia. *) +(* apply ZExtra.mod_0_bounds; crush; try lia. } *) +(* crush. *) +(* exploit (BOUNDS ptr); try lia. intros. crush. *) +(* exploit (BOUNDS ptr v); try lia. intros. *) +(* invert H0. *) +(* match goal with | |- ?x = _ => destruct x eqn:EQ end; try reflexivity. *) +(* assert (Mem.valid_access m AST.Mint32 sp' *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) +(* (Integers.Ptrofs.repr ptr))) Writable). *) +(* { pose proof H1. eapply Mem.store_valid_access_2 in H0. *) +(* exact H0. eapply Mem.store_valid_access_3. eassumption. } *) +(* pose proof (Mem.valid_access_store m AST.Mint32 sp' *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) +(* (Integers.Ptrofs.repr ptr))) v). *) +(* apply X in H0. invert H0. congruence. *) + +(* + (** Preamble *) *) +(* invert MARR. crush. *) + +(* unfold Op.eval_addressing in H0. *) +(* destruct (Archi.ptr64) eqn:ARCHI; crush. *) + +(* unfold reg_stack_based_pointers in RSBP. *) +(* pose proof (RSBP r0) as RSBPr0. *) +(* pose proof (RSBP r1) as RSBPr1. *) + +(* destruct (Registers.Regmap.get r0 rs) eqn:EQr0; *) +(* destruct (Registers.Regmap.get r1 rs) eqn:EQr1; crush. *) + +(* rewrite ARCHI in H1. crush. *) +(* subst. *) +(* clear RSBPr1. *) + +(* pose proof MASSOC as MASSOC'. *) +(* invert MASSOC'. *) +(* pose proof (H0 r0). *) +(* pose proof (H0 r1). *) +(* assert (HPler0 : Ple r0 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; crush; eauto). *) +(* assert (HPler1 : Ple r1 (RTL.max_reg_function f)) *) +(* by (eapply RTL.max_reg_function_use; eauto; simpl; auto). *) +(* apply H6 in HPler0. *) +(* apply H8 in HPler1. *) +(* invert HPler0; invert HPler1; try congruence. *) +(* rewrite EQr0 in H9. *) +(* rewrite EQr1 in H11. *) +(* invert H9. invert H11. *) +(* clear H0. clear H6. clear H8. *) + +(* unfold check_address_parameter_signed in *; *) +(* unfold check_address_parameter_unsigned in *; crush. *) + +(* remember (Integers.Ptrofs.add (Integers.Ptrofs.repr (uvalueToZ asr # r0)) *) +(* (Integers.Ptrofs.of_int *) +(* (Integers.Int.add (Integers.Int.mul (valueToInt asr # r1) (Integers.Int.repr z)) *) +(* (Integers.Int.repr z0)))) as OFFSET. *) + +(* (** Modular preservation proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET mod 4 = 0) as MOD_PRESERVE. *) +(* { rewrite HeqOFFSET. *) +(* apply PtrofsExtra.add_mod; crush; try lia. *) +(* rewrite Integers.Ptrofs.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. *) +(* apply PtrofsExtra.of_int_mod. *) +(* apply IntExtra.add_mod; crush. *) +(* apply IntExtra.mul_mod2; crush. *) +(* rewrite Integers.Int.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. *) +(* rewrite Integers.Int.unsigned_repr_eq. *) +(* rewrite <- Zmod_div_mod; crush. } *) + +(* (** Write bounds proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. *) +(* { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. *) +(* assert (Mem.valid_access m AST.Mint32 sp' *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) +(* (Integers.Ptrofs.repr ptr))) Writable). *) +(* { pose proof H1. eapply Mem.store_valid_access_2 in H0. *) +(* exact H0. eapply Mem.store_valid_access_3. eassumption. } *) +(* pose proof (Mem.valid_access_store m AST.Mint32 sp' *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) +(* (Integers.Ptrofs.repr ptr))) v). *) +(* apply X in H0. invert H0. congruence. *) + +(* + invert MARR. crush. *) + +(* unfold Op.eval_addressing in H0. *) +(* destruct (Archi.ptr64) eqn:ARCHI; crush. *) +(* rewrite ARCHI in H0. crush. *) + +(* unfold check_address_parameter_unsigned in *; *) +(* unfold check_address_parameter_signed in *; crush. *) + +(* assert (Integers.Ptrofs.repr 0 = Integers.Ptrofs.zero) as ZERO by reflexivity. *) +(* rewrite ZERO in H1. clear ZERO. *) +(* rewrite Integers.Ptrofs.add_zero_l in H1. *) + +(* remember i0 as OFFSET. *) + +(* (** Modular preservation proof *) *) +(* rename H0 into MOD_PRESERVE. *) + +(* (** Write bounds proof *) *) +(* assert (Integers.Ptrofs.unsigned OFFSET < f.(RTL.fn_stacksize)) as WRITE_BOUND_HIGH. *) +(* { destruct (Integers.Ptrofs.unsigned OFFSET destruct x eqn:EQ end; try reflexivity. *) +(* assert (Mem.valid_access m AST.Mint32 sp' *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) +(* (Integers.Ptrofs.repr ptr))) Writable). *) +(* { pose proof H1. eapply Mem.store_valid_access_2 in H0. *) +(* exact H0. eapply Mem.store_valid_access_3. eassumption. } *) +(* pose proof (Mem.valid_access_store m AST.Mint32 sp' *) +(* (Integers.Ptrofs.unsigned *) +(* (Integers.Ptrofs.add (Integers.Ptrofs.repr 0) *) +(* (Integers.Ptrofs.repr ptr))) v). *) +(* apply X in H0. invert H0. congruence.*) *) +(* Admitted. *) +(* Hint Resolve transl_istore_correct : htlproof. *) + +(* Lemma transl_icond_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) +(* (rs : Registers.Regmap.t Values.val) (m : mem) (cond : Op.condition) (args : list Registers.reg) *) +(* (ifso ifnot : RTL.node) (b : bool) (pc' : RTL.node), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Icond cond args ifso ifnot) -> *) +(* Op.eval_condition cond (map (fun r : positive => Registers.Regmap.get r rs) args) m = Some b -> *) +(* pc' = (if b then ifso else ifnot) -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f sp pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. *) +(* Proof. *) +(* intros s f sp pc rs m cond args ifso ifnot b pc' H H0 H1 R1 MSTATE. *) +(* inv_state. *) + +(* eexists. split. apply Smallstep.plus_one. *) +(* eapply HTL.step_module; eauto. *) +(* inv CONST; assumption. *) +(* inv CONST; assumption. *) +(* (* eapply Verilog.stmnt_runp_Vnonblock_reg with *) +(* (rhsval := if b then posToValue 32 ifso else posToValue 32 ifnot). *) +(* constructor. *) + +(* simpl. *) +(* destruct b. *) +(* eapply Verilog.erun_Vternary_true. *) +(* eapply eval_cond_correct; eauto. *) +(* constructor. *) +(* apply boolToValue_ValueToBool. *) +(* eapply Verilog.erun_Vternary_false. *) +(* eapply eval_cond_correct; eauto. *) +(* constructor. *) +(* apply boolToValue_ValueToBool. *) +(* constructor. *) + +(* big_tac. *) + +(* invert MARR. *) +(* destruct b; rewrite assumption_32bit; big_tac. *) + +(* Unshelve. *) +(* constructor. *) +(* Qed.*) *) +(* Admitted. *) +(* Hint Resolve transl_icond_correct : htlproof. *) + +(* Lemma transl_ijumptable_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (sp : Values.val) (pc : positive) *) +(* (rs : Registers.Regmap.t Values.val) (m : mem) (arg : Registers.reg) (tbl : list RTL.node) *) +(* (n : Integers.Int.int) (pc' : RTL.node), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Ijumptable arg tbl) -> *) +(* Registers.Regmap.get arg rs = Values.Vint n -> *) +(* list_nth_z tbl (Integers.Int.unsigned n) = Some pc' -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f sp pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ match_states (RTL.State s f sp pc' rs m) R2. *) +(* Proof. *) +(* intros s f sp pc rs m arg tbl n pc' H H0 H1 R1 MSTATE. *) +(* Admitted. *) +(* Hint Resolve transl_ijumptable_correct : htlproof. *) + +(* Lemma transl_ireturn_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (stk : Values.block) *) +(* (pc : positive) (rs : RTL.regset) (m : mem) (or : option Registers.reg) *) +(* (m' : mem), *) +(* (RTL.fn_code f) ! pc = Some (RTL.Ireturn or) -> *) +(* Mem.free m stk 0 (RTL.fn_stacksize f) = Some m' -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) pc rs m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) +(* match_states (RTL.Returnstate s (Registers.regmap_optget or Values.Vundef rs) m') R2. *) +(* Proof. *) +(* intros s f stk pc rs m or m' H H0 R1 MSTATE. *) +(* inv_state. *) + +(* - econstructor. split. *) +(* eapply Smallstep.plus_two. *) + +(* eapply HTL.step_module; eauto. *) +(* inv CONST; assumption. *) +(* inv CONST; assumption. *) +(* constructor. *) +(* econstructor; simpl; trivial. *) +(* econstructor; simpl; trivial. *) +(* constructor. *) +(* econstructor; simpl; trivial. *) +(* constructor. *) + +(* constructor. constructor. *) + +(* unfold state_st_wf in WF; big_tac; eauto. *) +(* destruct wf as [HCTRL HDATA]. apply HCTRL. *) +(* apply AssocMapExt.elements_iff. eexists. *) +(* match goal with H: control ! pc = Some _ |- _ => apply H end. *) + +(* apply HTL.step_finish. *) +(* unfold Verilog.merge_regs. *) +(* unfold_merge; simpl. *) +(* rewrite AssocMap.gso. *) +(* apply AssocMap.gss. lia. *) +(* apply AssocMap.gss. *) +(* rewrite Events.E0_left. reflexivity. *) + +(* constructor; auto. *) +(* constructor. *) + +(* (* FIXME: Duplication *) *) +(* - econstructor. split. *) +(* eapply Smallstep.plus_two. *) +(* eapply HTL.step_module; eauto. *) +(* inv CONST; assumption. *) +(* inv CONST; assumption. *) +(* constructor. *) +(* econstructor; simpl; trivial. *) +(* econstructor; simpl; trivial. *) +(* constructor. constructor. constructor. *) +(* constructor. constructor. constructor. *) + +(* unfold state_st_wf in WF; big_tac; eauto. *) + +(* destruct wf as [HCTRL HDATA]. apply HCTRL. *) +(* apply AssocMapExt.elements_iff. eexists. *) +(* match goal with H: control ! pc = Some _ |- _ => apply H end. *) + +(* apply HTL.step_finish. *) +(* unfold Verilog.merge_regs. *) +(* unfold_merge. *) +(* rewrite AssocMap.gso. *) +(* apply AssocMap.gss. simpl; lia. *) +(* apply AssocMap.gss. *) +(* rewrite Events.E0_left. trivial. *) + +(* constructor; auto. *) + +(* simpl. inversion MASSOC. subst. *) +(* unfold find_assocmap, AssocMapExt.get_default. rewrite AssocMap.gso. *) +(* apply H1. eapply RTL.max_reg_function_use. eauto. simpl; tauto. *) +(* assert (HPle : Ple r (RTL.max_reg_function f)). *) +(* eapply RTL.max_reg_function_use. eassumption. simpl; auto. *) +(* apply ZExtra.Ple_not_eq. apply ZExtra.Ple_Plt_Succ. assumption. *) + +(* Unshelve. *) +(* all: constructor. *) +(* Qed. *) +(* Hint Resolve transl_ireturn_correct : htlproof. *) + +(* Lemma transl_callstate_correct: *) +(* forall (s : list RTL.stackframe) (f : RTL.function) (args : list Values.val) *) +(* (m : mem) (m' : Mem.mem') (stk : Values.block), *) +(* Mem.alloc m 0 (RTL.fn_stacksize f) = (m', stk) -> *) +(* forall R1 : HTL.state, *) +(* match_states (RTL.Callstate s (AST.Internal f) args m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) +(* match_states *) +(* (RTL.State s f (Values.Vptr stk Integers.Ptrofs.zero) (RTL.fn_entrypoint f) *) +(* (RTL.init_regs args (RTL.fn_params f)) m') R2. *) +(* Proof. *) +(* intros s f args m m' stk H R1 MSTATE. *) + +(* inversion MSTATE; subst. inversion TF; subst. *) +(* econstructor. split. apply Smallstep.plus_one. *) +(* eapply HTL.step_call. crush. *) + +(* apply match_state with (sp' := stk); eauto. *) + +(* all: big_tac. *) + +(* apply regs_lessdef_add_greater. unfold Plt; lia. *) +(* apply regs_lessdef_add_greater. unfold Plt; lia. *) +(* apply regs_lessdef_add_greater. unfold Plt; lia. *) +(* apply init_reg_assoc_empty. *) + +(* constructor. *) + +(* destruct (Mem.load AST.Mint32 m' stk *) +(* (Integers.Ptrofs.unsigned (Integers.Ptrofs.add *) +(* Integers.Ptrofs.zero *) +(* (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. *) +(* pose proof Mem.load_alloc_same as LOAD_ALLOC. *) +(* pose proof H as ALLOC. *) +(* eapply LOAD_ALLOC in ALLOC. *) +(* 2: { exact LOAD. } *) +(* ptrofs. rewrite LOAD. *) +(* rewrite ALLOC. *) +(* repeat constructor. *) + +(* ptrofs. rewrite LOAD. *) +(* repeat constructor. *) + +(* unfold reg_stack_based_pointers. intros. *) +(* unfold RTL.init_regs; crush. *) +(* destruct (RTL.fn_params f); *) +(* rewrite Registers.Regmap.gi; constructor. *) + +(* unfold arr_stack_based_pointers. intros. *) +(* crush. *) +(* destruct (Mem.load AST.Mint32 m' stk *) +(* (Integers.Ptrofs.unsigned (Integers.Ptrofs.add *) +(* Integers.Ptrofs.zero *) +(* (Integers.Ptrofs.repr (4 * ptr))))) eqn:LOAD. *) +(* pose proof Mem.load_alloc_same as LOAD_ALLOC. *) +(* pose proof H as ALLOC. *) +(* eapply LOAD_ALLOC in ALLOC. *) +(* 2: { exact LOAD. } *) +(* rewrite ALLOC. *) +(* repeat constructor. *) +(* constructor. *) + +(* Transparent Mem.alloc. (* TODO: Since there are opaque there's probably a lemma. *) *) +(* Transparent Mem.load. *) +(* Transparent Mem.store. *) +(* unfold stack_bounds. *) +(* split. *) + +(* unfold Mem.alloc in H. *) +(* invert H. *) +(* crush. *) +(* unfold Mem.load. *) +(* intros. *) +(* match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. *) +(* invert v0. unfold Mem.range_perm in H4. *) +(* unfold Mem.perm in H4. crush. *) +(* unfold Mem.perm_order' in H4. *) +(* small_tac. *) +(* exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. *) +(* rewrite Maps.PMap.gss in H8. *) +(* match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. *) +(* crush. *) +(* apply proj_sumbool_true in H10. lia. *) + +(* unfold Mem.alloc in H. *) +(* invert H. *) +(* crush. *) +(* unfold Mem.store. *) +(* intros. *) +(* match goal with | |- context[if ?x then _ else _] => destruct x end; try congruence. *) +(* invert v0. unfold Mem.range_perm in H4. *) +(* unfold Mem.perm in H4. crush. *) +(* unfold Mem.perm_order' in H4. *) +(* small_tac. *) +(* exploit (H4 ptr). rewrite Integers.Ptrofs.unsigned_repr; small_tac. intros. *) +(* rewrite Maps.PMap.gss in H8. *) +(* match goal with | H8 : context[if ?x then _ else _] |- _ => destruct x eqn:EQ end; try contradiction. *) +(* crush. *) +(* apply proj_sumbool_true in H10. lia. *) +(* constructor. simplify. rewrite AssocMap.gss. *) +(* simplify. rewrite AssocMap.gso. apply AssocMap.gss. simplify. lia. *) +(* Opaque Mem.alloc. *) +(* Opaque Mem.load. *) +(* Opaque Mem.store. *) +(* Qed. *) +(* Hint Resolve transl_callstate_correct : htlproof. *) + +(* Lemma transl_returnstate_correct: *) +(* forall (res0 : Registers.reg) (f : RTL.function) (sp : Values.val) (pc : RTL.node) *) +(* (rs : RTL.regset) (s : list RTL.stackframe) (vres : Values.val) (m : mem) *) +(* (R1 : HTL.state), *) +(* match_states (RTL.Returnstate (RTL.Stackframe res0 f sp pc rs :: s) vres m) R1 -> *) +(* exists R2 : HTL.state, *) +(* Smallstep.plus HTL.step tge R1 Events.E0 R2 /\ *) +(* match_states (RTL.State s f sp pc (Registers.Regmap.set res0 vres rs) m) R2. *) +(* Proof. *) +(* intros res0 f sp pc rs s vres m R1 MSTATE. *) +(* inversion MSTATE. inversion MF. *) +(* Qed. *) +(* Hint Resolve transl_returnstate_correct : htlproof. *) + +(* Lemma option_inv : *) +(* forall A x y, *) +(* @Some A x = Some y -> x = y. *) +(* Proof. intros. inversion H. trivial. Qed. *) + +(* Lemma main_tprog_internal : *) +(* forall b, *) +(* Globalenvs.Genv.find_symbol tge tprog.(AST.prog_main) = Some b -> *) +(* exists f, Genv.find_funct_ptr (Genv.globalenv tprog) b = Some (AST.Internal f). *) +(* Proof. *) +(* intros. *) +(* destruct TRANSL. unfold main_is_internal in H1. *) +(* repeat (unfold_match H1). replace b with b0. *) +(* exploit function_ptr_translated; eauto. intros [tf [A B]]. *) +(* unfold transl_fundef, AST.transf_partial_fundef, Errors.bind in B. *) +(* unfold_match B. inv B. econstructor. apply A. *) + +(* apply option_inv. rewrite <- Heqo. rewrite <- H. *) +(* rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). *) +(* trivial. symmetry; eapply Linking.match_program_main; eauto. *) +(* Qed. *) + +(* Lemma transl_initial_states : *) +(* forall s1 : Smallstep.state (RTL.semantics prog), *) +(* Smallstep.initial_state (RTL.semantics prog) s1 -> *) +(* exists s2 : Smallstep.state (HTL.semantics tprog), *) +(* Smallstep.initial_state (HTL.semantics tprog) s2 /\ match_states s1 s2. *) +(* Proof. *) +(* induction 1. *) +(* destruct TRANSL. unfold main_is_internal in H4. *) +(* repeat (unfold_match H4). *) +(* assert (f = AST.Internal f1). apply option_inv. *) +(* rewrite <- Heqo0. rewrite <- H1. replace b with b0. *) +(* auto. apply option_inv. rewrite <- H0. rewrite <- Heqo. *) +(* trivial. *) +(* exploit function_ptr_translated; eauto. *) +(* intros [tf [A B]]. *) +(* unfold transl_fundef, Errors.bind in B. *) +(* unfold AST.transf_partial_fundef, Errors.bind in B. *) +(* repeat (unfold_match B). inversion B. subst. *) +(* exploit main_tprog_internal; eauto; intros. *) +(* rewrite symbols_preserved. replace (AST.prog_main tprog) with (AST.prog_main prog). *) +(* apply Heqo. symmetry; eapply Linking.match_program_main; eauto. *) +(* inversion H5. *) +(* econstructor; split. econstructor. *) +(* apply (Genv.init_mem_transf_partial TRANSL'); eauto. *) +(* replace (AST.prog_main tprog) with (AST.prog_main prog). *) +(* rewrite symbols_preserved; eauto. *) +(* symmetry; eapply Linking.match_program_main; eauto. *) +(* apply H6. *) + +(* constructor. *) +(* apply transl_module_correct. *) +(* assert (Some (AST.Internal x) = Some (AST.Internal m)). *) +(* replace (AST.fundef HTL.module) with (HTL.fundef). *) +(* rewrite <- H6. setoid_rewrite <- A. trivial. *) +(* trivial. inv H7. assumption. *) +(* Qed. *) +(* Hint Resolve transl_initial_states : htlproof. *) + +(* Lemma transl_final_states : *) +(* forall (s1 : Smallstep.state (RTL.semantics prog)) *) +(* (s2 : Smallstep.state (HTL.semantics tprog)) *) +(* (r : Integers.Int.int), *) +(* match_states s1 s2 -> *) +(* Smallstep.final_state (RTL.semantics prog) s1 r -> *) +(* Smallstep.final_state (HTL.semantics tprog) s2 r. *) +(* Proof. *) +(* intros. inv H0. inv H. inv H4. invert MF. constructor. reflexivity. *) +(* Qed. *) +(* Hint Resolve transl_final_states : htlproof. *) + +(* Theorem transl_step_correct: *) +(* forall (S1 : RTL.state) t S2, *) +(* RTL.step ge S1 t S2 -> *) +(* forall (R1 : HTL.state), *) +(* match_states S1 R1 -> *) +(* exists R2, Smallstep.plus HTL.step tge R1 t R2 /\ match_states S2 R2. *) +(* Proof. *) +(* induction 1; eauto with htlproof; (intros; inv_state). *) +(* Qed. *) +(* Hint Resolve transl_step_correct : htlproof. *) Theorem transf_program_correct: Smallstep.forward_simulation (RTL.semantics prog) (HTL.semantics tprog). Proof. - eapply Smallstep.forward_simulation_plus; eauto with htlproof. - apply senv_preserved. - Qed. + (* eapply Smallstep.forward_simulation_plus; eauto with htlproof. *) + (* apply senv_preserved. *) + (* Qed. *) + Admitted. End CORRECTNESS. -- cgit From fcb129725a68a052a079f882396be8e28142e1e0 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Tue, 7 Jul 2020 13:50:55 +0100 Subject: Only translate_cond left --- src/translation/HTLgen.v | 44 ++++++--- src/translation/HTLgenproof.v | 203 ++++++++++++++++++++++++++++++++++++++++-- src/translation/HTLgenspec.v | 18 ++++ src/verilog/Verilog.v | 4 +- 4 files changed, 252 insertions(+), 17 deletions(-) diff --git a/src/translation/HTLgen.v b/src/translation/HTLgen.v index b4f6b51..9f39edb 100644 --- a/src/translation/HTLgen.v +++ b/src/translation/HTLgen.v @@ -269,12 +269,35 @@ Definition translate_comparison_imm (c : Integers.comparison) (args : list reg) | _, _ => error (Errors.msg "Htlgen: comparison_imm instruction not implemented: other") end. +Definition translate_comparisonu (c : Integers.comparison) (args : list reg) : mon expr := + match c, args with + | Integers.Ceq, r1::r2::nil => ret (bop Veq r1 r2) + | Integers.Cne, r1::r2::nil => ret (bop Vne r1 r2) + | Integers.Clt, r1::r2::nil => ret (bop Vltu r1 r2) + | Integers.Cgt, r1::r2::nil => ret (bop Vgtu r1 r2) + | Integers.Cle, r1::r2::nil => ret (bop Vleu r1 r2) + | Integers.Cge, r1::r2::nil => ret (bop Vgeu r1 r2) + | _, _ => error (Errors.msg "Htlgen: comparison instruction not implemented: other") + end. + +Definition translate_comparison_immu (c : Integers.comparison) (args : list reg) (i: Integers.int) + : mon expr := + match c, args with + | Integers.Ceq, r1::nil => ret (boplit Veq r1 i) + | Integers.Cne, r1::nil => ret (boplit Vne r1 i) + | Integers.Clt, r1::nil => ret (boplit Vltu r1 i) + | Integers.Cgt, r1::nil => ret (boplit Vgtu r1 i) + | Integers.Cle, r1::nil => ret (boplit Vleu r1 i) + | Integers.Cge, r1::nil => ret (boplit Vgeu r1 i) + | _, _ => error (Errors.msg "Htlgen: comparison_imm instruction not implemented: other") + end. + Definition translate_condition (c : Op.condition) (args : list reg) : mon expr := match c, args with | Op.Ccomp c, _ => translate_comparison c args - | Op.Ccompu c, _ => translate_comparison c args + | Op.Ccompu c, _ => translate_comparisonu c args | Op.Ccompimm c i, _ => translate_comparison_imm c args i - | Op.Ccompuimm c i, _ => translate_comparison_imm c args i + | Op.Ccompuimm c i, _ => translate_comparison_immu c args i | Op.Cmaskzero n, _ => error (Errors.msg "Htlgen: condition instruction not implemented: Cmaskzero") | Op.Cmasknotzero n, _ => error (Errors.msg "Htlgen: condition instruction not implemented: Cmasknotzero") | _, _ => error (Errors.msg "Htlgen: condition instruction not implemented: other") @@ -301,11 +324,11 @@ Definition translate_eff_addressing (a: Op.addressing) (args: list reg) : mon ex else error (Errors.msg "Veriloggen: translate_eff_addressing (Ascaled): address misaligned") | Op.Aindexed2 offset, r1::r2::nil => if (check_address_parameter_signed offset) - then ret (Vbinop Vadd (Vvar r1) (boplitz Vadd r2 offset)) + then ret (Vbinop Vadd (bop Vadd r1 r2) (Vlit (ZToValue offset))) else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed2): address misaligned") | Op.Aindexed2scaled scale offset, r1::r2::nil => (* Typical for dynamic array addressing *) if (check_address_parameter_signed scale) && (check_address_parameter_signed offset) - then ret (Vbinop Vadd (boplitz Vadd r1 offset) (boplitz Vmul r2 scale)) + then ret (Vbinop Vadd (Vvar r1) (Vbinop Vadd (boplitz Vmul r2 scale) (Vlit (ZToValue offset)))) else error (Errors.msg "Veriloggen: translate_eff_addressing (Aindexed2scaled): address misaligned") | Op.Ainstack a, nil => (* We need to be sure that the base address is aligned *) let a := Integers.Ptrofs.unsigned a in @@ -324,8 +347,8 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr := | Op.Osub, r1::r2::nil => ret (bop Vsub r1 r2) | Op.Omul, r1::r2::nil => ret (bop Vmul r1 r2) | Op.Omulimm n, r::nil => ret (boplit Vmul r n) - | Op.Omulhs, r1::r2::nil => ret (bop Vmul r1 r2) - | Op.Omulhu, r1::r2::nil => ret (bop Vmul r1 r2) + | Op.Omulhs, r1::r2::nil => error (Errors.msg "Htlgen: Instruction not implemented: mulhs") + | Op.Omulhu, r1::r2::nil => error (Errors.msg "Htlgen: Instruction not implemented: mulhu") | Op.Odiv, r1::r2::nil => ret (bop Vdiv r1 r2) | Op.Odivu, r1::r2::nil => ret (bop Vdivu r1 r2) | Op.Omod, r1::r2::nil => ret (bop Vmod r1 r2) @@ -341,12 +364,13 @@ Definition translate_instr (op : Op.operation) (args : list reg) : mon expr := | Op.Oshlimm n, r::nil => ret (boplit Vshl r n) | Op.Oshr, r1::r2::nil => ret (bop Vshr r1 r2) | Op.Oshrimm n, r::nil => ret (boplit Vshr r n) - | Op.Oshrximm n, r::nil => ret (Vbinop Vdiv (Vvar r) - (Vbinop Vshl (Vlit (ZToValue 1)) - (Vlit (intToValue n)))) + | Op.Oshrximm n, r::nil => error (Errors.msg "Htlgen: Instruction not implemented: Oshrximm") + (*ret (Vbinop Vdiv (Vvar r) + (Vbinop Vshl (Vlit (ZToValue 1)) + (Vlit (intToValue n))))*) | Op.Oshru, r1::r2::nil => ret (bop Vshru r1 r2) | Op.Oshruimm n, r::nil => ret (boplit Vshru r n) - | Op.Ororimm n, r::nil => ret (Vbinop Vor (boplit Vshr r n) (boplit Vshl r (Integers.Int.sub (Integers.Int.repr 32) n))) + | Op.Ororimm n, r::nil => ret (boplit Vror r n) | Op.Oshldimm n, r::nil => ret (Vbinop Vor (boplit Vshl r n) (boplit Vshr r (Integers.Int.sub (Integers.Int.repr 32) n))) | Op.Ocmp c, _ => translate_condition c args | Op.Osel c AST.Tint, r1::r2::rl => diff --git a/src/translation/HTLgenproof.v b/src/translation/HTLgenproof.v index 51c0fa1..7db0a2b 100644 --- a/src/translation/HTLgenproof.v +++ b/src/translation/HTLgenproof.v @@ -420,6 +420,7 @@ Section CORRECTNESS. destruct args; inv H | |- context[if ?c then _ else _] => destruct c; try discriminate | H: match _ with _ => _ end = Some _ |- _ => repeat (unfold_match H) + | H: match _ with _ => _ end = OK _ _ _ |- _ => repeat (unfold_match H) | |- context[match ?g with _ => _ end] => destruct g; try discriminate | |- _ => simplify; solve [auto] end. @@ -451,10 +452,15 @@ Section CORRECTNESS. | |- context[valueToPtr] => unfold valueToPtr | |- context[valueToInt] => unfold valueToInt | |- context[bop] => unfold bop + | H : context[bop] |- _ => unfold bop in H | |- context[boplit] => unfold boplit + | H : context[boplit] |- _ => unfold boplit in H + | |- context[boplitz] => unfold boplitz + | H : context[boplitz] |- _ => unfold boplitz in H | |- val_value_lessdef Values.Vundef _ => solve [constructor] | H : val_value_lessdef _ _ |- val_value_lessdef (Values.Vint _) _ => constructor; inv H | |- val_value_lessdef (Values.Vint _) _ => constructor; auto + | H : ret _ _ = OK _ _ _ |- _ => inv H | H : context[RTL.max_reg_function ?f] |- context[_ (Registers.Regmap.get ?r ?rs) (Registers.Regmap.get ?r0 ?rs)] => let HPle1 := fresh "HPle" in @@ -471,6 +477,8 @@ Section CORRECTNESS. [econstructor; eauto; constructor; trivial | inv HPle1; try (constructor; auto)] | H : _ :: _ = _ :: _ |- _ => inv H | |- context[match ?d with _ => _ end] => destruct d eqn:?; try discriminate + | H : match ?d with _ => _ end = _ |- _ => repeat unfold_match H + | H : match ?d with _ => _ end _ = _ |- _ => repeat unfold_match H | |- Verilog.expr_runp _ _ _ _ _ => econstructor | |- val_value_lessdef (?f _ _) _ => unfold f | |- val_value_lessdef (?f _) _ => unfold f @@ -490,7 +498,49 @@ Section CORRECTNESS. assert (HPle : Ple r (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto); apply H in HPle; eexists; split; try constructor; eauto | |- context[if ?c then _ else _] => destruct c eqn:?; try discriminate + | H : ?b = _ |- _ = boolToValue ?b => rewrite H end. + Ltac inv_lessdef := lazymatch goal with + | H2 : context[RTL.max_reg_function ?f], H : Registers.Regmap.get ?r ?rs = _, + H1 : Registers.Regmap.get ?r0 ?rs = _ |- _ => + let HPle1 := fresh "HPle" in + assert (HPle1 : Ple r (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H2 in HPle1; inv HPle1; + let HPle2 := fresh "HPle" in + assert (HPle2 : Ple r0 (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H2 in HPle2; inv HPle2 + | H2 : context[RTL.max_reg_function ?f], H : Registers.Regmap.get ?r ?rs = _ |- _ => + let HPle1 := fresh "HPle" in + assert (HPle1 : Ple r (RTL.max_reg_function f)) + by (eapply RTL.max_reg_function_use; eauto; simpl; auto); + apply H2 in HPle1; inv HPle1 + end. + Ltac solve_cond := + match goal with + | H : Values.Vptr _ _ = Registers.Regmap.get ?r ?rs, + H2 : Registers.Regmap.get ?r ?rs = Values.Vint _ |- _ => + rewrite H2 in H; discriminate + | H : Values.Vundef = Registers.Regmap.get ?r ?rs, + H2 : Registers.Regmap.get ?r ?rs = Values.Vint _ |- _ => + rewrite H2 in H; discriminate + | H : Values.Vint _ = Registers.Regmap.get ?r ?rs, + H2 : Registers.Regmap.get ?r ?rs = Values.Vptr _ _ |- _ => + rewrite H2 in H; discriminate + | H : Values.Vint _ = Registers.Regmap.get ?r ?rs, + H2 : Registers.Regmap.get ?r ?rs = Values.Vint _ _ |- _ => + rewrite H2 in H; discriminate + | |- context[val_value_lessdef Values.Vundef _] => + econstructor; split; econstructor; econstructor; auto; solve [constructor] + | H1 : Registers.Regmap.get ?r ?rs = Values.Vint _, + H2 : Values.Vint _ = Registers.Regmap.get ?r ?rs, + H3 : Registers.Regmap.get ?r0 ?rs = Values.Vint _, + H4 : Values.Vint _ = Registers.Regmap.get ?r0 ?rs|- _ => + rewrite H1 in H2; rewrite H3 in H4; inv H2; inv H4; unfold valueToInt in *; constructor + | H : _ :: _ = _ :: _ |- _ => inv H + | H : ret _ _ = OK _ _ _ |- _ => inv H + end. intros s sp op rs m v e asr asa f f' stk s' i pc pc' res0 args res ml st MSTATE INSTR EVAL TR_INSTR. inv MSTATE. inv MASSOC. unfold translate_instr in TR_INSTR; repeat (unfold_match TR_INSTR); inv TR_INSTR; unfold Op.eval_operation in EVAL; repeat (unfold_match EVAL); inv EVAL; @@ -513,16 +563,157 @@ Section CORRECTNESS. eapply H2 in ARCH. apply ARCH. pose proof Ptrofs.agree32_of_int. unfold Ptrofs.agree32 in H2. eapply H2 in ARCH. apply ARCH. - - admit. (* mulhs *) - - admit. (* mulhu *) - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. - rewrite Heqb in Heqb0. discriminate. - rewrite H0 in Heqb. rewrite H1 in Heqb. discriminate. - rewrite Heqb in Heqb0. discriminate. - - admit. - - admit. (* ror *) - - admit. (* addressing *) - - admit. (* eval_condition *) + - unfold Op.eval_addressing32 in *. repeat (unfold_match H2); inv H2. + + unfold translate_eff_addressing in *. repeat (unfold_match H1). + destruct v0; inv Heql; rewrite H2; inv H1; repeat eval_correct_tac. + pose proof Integers.Ptrofs.agree32_add as AGR; unfold Integers.Ptrofs.agree32 in AGR. unfold ZToValue. + apply ptrofs_inj. unfold Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. + apply AGR. auto. rewrite H2 in H0. inv H0. unfold valueToPtr. unfold Ptrofs.of_int. + rewrite Ptrofs.unsigned_repr. auto. replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + rewrite Ptrofs.unsigned_repr. auto. replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + + unfold translate_eff_addressing in *. repeat (unfold_match H1). inv H1. + inv Heql. unfold boplitz. repeat (simplify; eval_correct_tac). + all: repeat (unfold_match Heqv). + * inv Heqv. unfold valueToInt in *. inv H2. inv H0. unfold valueToInt in *. trivial. + * constructor. unfold valueToPtr, ZToValue in *. + pose proof Integers.Ptrofs.agree32_add as AGR; unfold Integers.Ptrofs.agree32 in AGR. unfold ZToValue. + apply ptrofs_inj. unfold Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. + apply AGR. auto. inv Heqv. rewrite Int.add_commut. + apply AGR. auto. inv H1. inv H0. unfold valueToPtr. unfold Ptrofs.of_int. + rewrite Ptrofs.unsigned_repr. auto. replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + unfold Ptrofs.of_int. + rewrite Ptrofs.unsigned_repr. inv H0. auto. replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + rewrite Ptrofs.unsigned_repr. auto. replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + apply Int.unsigned_range_2. + * constructor. unfold valueToPtr, ZToValue in *. + pose proof Integers.Ptrofs.agree32_add as AGR; unfold Integers.Ptrofs.agree32 in AGR. unfold ZToValue. + apply ptrofs_inj. unfold Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. + apply AGR. auto. inv Heqv. + apply AGR. auto. inv H0. unfold valueToPtr, Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. auto. + replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + inv H1. unfold valueToPtr, Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. auto. + replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. + rewrite Ptrofs.unsigned_repr. auto. + replace Ptrofs.max_unsigned with Int.max_unsigned by auto. + apply Int.unsigned_range_2. apply Int.unsigned_range_2. + + unfold translate_eff_addressing in *. repeat (unfold_match H1). inv H1. + inv Heql. unfold boplitz. repeat (simplify; eval_correct_tac). + all: repeat (unfold_match Heqv). + * unfold Values.Val.mul in Heqv. repeat (unfold_match Heqv). inv Heqv. inv H3. + unfold valueToInt, ZToValue. auto. + * unfold Values.Val.mul in Heqv. repeat (unfold_match Heqv). + * unfold Values.Val.mul in Heqv. repeat (unfold_match Heqv). + * constructor. unfold valueToPtr, ZToValue. unfold Values.Val.mul in Heqv. repeat (unfold_match Heqv). + + unfold translate_eff_addressing in *. repeat (unfold_match H1). inv H1. + inv Heql. unfold boplitz. repeat (simplify; eval_correct_tac). + all: repeat (unfold_match Heqv). + unfold valueToPtr, ZToValue. + repeat unfold_match Heqv0. unfold Values.Val.mul in Heqv1. repeat unfold_match Heqv1. + inv Heqv1. inv Heqv0. unfold valueToInt in *. + assert (HPle1 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + apply H in HPle1. inv HPle1. unfold valueToInt in *. rewrite Heqv2 in H2. inv H2. auto. + rewrite Heqv2 in H2. inv H2. + rewrite Heqv2 in H3. discriminate. + repeat unfold_match Heqv0. unfold Values.Val.mul in Heqv1. repeat unfold_match Heqv1. + repeat unfold_match Heqv0. unfold Values.Val.mul in Heqv1. repeat unfold_match Heqv1. + constructor. unfold valueToPtr, ZToValue. inv Heqv0. inv Heqv1. + assert (HPle1 : Ple r0 (RTL.max_reg_function f)) by (eapply RTL.max_reg_function_use; eauto; simpl; auto). + apply H in HPle1. inv HPle1. unfold valueToInt in *. rewrite Heqv2 in H3. inv H3. + + pose proof Integers.Ptrofs.agree32_add as AGR; unfold Integers.Ptrofs.agree32 in AGR. unfold ZToValue. + apply ptrofs_inj. unfold Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. + apply AGR. auto. inv H2. unfold valueToPtr, Ptrofs.of_int. rewrite Ptrofs.unsigned_repr. auto. + replace Ptrofs.max_unsigned with Int.max_unsigned by auto. apply Int.unsigned_range_2. + apply Ptrofs.unsigned_repr. apply Int.unsigned_range_2. apply Int.unsigned_range_2. + + rewrite Heqv2 in H3. inv H3. + + rewrite Heqv2 in H4. inv H4. + + unfold translate_eff_addressing in *. repeat (unfold_match H1). inv H1. + inv Heql. unfold boplitz. repeat (simplify; eval_correct_tac). + all: repeat (unfold_match Heqv). + eexists. split. constructor. + constructor. unfold valueToPtr, ZToValue. rewrite Ptrofs.add_zero_l. unfold Ptrofs.of_int. + rewrite Int.unsigned_repr. symmetry. apply Ptrofs.repr_unsigned. + unfold check_address_parameter_unsigned in *. apply Ptrofs.unsigned_range_2. + - unfold translate_condition in *; repeat unfold_match H1; + unfold translate_comparison in *; repeat unfold_match H1; inv H1; + unfold translate_comparisonu, translate_comparison_imm, translate_comparison_immu in *; + unfold Op.eval_condition, Values.Val.of_optbool, Values.Val.cmp_bool, Values.Val.cmpu_bool, bop in *; + simplify; + repeat (match goal with |- context[match ?d with _ => _ end] => destruct d eqn:? end; + match goal with H : context[match ?d with _ => _ end] |- _ => repeat unfold_match H end); + try (match goal with |- context[if ?d then _ else _] => destruct d eqn:? end); + simplify; repeat solve_cond. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1. auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1. auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + eexists. split. econstructor; econstructor; auto. + simplify. inv_lessdef; solve_cond. rewrite H1; auto. + + inv_lessdef; try solve_cond. + * unfold valueToInt, valueToPtr in *. rewrite H5 in H3. rewrite H4 in H2. inv H2. inv H3. + eexists. split. econstructor; econstructor; auto. simplify. + unfold Int.eq. + constructor. apply H in HPle1. inv HPle1. unfold valueToInt in *. rewrite Heqv2 in H2. inv H2. auto. + - rewrite H2. auto. + - + admit. (* eval_condition *) - admit. (* select *) Admitted. diff --git a/src/translation/HTLgenspec.v b/src/translation/HTLgenspec.v index f0508bd..71fb618 100644 --- a/src/translation/HTLgenspec.v +++ b/src/translation/HTLgenspec.v @@ -349,6 +349,15 @@ Proof. Qed. Hint Resolve translate_comparison_freshreg_trans : htlspec. +Lemma translate_comparisonu_freshreg_trans : + forall op args s r s' i, + translate_comparisonu op args s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_comparisonu_freshreg_trans : htlspec. + Lemma translate_comparison_imm_freshreg_trans : forall op args s r s' i n, translate_comparison_imm op args n s = OK r s' i -> @@ -358,6 +367,15 @@ Proof. Qed. Hint Resolve translate_comparison_imm_freshreg_trans : htlspec. +Lemma translate_comparison_immu_freshreg_trans : + forall op args s r s' i n, + translate_comparison_immu op args n s = OK r s' i -> + s.(st_freshreg) = s'.(st_freshreg). +Proof. + destruct op; intros; simpl in *; repeat (unfold_match H); inv H; auto. +Qed. +Hint Resolve translate_comparison_immu_freshreg_trans : htlspec. + Lemma translate_condition_freshreg_trans : forall op args s r s' i, translate_condition op args s = OK r s' i -> diff --git a/src/verilog/Verilog.v b/src/verilog/Verilog.v index 78b057d..43df3dd 100644 --- a/src/verilog/Verilog.v +++ b/src/verilog/Verilog.v @@ -143,7 +143,8 @@ Inductive binop : Type := | Vxor : binop (** xor (binary [^|]) *) | Vshl : binop (** shift left ([<<]) *) | Vshr : binop (** shift right ([>>>]) *) -| Vshru : binop. (** shift right unsigned ([>>]) *) +| Vshru : binop (** shift right unsigned ([>>]) *) +| Vror : binop. (** shift right unsigned ([>>]) *) (** ** Unary Operators *) @@ -324,6 +325,7 @@ Definition binop_run (op : binop) (v1 v2 : value) : option value := | Vshl => Some (Int.shl v1 v2) | Vshr => Some (Int.shr v1 v2) | Vshru => Some (Int.shru v1 v2) + | Vror => Some (Int.ror v1 v2) end. Definition unop_run (op : unop) (v1 : value) : value := -- cgit