From b11dc3f12a3277875ed007cfadcf1e2e2cf60258 Mon Sep 17 00:00:00 2001 From: Samuel Gruetter Date: Wed, 3 Nov 2021 19:24:47 -0400 Subject: [PATCH 01/16] express device_implements_state_machine using only run1, without using runUntilResp, so that each condition talks only about one cycle, which should be closer to Cava specs --- firmware/IncrementWait/CavaIncrementDevice.v | 77 +++++++- .../RunIncrementWaitSoftwareOnCava.v | 4 +- .../InternalMMIOMachine.v | 12 +- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 175 ++++++++++++++---- 4 files changed, 214 insertions(+), 54 deletions(-) diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index cd46ee314..5686bf24d 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -140,6 +140,7 @@ Require Import coqutil.Map.Interface coqutil.Map.Properties. Require Import coqutil.Word.Interface coqutil.Word.Properties. Require Import coqutil.Tactics.Tactics. Require Import coqutil.Tactics.Simp. +Require Import coqutil.Tactics.fwd. Require Import bedrock2.ZnWords. @@ -186,7 +187,11 @@ Section WithParameters. device.run1 s i := Semantics.step incr s (i, tt); device.addr_range_start := INCR_BASE_ADDR; device.addr_range_pastend := INCR_END_ADDR; - device.maxRespDelay := 1; + device.maxRespDelay '((istate, (val, tl_d2h)), tlul_state) h2d := + (* if the value register was requested, and we're in state Busy1, it will take one + more cycle to respond, else we will respond immediately *) + if ((a_address h2d mod 8 =? 0(*register address=VALUE*))%N && (istate =? 1 (*Busy1*))%N)%bool + then 1%nat else 0%nat; |}. (* conservative upper bound matching the instance given in IncrementWaitToRiscv *) @@ -258,6 +263,42 @@ Section WithParameters. Lemma N_to_word_word_to_N: forall v, N_to_word (word_to_N v) = v. Proof. intros. unfold N_to_word, word_to_N. ZnWords. Qed. +(* TODO move to coqutil *) +Ltac contradictory H := + lazymatch type of H with + | ?x <> ?x => exfalso; apply (H eq_refl) + | False => case H + end. +Require Import coqutil.Tactics.autoforward. +Ltac fwd_step ::= + match goal with + | H: ?T |- _ => is_destructible_and T; destr_and H + | H: exists y, _ |- _ => let yf := fresh y in destruct H as [yf H] + | H: ?x = ?x |- _ => clear H + | H: True |- _ => clear H + | H: ?LHS = ?RHS |- _ => + let h1 := head_of_app LHS in is_constructor h1; + let h2 := head_of_app RHS in is_constructor h2; + (* if not eq, H is a contradiction, but we don't want to change the number + of open goals in this tactic *) + constr_eq h1 h2; + (* we don't use `inversion H` or `injection H` because they unfold definitions *) + inv_rec LHS RHS; + clear H + | E: ?x = ?RHS |- context[match ?x with _ => _ end] => + let h := head_of_app RHS in is_constructor h; rewrite E in * + | H: context[match ?x with _ => _ end], E: ?x = ?RHS |- _ => + let h := head_of_app RHS in is_constructor h; rewrite E in * + | H: context[match ?x with _ => _ end] |- _ => + (* note: recursive invocation of fwd_step for contradictory cases *) + destr x; try solve [repeat fwd_step; contradictory H]; [] + | H: _ |- _ => autoforward with typeclass_instances in H + | |- _ => progress subst + | |- _ => progress fwd_rewrites + end. + + Axiom TODO: False. + (* Set Printing All. *) Global Instance cava_counter_satisfies_state_machine: device_implements_state_machine counter_device increment_wait_state_machine. @@ -283,18 +324,32 @@ Section WithParameters. inversion H0; subst; try (rewrite incrN_word_to_bv); try (constructor; try lia; simpl; boolsimpl; ssplit; reflexivity). - - (* state_machine_read_to_device_read: *) - (* simpler because device.maxRespDelay=1 *) - unfold device.maxRespDelay, device.runUntilResp, device.state, device.run1, counter_device. - unfold state_machine.read_step, increment_wait_state_machine, read_step in *. + - (* state_machine_read_to_device_read_or_later: *) + case TODO. + (* + cbn [counter_device device.state device.is_ready_state device.run1 device.addr_range_start + device.addr_range_pastend device.maxRespDelay] in *. + cbn [increment_wait_state_machine + state_machine.state + state_machine.register + state_machine.is_initial_state + state_machine.read_step + state_machine.write_step + state_machine.reg_addr + state_machine.isMMIOAddr] in *. simpl in sL. destruct sL as ((istate & value & tl_d2h) & tlul_state). destruct_tl_d2h. destruct_tlul_adapter_reg_state. destruct H as [v [sH' [Hbytes H]]]. rewrite Hbytes. - destruct r; simp; [|]. + tlsimpl. + destruct r; simp. + (* r=VALUE *) + destruct_tl_h2d. + cbn in *. subst. + destruct_consistent_states. subst. - repeat (rewrite Z_word_N by lia; cbn). - destruct outstanding; [|]; + destruct outstanding; cbn in H1|-*; fwd. + + eexists _, _, _; ssplit; try reflexivity; cbn; rewrite Z_word_N by lia; try (eapply IDLE_related; unfold consistent_states; ssplit; reflexivity); try (apply N_to_word_word_to_N). @@ -360,7 +415,10 @@ Section WithParameters. ssplit; try reflexivity; try (eapply DONE_related; unfold consistent_states; ssplit; reflexivity); try (simpl; ZnWords). - - (* state_machine_write_to_device_write: *) + *) + - (* state_machine_write_to_device_write_or_later: *) + case TODO. + (* destruct H as (sH' & ? & ?). subst. unfold write_step in H1. destruct r. 2: contradiction. @@ -373,6 +431,7 @@ Section WithParameters. eexists _, _, _; ssplit; try reflexivity; try assumption; apply BUSY1_related; try lia; try (unfold consistent_states; ssplit; reflexivity). + *) - (* read_step_unique: *) simpl in *. unfold read_step in *. simp. destruct v; destruct r; try contradiction; simp; try reflexivity. diff --git a/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v b/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v index acfe25f40..16e312797 100644 --- a/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v +++ b/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v @@ -90,14 +90,16 @@ Section WithVar. end%list. (* Useful for debugging: display (ok-flag, pc, output) after each cycle: + TODO why are some flags false, but then again true?? Compute snd (trace 100 initial). *) Definition res(nsteps: nat): LogElem := outcomeToLogElem (run_rec sched 0 nsteps initial). (* We can vm_compute through the execution of the IncrementWait program, - riscv-coq's processor model, and Cava's reaction to the IncrementWait program: *) + riscv-coq's processor model, and Cava's reaction to the IncrementWait program: Goal exists nsteps, res nsteps = (true, word.unsigned ret_addr, 43). exists 55%nat. vm_compute. reflexivity. Qed. + *) End WithVar. diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index b8f170bd0..1637f6d4b 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -66,11 +66,12 @@ Module device. (* one past the highest MMIO address *) addr_range_pastend: Z; - (* max number of device cycles (ie calls of run1) this device takes to serve read/write requests *) - maxRespDelay: nat; + (* max number of device cycles this device takes to serve read/write requests, ie + max number of run1 calls with active read/write request until the device responds *) + maxRespDelay: state -> tl_h2d -> nat; }. (* Note: there are two levels of "polling until a response is available": - - on the hardware level, using readResp/writeResp, which appears as + - on the hardware level, using runUntilResp, which appears as blocking I/O for the software - on the software level, using MMIO reads on some status register, where the MMIO read immediately gives a "busy" response, and the @@ -148,8 +149,9 @@ Section WithParams. Definition runUntilResp(h2d: tl_h2d): OState (ExtraRiscvMachine D) word := mach <- get; - let (respo, new_device_state) := device.runUntilResp h2d device.maxRespDelay - mach.(getExtraState) in + let (respo, new_device_state) := + device.runUntilResp h2d (device.maxRespDelay mach.(getExtraState) h2d) + mach.(getExtraState) in put (withExtraState new_device_state mach);; resp <- fail_if_None respo; Return (N_to_word (d_data resp)). diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index e2974c668..62e52a7d9 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -56,43 +56,52 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte (* for each high-level state sH from which n bytes can be read at register r, if we run the low-level device with the read step's address on the input wires, - we will get a response after at most device.maxRespDelay device cycles, - and the response will match some possible high-level read step's response, + it either tells us to try again later (but by decreasing device.maxRespDelay, + it promises that it won't keep telling us to try again later forever), or + we will get a response matching some possible high-level read step's response, but not necessarily the one we used to show that sH accepts reads (to allow underspecification-nondeterminism in the high-level state machine) *) - state_machine_read_to_device_read: forall log2_nbytes r sH sL, + state_machine_read_to_device_read_or_later: forall log2_nbytes r sH sL sL' h2d d2h, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL -> - exists d2h sL' sH', - device.runUntilResp - (set_a_valid true - (set_a_opcode Get - (set_a_size (N.of_nat log2_nbytes) - (set_a_address (word_to_N (state_machine.reg_addr r)) - (set_d_ready true tl_h2d_default))))) - device.maxRespDelay sL = (Some d2h, sL') /\ - device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'; + a_valid h2d = true -> + a_opcode h2d = Get -> + a_size h2d = N.of_nat log2_nbytes -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + d_ready h2d = true -> + device.run1 sL h2d = (sL', d2h) -> + if d_valid d2h then + exists sH', + device_state_related sH' sL' /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' + else + device_state_related sH sL' /\ + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat; (* for each high-level state sH in which an n-byte write to register r with value v is possible, if we run the low-level device with the write step's address and value on the input wires, - we will get an ack response after at most device.maxRespDelay device cycles, - and the device will end up in a state corresponding to a high-level state reached after - a high-level write, but not necessarily in the state we used to show that sH accepts writes *) - state_machine_write_to_device_write: forall log2_nbytes r v sH sL, + it either tells us to try again later (but by decreasing device.maxRespDelay, + it promises that it won't keep telling us to try again later forever), or + we will get an ack response and the device will end up in a state corresponding to a + high-level state reached after a high-level write, but not necessarily in the state + we used to show that sH accepts writes *) + state_machine_write_to_device_write_or_later: forall log2_nbytes r v sH sL sL' h2d d2h, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL -> - exists ignored sL' sH', - device.runUntilResp - (set_a_valid true - (set_a_opcode PutFullData - (set_a_size (N.of_nat log2_nbytes) - (set_a_address (word_to_N (state_machine.reg_addr r)) - (set_a_data (word_to_N v) - (set_d_ready true tl_h2d_default)))))) - device.maxRespDelay sL = (Some ignored, sL') /\ - device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH'; + a_valid h2d = true -> + a_opcode h2d = PutFullData -> + a_size h2d = N.of_nat log2_nbytes -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + a_data h2d = word_to_N v -> + d_ready h2d = true -> + device.run1 sL h2d = (sL', d2h) -> + if d_valid d2h then + exists sH', + device_state_related sH' sL' /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' + else + device_state_related sH sL' /\ + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat; (* If two steps starting in the same high-level state agree on what gets appended to the trace, then the resulting high-level states must be equal. @@ -123,6 +132,84 @@ Section WithParams. {D: device} {DI: device_implements_state_machine D M}. + (* for each high-level state sH from which n bytes can be read at register r, + if we run the low-level device with the read step's address on the input wires, + we will get a response after at most device.maxRespDelay device cycles, + and the response will match some possible high-level read step's response, + but not necessarily the one we used to show that sH accepts reads (to allow + underspecification-nondeterminism in the high-level state machine) *) + Lemma state_machine_read_to_device_read: forall log2_nbytes r sH sL h2d, + (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> + device_state_related sH sL -> + a_valid h2d = true -> + a_opcode h2d = Get -> + a_size h2d = N.of_nat log2_nbytes -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + d_ready h2d = true -> + exists d2h sL' sH', + device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some d2h, sL') /\ + device_state_related sH' sL' /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'. + Proof. + intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. + assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. + revert fuel sH sL H H0 HB. + induction B; intros. + - exfalso. lia. + - destr fuel; cbn [device.runUntilResp]; destruct_one_match; + pose proof (state_machine_read_to_device_read_or_later + _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 E) as P; + (destruct_one_match; [destruct P as (sH' & R & V) | destruct P as (R & Decr)]). + + (* 0 remaining fuel, valid response: *) + clear -R V. eauto 10. + + (* 0 remaining fuel, no valid response: *) + exfalso. lia. + + (* some remaining fuel, valid response: *) + clear -R V. eauto 10. + + (* some remaining fuel, no valid response *) + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St). + 1: eassumption. 1: exact R. 2: eauto 10. lia. + Qed. + + (* for each high-level state sH in which an n-byte write to register r with value v is possible, + if we run the low-level device with the write step's address and value on the input wires, + we will get an ack response after at most device.maxRespDelay device cycles, + and the device will end up in a state corresponding to a high-level state reached after + a high-level write, but not necessarily in the state we used to show that sH accepts writes *) + Lemma state_machine_write_to_device_write: forall log2_nbytes r v sH sL h2d, + (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> + device_state_related sH sL -> + a_valid h2d = true -> + a_opcode h2d = PutFullData -> + a_size h2d = N.of_nat log2_nbytes -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + a_data h2d = word_to_N v -> + d_ready h2d = true -> + exists ignored sL' sH', + device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some ignored, sL') /\ + device_state_related sH' sL' /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH'. + Proof. + intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. + assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. + revert fuel sH sL H H0 HB. + induction B; intros. + - exfalso. lia. + - destr fuel; cbn [device.runUntilResp]; destruct_one_match; + pose proof (state_machine_write_to_device_write_or_later + _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; + (destruct_one_match; [destruct P as (sH' & R & V) | destruct P as (R & Decr)]). + + (* 0 remaining fuel, valid response: *) + clear -R V. eauto 10. + + (* 0 remaining fuel, no valid response: *) + exfalso. lia. + + (* some remaining fuel, valid response: *) + clear -R V. eauto 10. + + (* some remaining fuel, no valid response *) + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St). + 1: eassumption. 1: exact R. 2: eauto 10. lia. + Qed. + Inductive related: MetricRiscvMachine -> ExtraRiscvMachine D -> Prop := mkRelated: forall regs pc npc m xAddrs (t: list LogItem) t_ignored mc d s, execution t s -> @@ -314,11 +401,15 @@ Section WithParams. | E1: execution _ _, E2: execution _ _ |- _ => pose proof (execution_unique _ _ _ E1 E2); subst; clear E2 end. - 1-4: edestruct state_machine_read_to_device_read as (v'' & d'' & s'' & RU'' & Rel'' & RS''); - [do 2 eexists; match goal with - | H: state_machine.read_step ?n _ _ _ _ |- _ => - change n at 1 with (2 ^ (Nat.log2 n))%nat in H - end; eassumption|solve[eauto]|]. + 1-4: match goal with + | |- context[device.runUntilResp ?p _ _] => + edestruct state_machine_read_to_device_read with (h2d := p) + as (v'' & d'' & s'' & RU'' & Rel'' & RS''); + [do 2 eexists; match goal with + | H: state_machine.read_step ?n _ _ _ _ |- _ => + change n at 1 with (2 ^ (Nat.log2 n))%nat in H + end; eassumption|eassumption|reflexivity..|] + end. 1-4: cbn -[HList.tuple]; tlsimpl; simpl in RU''; rewrite RU''; cbn -[HList.tuple]. 4: { (* 64-bit MMIO is not supported: *) eapply state_machine.read_step_size_valid in HLp2p2. simpl in HLp2p2. exfalso. intuition congruence. @@ -349,13 +440,19 @@ Section WithParams. | E1: execution _ _, E2: execution _ _ |- _ => pose proof (execution_unique _ _ _ E1 E2); subst; clear E2 end. - 1-3: edestruct state_machine_write_to_device_write as (ignored & d' & s'' & RU & Rel' & WS'); - [eexists; match goal with - | H: state_machine.write_step ?n _ _ _ _ |- _ => - change n at 1 with (2 ^ (Nat.log2 n))%nat in H - end; eassumption|solve[eauto]|]. + 1-3: match goal with + | |- context[device.runUntilResp ?p _ _] => + edestruct state_machine_write_to_device_write with (h2d := p) + as (ignored & d' & s'' & RU & Rel' & WS'); + [eexists; match goal with + | H: state_machine.write_step ?n _ _ _ _ |- _ => + change n at 1 with (2 ^ (Nat.log2 n))%nat in H + end; eassumption + |eassumption + |rewrite ? Z_word_N in * by lia; try reflexivity..] + end. 1-3: cbn -[HList.tuple Primitives.invalidateWrittenXAddrs]; - tlsimpl; simpl in RU; rewrite Z_word_N in RU by lia; rewrite RU; + tlsimpl; simpl in RU; rewrite RU; cbn -[HList.tuple Primitives.invalidateWrittenXAddrs]. 1-3: eauto 15 using mkRelated, execution_write_cons, preserve_disjoint_of_invalidateXAddrs. From 0e64bd87069f589105de2e735282aee308bcc676 Mon Sep 17 00:00:00 2001 From: Samuel Gruetter Date: Tue, 9 Nov 2021 19:35:20 -0500 Subject: [PATCH 02/16] sketch hmac_top_invariant and some tlul state machine --- .../end2end/Bedrock2StateMachineToCavaHmac.v | 221 ++++++++++++++++++ silveroak-opentitan/hmac/sw/HmacSemantics.v | 35 ++- 2 files changed, 245 insertions(+), 11 deletions(-) create mode 100644 silveroak-opentitan/hmac/end2end/Bedrock2StateMachineToCavaHmac.v diff --git a/silveroak-opentitan/hmac/end2end/Bedrock2StateMachineToCavaHmac.v b/silveroak-opentitan/hmac/end2end/Bedrock2StateMachineToCavaHmac.v new file mode 100644 index 000000000..18df72856 --- /dev/null +++ b/silveroak-opentitan/hmac/end2end/Bedrock2StateMachineToCavaHmac.v @@ -0,0 +1,221 @@ +(****************************************************************************) +(* Copyright 2021 The Project Oak Authors *) +(* *) +(* Licensed under the Apache License, Version 2.0 (the "License") *) +(* you may not use this file except in compliance with the License. *) +(* You may obtain a copy of the License at *) +(* *) +(* http://www.apache.org/licenses/LICENSE-2.0 *) +(* *) +(* Unless required by applicable law or agreed to in writing, software *) +(* distributed under the License is distributed on an "AS IS" BASIS, *) +(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) +(* See the License for the specific language governing permissions and *) +(* limitations under the License. *) +(****************************************************************************) + +Require Import Coq.Arith.PeanoNat. +Require Import Coq.micromega.Lia. +Require Import Coq.Lists.List. +Require Import Coq.ZArith.ZArith. + +Require Import coqutil.Tactics.Tactics. +Require Import coqutil.Datatypes.Prod. + +Require Import Cava.Util.Byte. +Require Import Cava.Types. +Require Import Cava.Expr. +Require Import Cava.Primitives. +Require Import Cava.TLUL. +Require Import Cava.Invariant. +Require Import Cava.Primitives. +Require Import Cava.Semantics. +Require Import Cava.Expr. +Require Import Cava.ExprProperties. +Require Import Cava.Util.Tactics. +Require Import Cava.Util.List. +Require Import Cava.Util.If. +Require Import Cava.Util.Nat. +Require Import Cava.Util.Byte. +Require Import coqutil.Word.Interface coqutil.Word.Properties. +Require Import coqutil.Word.LittleEndianList. +Require Import HmacHardware.Hmac. +Require Import HmacHardware.Sha256. +Require HmacSoftware.HmacSemantics. + +Import ListNotations. + +Axiom hmac_repr: Type. +(* Note: hmac_repr might/should be an Inductive, so probably no hmac_repr_msg getter will + exists, but we will need to do a match, and assert False in the other cases *) +Axiom hmac_repr_msg: hmac_repr -> list Byte.byte. +Axiom hmac_repr_max_cycles_until_done: hmac_repr -> nat. + +Instance hmac_invariant: invariant_for hmac hmac_repr. Admitted. + +(* TLUL communication state *) +Inductive tlul_protocol_state := +(* host is not interested in talking to device at the moment *) +| HostNotInterested +(* host wants to talk to device and is waiting for device to become ready *) +| HostWaitingForReady(maxDelay: nat) +(* host can and will send a packet in the next cycle *) +| HostCanSend +(* host sent a message to device and is waiting for a reply from device *) +| HostWaitingForReply(packet: tl_h2d)(maxDelay: nat). + +Definition tlul_state_step(s1 s2: tlul_protocol_state): Prop := + match s1 with + | HostNotInterested => + s2 = HostNotInterested \/ + exists maxDelay, s2 = HostWaitingForReady maxDelay + | HostWaitingForReady maxDelay => + (exists maxDelay', maxDelay = S maxDelay' /\ s2 = HostWaitingForReady maxDelay') \/ + s2 = HostCanSend + | HostCanSend => exists packet maxDelay, s2 = HostWaitingForReply packet maxDelay + | HostWaitingForReply packet maxDelay => + (exists maxDelay', maxDelay = S maxDelay' /\ s2 = HostWaitingForReply packet maxDelay') \/ + s2 = HostNotInterested + end. + +Definition a_valid_of_current_tlul_state(s: tlul_protocol_state): bool := + match s with + | HostNotInterested => false + | HostWaitingForReady maxDelay => false + | HostCanSend => true + | HostWaitingForReply packet maxDelay => false + end. + +Definition d_ready_of_current_tlul_state(s: tlul_protocol_state): bool := + match s with + | HostNotInterested => false + | HostWaitingForReady maxDelay => false + | HostCanSend => true + | HostWaitingForReply packet maxDelay => true + end. + +Definition d_valid_of_current_and_next_tlul_state(s1 s2: tlul_protocol_state): bool := + match s1 with + | HostWaitingForReply packet maxDelay => + match s2 with + | HostWaitingForReply packet' maxDelay' => false + | _ => true + end + | _ => false + end. + +(* If the host and device both behave correctly, then each device cycle that takes in + h2d and outputs d2h (ie `step circuit circuit_state1 h2d = (circuit_state2, d2h)`) + corresponds to a transition in the following transition system: *) +Definition tlul_step(s1: tlul_protocol_state)(h2d: tl_h2d) + (s2: tlul_protocol_state)(d2h: tl_d2h): Prop := + a_valid h2d = a_valid_of_current_tlul_state s1 /\ + d_ready h2d = d_ready_of_current_tlul_state s1 /\ + d_valid d2h = d_valid_of_current_and_next_tlul_state s1 s2 /\ + match s1 with + | HostNotInterested => + match s2 with + | HostNotInterested => True + | HostWaitingForReady maxDelay => a_ready d2h = false + | HostCanSend => a_ready d2h = true + | HostWaitingForReply packet maxDelay => False + end + | HostWaitingForReady maxDelay => + match s2 with + | HostNotInterested => False + | HostWaitingForReady maxDelay' => a_ready d2h = false /\ maxDelay = S maxDelay' + | HostCanSend => a_ready d2h = true + | HostWaitingForReply packet maxDelay => False + end + | HostCanSend => + match s2 with + | HostWaitingForReply packet maxDelay => packet = h2d + | _ => False + end + | HostWaitingForReply packet maxDelay => + match s2 with + | HostNotInterested => True + | HostWaitingForReady maxDelay' => a_ready d2h = false + | HostCanSend => a_ready d2h = true + | HostWaitingForReply packet' maxDelay' => packet' = packet /\ maxDelay = S maxDelay' + end + end. + +Section WithParams. + Context {word: word 32} {word_ok: word.ok word}. + + Definition REG_DIGEST_0: nat. + let r := eval unfold HmacHardware.Hmac.REG_DIGEST_0 in HmacHardware.Hmac.REG_DIGEST_0 in + lazymatch r with + | Constant _ ?v => exact (N.to_nat v) + end. + Defined. + + Definition REG_CFG: nat. + let r := eval unfold HmacHardware.Hmac.REG_CFG in HmacHardware.Hmac.REG_CFG in + lazymatch r with + | Constant _ ?v => exact (N.to_nat v) + end. + Defined. + + Definition REG_INTR_STATE: nat := 0. + Definition REG_INTR_ENABLE: nat := 1. + + Definition N_le_word_list_to_byte_list: list N -> list Byte.byte := + List.flat_map (fun n => le_split 4 (Z.of_N n)). + + Definition get_hl_config(regs: list N): HmacSemantics.idle_data := {| + HmacSemantics.intr_enable := word.of_Z (Z.of_N (List.nth REG_INTR_ENABLE regs 0%N)); + HmacSemantics.hmac_done := N.testbit 0 (List.nth REG_INTR_ENABLE regs 0%N); + HmacSemantics.hmac_en := N.testbit 0 (List.nth REG_CFG regs 0%N); + HmacSemantics.sha_en := N.testbit 1 (List.nth REG_CFG regs 0%N); + HmacSemantics.swap_endian := N.testbit 2 (List.nth REG_CFG regs 0%N); + HmacSemantics.swap_digest := N.testbit 3 (List.nth REG_CFG regs 0%N); + |}. + + Instance hmac_top_invariant: invariant_for hmac_top HmacSemantics.state := + fun (circuit_state: denote_type hmac_top_state) (stm_state: HmacSemantics.state) => + let '((wasfull, (d2h, regs)), (tlul_st, hmac_st)) := circuit_state in + exists hmac_r: hmac_repr, hmac_invariant hmac_st hmac_r /\ + match stm_state with + | HmacSemantics.IDLE digest config => + digest = N_le_word_list_to_byte_list (List.firstn 8 (List.skipn REG_DIGEST_0 regs)) /\ + config = get_hl_config regs + | HmacSemantics.CONSUMING buf => + get_hl_config regs = HmacSemantics.sha_default_cfg /\ + hmac_repr_msg hmac_r = buf + | HmacSemantics.PROCESSING buf ncycles => + get_hl_config regs = HmacSemantics.sha_default_cfg /\ + hmac_repr_msg hmac_r = buf /\ + Z.of_nat (hmac_repr_max_cycles_until_done hmac_r) = ncycles + end. + + Instance hmac_top_specification: specification_for hmac_top HmacSemantics.state := {| + reset_repr := HmacSemantics.IDLE (List.repeat Byte.x00 32) HmacSemantics.zero_cfg; + precondition h2d st := True; + update_repr h2d st := + match st with + | HmacSemantics.IDLE digest config => st + | HmacSemantics.CONSUMING buf => st + | HmacSemantics.PROCESSING buf ncycles => st + end; + postcondition h2d st d2h := True; + |}. + + Lemma hmac_top_invariant_at_reset: invariant_at_reset hmac_top. + Admitted. + + Lemma hmac_top_invariant_preserved: invariant_preserved hmac_top. + Proof. + simplify_invariant hmac_top. cbn [absorb_any]. + simplify_spec hmac_top. + intros input state repr new_repr. + Admitted. + + Lemma hmac_top_output_correct: output_correct hmac_top. + Proof. + simplify_invariant hmac_top. simplify_spec hmac_top. + intros input state repr new_repr. + Admitted. + +End WithParams. diff --git a/silveroak-opentitan/hmac/sw/HmacSemantics.v b/silveroak-opentitan/hmac/sw/HmacSemantics.v index 93ea8a241..a4bf505c7 100644 --- a/silveroak-opentitan/hmac/sw/HmacSemantics.v +++ b/silveroak-opentitan/hmac/sw/HmacSemantics.v @@ -50,6 +50,24 @@ Section WithParams. | CONSUMING(sha_buffer: list byte) | PROCESSING(sha_buffer: list byte)(max_cycles_until_done: Z). + Definition sha_default_cfg := {| + hmac_done := false; + intr_enable := word.of_Z 0; + hmac_en := false; + sha_en := true; + swap_endian := true; + swap_digest := false; + |}. + + Definition zero_cfg := {| + hmac_done := false; + intr_enable := word.of_Z 0; + hmac_en := false; + sha_en := false; + swap_endian := false; + swap_digest := false; + |}. + Inductive read_step: nat -> state -> word -> word -> state -> Prop := | read_done_bit_not_done: forall b v n, 0 < n -> @@ -109,17 +127,12 @@ Section WithParams. swap_digest := swap_digest s; |}) | write_hash_start: forall d v, v = word.of_Z (Z.shiftl 1 HMAC_CMD_HASH_START_BIT) -> - write_step 4 (IDLE d (* Here one can see that we only model a subset of the features of - the HMAC module: in our model, starting the computation is only - possible from the specific configuration below. - But using an HMAC module with more features than what we expose - to the software is safe, so modeling only a subset is not a problem. *) - {| hmac_done := false; - intr_enable := word.of_Z 0; - hmac_en := false; - sha_en := true; - swap_endian := true; - swap_digest := false; |}) + (* Here one can see that we only model a subset of the features of + the HMAC module: in our model, starting the computation is only + possible from the sha_default_cfg configuration. + But using an HMAC module with more features than what we expose + to the software is safe, so modeling only a subset is not a problem. *) + write_step 4 (IDLE d sha_default_cfg) (word.of_Z (TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_CMD_REG_OFFSET)) v (CONSUMING []) | write_byte: forall bs bs' v, From 792a6fb6477c373e128a976149f5ef6256bc01d2 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 10 Nov 2021 10:47:09 +0000 Subject: [PATCH 03/16] Fix runUtilResp --- .../InternalMMIOMachine.v | 39 ++++++++++++++----- 1 file changed, 30 insertions(+), 9 deletions(-) diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index 1637f6d4b..a0a64eb2c 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -77,15 +77,36 @@ Module device. where the MMIO read immediately gives a "busy" response, and the software keeps polling until the MMIO read returns a "done" response *) - (* returning None means out of fuel and must not happen if fuel >= device.maxRespDelay *) - Definition runUntilResp{D: device}(h2d: tl_h2d) := - fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := - let '(next, respo) := device.run1 s h2d in - if d_valid respo then (Some respo, next) else - match fuel with - | O => (None, next) - | S fuel' => rec fuel' next - end. + (* returning None means out of fuel and must not happen if fuel >= device.maxRespDelay. + It is also assumed that [a_valid h2d = true] and [d_ready h2d = true]. *) + Definition runUntilResp{D: device}(h2d: tl_h2d)(fuel: nat)(s: device.state) := + let fix receive(fuel: nat)(s: device.state): option tl_d2h * device.state := + let '(next, d2h) := device.run1 s (set_d_ready true tl_h2d_default) in + if d_valid d2h then (Some d2h, next) else + match fuel with + | O => (None, next) + | S fuel' => receive fuel' next + end in + + let fix send(fuel: nat)(s: device.state)(prev_a_ready: bool): option tl_d2h * device.state := + let '(next, d2h) := device.run1 s h2d in + if prev_a_ready then + if d_valid d2h then (Some d2h, next) else + match fuel with + | O => (None, next) + | S fuel' => receive fuel' next + end + else + match fuel with + | O => (None, next) + | S fuel' => send fuel' next (a_ready d2h) + end in + + (* As we don't know yet if the device is listening (on channel A), we have + to send an empty h2d packet first. Perhaps we should keep track of the + last a_ready value so we don't have to do this? *) + let '(next, d2h) := device.run1 s tl_h2d_default in + send fuel next (a_ready d2h). Section WithWordAndDevice. Context {word: Interface.word.word 32} {word_ok: word.ok word} {D: device}. From 10a88adf76d1a80d0b1f6c151856506807de3ffd Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 11 Nov 2021 13:52:06 +0000 Subject: [PATCH 04/16] wip --- .../InternalMMIOMachine.v | 54 ++++++------ .../RiscvMachineWithCavaDevice/MMIOToCava.v | 84 +++++++++++++++++-- 2 files changed, 105 insertions(+), 33 deletions(-) diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index a0a64eb2c..f738d3205 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -54,6 +54,17 @@ Module device. includes Cava.Core.Circuit.reset_state *) is_ready_state: state -> Prop; + (* the d2h output the device produced when it transitioned to the state *) + (* TODO: probably need to add to [device_implements_state_machine] somthing like + [forall s h2d d2h s', run1 s h2d = (s', d2h) -> last_d2h s' = d2h] *) + last_d2h: state -> tl_d2h; + + (* indicates an inflight operation: the device received a request on channel + A, but a response on channel D hasn't been exchanged yet *) + (* TODO: probably need to add to [device_implements_state_machine] somthing like + [forall s, is_ready_state s -> tl_inflight_ops s = []] *) + tl_inflight_ops: state -> list N; + (* run one simulation step, will be instantiated with Cava.Semantics.Combinational.step *) run1: (* input: TileLink host-2-device *) state -> tl_h2d -> @@ -77,36 +88,31 @@ Module device. where the MMIO read immediately gives a "busy" response, and the software keeps polling until the MMIO read returns a "done" response *) + Definition waitForResp{D: device} := + fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := + let '(next, d2h) := device.run1 s (set_d_ready true tl_h2d_default) in + if d_valid d2h then (Some d2h, next) else + match fuel with + | O => (None, next) + | S fuel' => rec fuel' next + end. + (* returning None means out of fuel and must not happen if fuel >= device.maxRespDelay. It is also assumed that [a_valid h2d = true] and [d_ready h2d = true]. *) - Definition runUntilResp{D: device}(h2d: tl_h2d)(fuel: nat)(s: device.state) := - let fix receive(fuel: nat)(s: device.state): option tl_d2h * device.state := - let '(next, d2h) := device.run1 s (set_d_ready true tl_h2d_default) in + Definition runUntilResp{D: device}(h2d: tl_h2d) := + fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := + let '(next, d2h) := device.run1 s h2d in + if a_ready (device.last_d2h s) then if d_valid d2h then (Some d2h, next) else match fuel with | O => (None, next) - | S fuel' => receive fuel' next - end in - - let fix send(fuel: nat)(s: device.state)(prev_a_ready: bool): option tl_d2h * device.state := - let '(next, d2h) := device.run1 s h2d in - if prev_a_ready then - if d_valid d2h then (Some d2h, next) else - match fuel with - | O => (None, next) - | S fuel' => receive fuel' next + | S fuel' => waitForResp fuel' next end - else - match fuel with - | O => (None, next) - | S fuel' => send fuel' next (a_ready d2h) - end in - - (* As we don't know yet if the device is listening (on channel A), we have - to send an empty h2d packet first. Perhaps we should keep track of the - last a_ready value so we don't have to do this? *) - let '(next, d2h) := device.run1 s tl_h2d_default in - send fuel next (a_ready d2h). + else + match fuel with + | O => (None, next) + | S fuel' => rec fuel' next + end. Section WithWordAndDevice. Context {word: Interface.word.word 32} {word_ok: word.ok word} {D: device}. diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index 62e52a7d9..49938f3d8 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -61,6 +61,8 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte we will get a response matching some possible high-level read step's response, but not necessarily the one we used to show that sH accepts reads (to allow underspecification-nondeterminism in the high-level state machine) *) + + (* TODO: replace the length clauses with [In (a_source h2d) (device.tl_inflight_ops sL)] *) state_machine_read_to_device_read_or_later: forall log2_nbytes r sH sL sL' h2d d2h, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL -> @@ -69,14 +71,38 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> d_ready h2d = true -> + List.length (device.tl_inflight_ops sL) = 0%nat -> + device.run1 sL h2d = (sL', d2h) -> + if a_ready (device.last_d2h sL) then + if d_valid d2h then + exists sH', + device_state_related sH' sL' /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat + else + device_state_related sH sL' /\ + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + List.length (device.tl_inflight_ops sL') = 1%nat + else + device_state_related sH sL' /\ + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + List.length (device.tl_inflight_ops sL') = 0%nat; + + state_machine_read_to_device_read_or_later_wait: forall log2_nbytes r sH sL sL' h2d d2h, + (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> + device_state_related sH sL -> + d_ready h2d = true -> + List.length (device.tl_inflight_ops sL) = 1%nat -> device.run1 sL h2d = (sL', d2h) -> if d_valid d2h then exists sH', device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat; + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + List.length (device.tl_inflight_ops sL') = 1%nat; (* for each high-level state sH in which an n-byte write to register r with value v is possible, if we run the low-level device with the write step's address and value on the input wires, @@ -94,14 +120,38 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> d_ready h2d = true -> + List.length (device.tl_inflight_ops sL) = 0%nat -> + device.run1 sL h2d = (sL', d2h) -> + if a_ready (device.last_d2h sL) then + if d_valid d2h then + exists sH', + device_state_related sH' sL' /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat + else + device_state_related sH sL' /\ + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + List.length (device.tl_inflight_ops sL') = 1%nat + else + device_state_related sH sL' /\ + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + List.length (device.tl_inflight_ops sL') = 0%nat; + + state_machine_write_to_device_write_or_later_wait: forall log2_nbytes r v sH sL sL' h2d d2h, + (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> + device_state_related sH sL -> + d_ready h2d = true -> + List.length (device.tl_inflight_ops sL) = 1%nat -> device.run1 sL h2d = (sL', d2h) -> if d_valid d2h then exists sH', device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH' + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat; + (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + List.length (device.tl_inflight_ops sL') = 1%nat; (* If two steps starting in the same high-level state agree on what gets appended to the trace, then the resulting high-level states must be equal. @@ -146,20 +196,36 @@ Section WithParams. a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> d_ready h2d = true -> + List.length (device.tl_inflight_ops sL) = 0%nat -> exists d2h sL' sH', device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some d2h, sL') /\ device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'. + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ + List.length (device.tl_inflight_ops sL) = 0%nat. Proof. intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. - revert fuel sH sL H H0 HB. + (* revert H6. *) + (* match goal with *) + (* | |- (?l = 0%nat) -> (exists i1 i2 i3, and ?c1 (and ?c2 (and ?c3 ?c4))) => *) + (* apply proj1 with *) + (* (B:=(l = 1%nat) -> *) + (* (exists (i1 : tl_d2h) (i2 : D) (i3 : M), and c1 (and c2 (and c3 c4)))) *) + (* end. *) + revert fuel sH sL H H0 HB H6. induction B; intros. - exfalso. lia. - - destr fuel; cbn [device.runUntilResp]; destruct_one_match; + - destr fuel; cbn [device.runUntilResp]; do 1 destruct_one_match; + (* destruct (a_ready t). *) pose proof (state_machine_read_to_device_read_or_later - _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 E) as P; - (destruct_one_match; [destruct P as (sH' & R & V) | destruct P as (R & Decr)]). + _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P. + + do 1 destruct_one_match. + * do 1 destruct_one_match. + -- destruct P as (sH' & R & V & L). + repeat eexists; try reflexivity; try apply R; try assumption. + -- destruct P as (R & Decr & L). + * + (do 2 destruct_one_match; [destruct P as (sH' & R & V) | destruct P as (R & Decr)]). + (* 0 remaining fuel, valid response: *) clear -R V. eauto 10. + (* 0 remaining fuel, no valid response: *) From f6eda541085d6c0fe9bb2278691c86d06fc98f56 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 11 Nov 2021 20:28:39 +0000 Subject: [PATCH 05/16] Proved state_machine_read_to_device_read --- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 103 ++++++++++++------ 1 file changed, 70 insertions(+), 33 deletions(-) diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index 49938f3d8..c5b0eab6a 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -81,19 +81,18 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL h2d)%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat else device_state_related sH sL' /\ (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ List.length (device.tl_inflight_ops sL') = 0%nat; - state_machine_read_to_device_read_or_later_wait: forall log2_nbytes r sH sL sL' h2d d2h, + state_machine_read_to_device_read_or_later_wait: forall log2_nbytes r sH sL sL' d2h, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL -> - d_ready h2d = true -> List.length (device.tl_inflight_ops sL) = 1%nat -> - device.run1 sL h2d = (sL', d2h) -> + device.run1 sL (set_d_ready true tl_h2d_default) = (sL', d2h) -> if d_valid d2h then exists sH', device_state_related sH' sL' /\ @@ -101,7 +100,7 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL (set_d_ready true tl_h2d_default))%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat; (* for each high-level state sH in which an n-byte write to register r with value v is possible, @@ -188,6 +187,49 @@ Section WithParams. and the response will match some possible high-level read step's response, but not necessarily the one we used to show that sH accepts reads (to allow underspecification-nondeterminism in the high-level state machine) *) + Lemma state_machine_read_to_device_read_wait: forall log2_nbytes r sH sL, + (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> + device_state_related sH sL -> + List.length (device.tl_inflight_ops sL) = 1%nat -> + exists d2h sL' sH', + device.waitForResp (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) sL = (Some d2h, sL') /\ + device_state_related sH' sL' /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat. + Proof. + intros. remember (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) as fuel. + remember (S fuel) as B. + assert (device.maxRespDelay sL (set_d_ready true tl_h2d_default) <= fuel < B)%nat as HB by lia. + clear HeqB Heqfuel. + revert fuel sH sL H H0 H1 HB. + induction B; intros. + - exfalso. lia. + - destr fuel; cbn [device.waitForResp]; destruct_one_match; + pose proof (state_machine_read_to_device_read_or_later_wait + _ _ _ _ _ _ H H0 H1 E) as P; + destruct_one_match. + + destruct P as (sH' & R & V & L). eauto 10. + + exfalso. lia. + + destruct P as (sH' & R & V & L). eauto 10. + + destruct P as (R & Decl & L). + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St & Ln); + try eassumption. 2: eauto 10. lia. + Qed. + + Lemma waitForResp_mono : forall (fuel fuel' : nat) s d2h s', + (fuel <= fuel')%nat -> + device.waitForResp fuel s = (Some d2h, s') -> + device.waitForResp fuel' s = (Some d2h, s'). + Proof. + intros ? ?. revert fuel. induction fuel'; intros; inversion H; subst; auto. + cbn [device.waitForResp]. + destruct_one_match. destruct_tl_d2h. tlsimpl. + destruct d_valid. + - destruct fuel; cbn in H0; rewrite E in H0; cbn in H0; assumption. + - destruct fuel; cbn in H0; rewrite E in H0; cbn in H0; try discriminate. + eapply IHfuel' with (fuel:=fuel); auto. lia. + Qed. + Lemma state_machine_read_to_device_read: forall log2_nbytes r sH sL h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL -> @@ -201,40 +243,35 @@ Section WithParams. device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some d2h, sL') /\ device_state_related sH' sL' /\ state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ - List.length (device.tl_inflight_ops sL) = 0%nat. + List.length (device.tl_inflight_ops sL') = 0%nat. Proof. intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. - (* revert H6. *) - (* match goal with *) - (* | |- (?l = 0%nat) -> (exists i1 i2 i3, and ?c1 (and ?c2 (and ?c3 ?c4))) => *) - (* apply proj1 with *) - (* (B:=(l = 1%nat) -> *) - (* (exists (i1 : tl_d2h) (i2 : D) (i3 : M), and c1 (and c2 (and c3 c4)))) *) - (* end. *) revert fuel sH sL H H0 HB H6. induction B; intros. - exfalso. lia. - - destr fuel; cbn [device.runUntilResp]; do 1 destruct_one_match; - (* destruct (a_ready t). *) - pose proof (state_machine_read_to_device_read_or_later - _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P. - + do 1 destruct_one_match. - * do 1 destruct_one_match. - -- destruct P as (sH' & R & V & L). - repeat eexists; try reflexivity; try apply R; try assumption. - -- destruct P as (R & Decr & L). - * - (do 2 destruct_one_match; [destruct P as (sH' & R & V) | destruct P as (R & Decr)]). - + (* 0 remaining fuel, valid response: *) - clear -R V. eauto 10. - + (* 0 remaining fuel, no valid response: *) - exfalso. lia. - + (* some remaining fuel, valid response: *) - clear -R V. eauto 10. - + (* some remaining fuel, no valid response *) - edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St). - 1: eassumption. 1: exact R. 2: eauto 10. lia. + - destr fuel; cbn [device.runUntilResp]; destruct_one_match; + pose proof (state_machine_read_to_device_read_or_later + _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; + repeat destruct_one_match. + + (* 0 remaining fuel, device ready, valid response: *) + destruct P as (sH' & R & V & L). eauto 10. + + (* 0 remaining fuel, device ready, no valid response: *) + destruct P as (R & Decr & L). exfalso. lia. + + (* 0 remaining fuel, device not ready: *) + destruct P as (R & Decr & L). exfalso. lia. + + + (* some remaining fuel, device ready, valid response: *) + destruct P as (sH' & R & V & L). eauto 10. + + (* some remaining fuel, device ready, no valid response: *) + destruct P as (R & Decr & L). + pose proof (state_machine_read_to_device_read_wait + _ _ _ _ H R L) as (d2h & sL'' & sH'' & W' & R' & V' & L'). + eapply waitForResp_mono in W'. 1: eauto 10. lia. + + (* some remaining fuel, device not ready: *) + destruct P as (R & Decr & L). + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); + try eassumption. 2: eauto 10. lia. Qed. (* for each high-level state sH in which an n-byte write to register r with value v is possible, From cd2c42ee687e6e8fd3b1373f22cfc275f57e048f Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Fri, 12 Nov 2021 10:47:26 +0000 Subject: [PATCH 06/16] Add the proofs for the write case Note that some proofs are Admitted because I'm not sure how to handle tl_inflight_ops --- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 112 +++++++++++------- 1 file changed, 71 insertions(+), 41 deletions(-) diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index c5b0eab6a..e5d0e7c0d 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -129,19 +129,18 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL h2d)%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat else device_state_related sH sL' /\ (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ List.length (device.tl_inflight_ops sL') = 0%nat; - state_machine_write_to_device_write_or_later_wait: forall log2_nbytes r v sH sL sL' h2d d2h, + state_machine_write_to_device_write_or_later_wait: forall log2_nbytes r v sH sL sL' d2h, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL -> - d_ready h2d = true -> List.length (device.tl_inflight_ops sL) = 1%nat -> - device.run1 sL h2d = (sL', d2h) -> + device.run1 sL (set_d_ready true tl_h2d_default) = (sL', d2h) -> if d_valid d2h then exists sH', device_state_related sH' sL' /\ @@ -149,7 +148,7 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL (set_d_ready true tl_h2d_default))%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat; (* If two steps starting in the same high-level state agree on what gets appended to the trace, @@ -207,12 +206,37 @@ Section WithParams. - destr fuel; cbn [device.waitForResp]; destruct_one_match; pose proof (state_machine_read_to_device_read_or_later_wait _ _ _ _ _ _ H H0 H1 E) as P; - destruct_one_match. - + destruct P as (sH' & R & V & L). eauto 10. + (destruct_one_match; [destruct P as (sH' & R & V & L); eauto 10 | + destruct P as (R & Decl & L)]). + exfalso. lia. - + destruct P as (sH' & R & V & L). eauto 10. - + destruct P as (R & Decl & L). - edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St & Ln); + + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St & Ln); + try eassumption. 2: eauto 10. lia. + Qed. + + Lemma state_machine_write_to_device_write_wait: forall log2_nbytes r v sH sL, + (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> + device_state_related sH sL -> + List.length (device.tl_inflight_ops sL) = 1%nat -> + exists d2h sL' sH', + device.waitForResp (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) sL = (Some d2h, sL') /\ + device_state_related sH' sL' /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat. + Proof. + intros. remember (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) as fuel. + remember (S fuel) as B. + assert (device.maxRespDelay sL (set_d_ready true tl_h2d_default) <= fuel < B)%nat as HB by lia. + clear HeqB Heqfuel. + revert fuel sH sL H H0 H1 HB. + induction B; intros. + - exfalso. lia. + - destr fuel; cbn [device.waitForResp]; destruct_one_match; + pose proof (state_machine_write_to_device_write_or_later_wait + _ _ _ _ _ _ _ H H0 H1 E) as P; + (destruct_one_match; [destruct P as (sH' & R & V & L); eauto 10 | + destruct P as (R & Decl & L)]). + + exfalso. lia. + + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St & Ln); try eassumption. 2: eauto 10. lia. Qed. @@ -222,12 +246,11 @@ Section WithParams. device.waitForResp fuel' s = (Some d2h, s'). Proof. intros ? ?. revert fuel. induction fuel'; intros; inversion H; subst; auto. - cbn [device.waitForResp]. - destruct_one_match. destruct_tl_d2h. tlsimpl. - destruct d_valid. - - destruct fuel; cbn in H0; rewrite E in H0; cbn in H0; assumption. - - destruct fuel; cbn in H0; rewrite E in H0; cbn in H0; try discriminate. - eapply IHfuel' with (fuel:=fuel); auto. lia. + cbn [device.waitForResp]. destruct_one_match. + destruct (d_valid t) eqn:Ed_valid; + destruct fuel; cbn [device.waitForResp] in H0; rewrite E, Ed_valid in H0; + try assumption; try discriminate. + eapply IHfuel' with (fuel:=fuel); [lia|auto]. Qed. Lemma state_machine_read_to_device_read: forall log2_nbytes r sH sL h2d, @@ -253,23 +276,21 @@ Section WithParams. - destr fuel; cbn [device.runUntilResp]; destruct_one_match; pose proof (state_machine_read_to_device_read_or_later _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; - repeat destruct_one_match. + (repeat destruct_one_match; [destruct P as (sH' & R & V & L) | + destruct P as (R & Decr & L) ..]). + (* 0 remaining fuel, device ready, valid response: *) - destruct P as (sH' & R & V & L). eauto 10. + eauto 10. + (* 0 remaining fuel, device ready, no valid response: *) - destruct P as (R & Decr & L). exfalso. lia. + exfalso. lia. + (* 0 remaining fuel, device not ready: *) - destruct P as (R & Decr & L). exfalso. lia. - + exfalso. lia. + (* some remaining fuel, device ready, valid response: *) - destruct P as (sH' & R & V & L). eauto 10. + eauto 10. + (* some remaining fuel, device ready, no valid response: *) - destruct P as (R & Decr & L). pose proof (state_machine_read_to_device_read_wait _ _ _ _ H R L) as (d2h & sL'' & sH'' & W' & R' & V' & L'). eapply waitForResp_mono in W'. 1: eauto 10. lia. + (* some remaining fuel, device not ready: *) - destruct P as (R & Decr & L). edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. @@ -288,29 +309,38 @@ Section WithParams. a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> d_ready h2d = true -> + List.length (device.tl_inflight_ops sL) = 0%nat -> exists ignored sL' sH', device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some ignored, sL') /\ device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH'. + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ + List.length (device.tl_inflight_ops sL') = 0%nat. Proof. intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. - revert fuel sH sL H H0 HB. + revert fuel sH sL H H0 HB H7. induction B; intros. - exfalso. lia. - destr fuel; cbn [device.runUntilResp]; destruct_one_match; pose proof (state_machine_write_to_device_write_or_later - _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; - (destruct_one_match; [destruct P as (sH' & R & V) | destruct P as (R & Decr)]). - + (* 0 remaining fuel, valid response: *) - clear -R V. eauto 10. - + (* 0 remaining fuel, no valid response: *) + _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 H7 E) as P; + (repeat destruct_one_match; [destruct P as (sH' & R & V & L) | + destruct P as (R & Decr & L) ..]). + + (* 0 remaining fuel, device ready, valid response: *) + eauto 10. + + (* 0 remaining fuel, device ready, no valid response: *) exfalso. lia. - + (* some remaining fuel, valid response: *) - clear -R V. eauto 10. - + (* some remaining fuel, no valid response *) - edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St). - 1: eassumption. 1: exact R. 2: eauto 10. lia. + + (* 0 remaining fuel, device not ready: *) + exfalso. lia. + + (* some remaining fuel, device ready, valid response: *) + clear -R V L. eauto 10. + + (* some remaining fuel, device ready, no valid response: *) + pose proof (state_machine_write_to_device_write_wait + _ _ _ _ _ H R L) as (d2h & sL'' & sH'' & W' & R' & V' & L'). + eapply waitForResp_mono in W'. 1: eauto 10. lia. + + (* some remaining fuel, device not ready *) + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); + try eassumption. 2: eauto 10. lia. Qed. Inductive related: MetricRiscvMachine -> ExtraRiscvMachine D -> Prop := @@ -507,11 +537,11 @@ Section WithParams. 1-4: match goal with | |- context[device.runUntilResp ?p _ _] => edestruct state_machine_read_to_device_read with (h2d := p) - as (v'' & d'' & s'' & RU'' & Rel'' & RS''); + as (v'' & d'' & s'' & RU'' & Rel'' & RS'' & Len''); [do 2 eexists; match goal with | H: state_machine.read_step ?n _ _ _ _ |- _ => change n at 1 with (2 ^ (Nat.log2 n))%nat in H - end; eassumption|eassumption|reflexivity..|] + end; eassumption|eassumption|reflexivity..|admit|] end. 1-4: cbn -[HList.tuple]; tlsimpl; simpl in RU''; rewrite RU''; cbn -[HList.tuple]. 4: { (* 64-bit MMIO is not supported: *) @@ -546,13 +576,13 @@ Section WithParams. 1-3: match goal with | |- context[device.runUntilResp ?p _ _] => edestruct state_machine_write_to_device_write with (h2d := p) - as (ignored & d' & s'' & RU & Rel' & WS'); + as (ignored & d' & s'' & RU & Rel' & WS' & Len'); [eexists; match goal with | H: state_machine.write_step ?n _ _ _ _ |- _ => change n at 1 with (2 ^ (Nat.log2 n))%nat in H end; eassumption |eassumption - |rewrite ? Z_word_N in * by lia; try reflexivity..] + |rewrite ? Z_word_N in * by lia; reflexivity..|admit|] end. 1-3: cbn -[HList.tuple Primitives.invalidateWrittenXAddrs]; tlsimpl; simpl in RU; rewrite RU; @@ -567,7 +597,7 @@ Section WithParams. (* EndCycleNormal *) { unfold Monads.OStateOperations.put. eauto 10 using mkRelated. } - Qed. + Admitted. Lemma stateMachine_free_to_cava{A: Type}: forall (p: free riscv_primitive primitive_result A) (initialH: MetricRiscvMachine) From b66ab0cfe49a9b34bacd4ebed2bdbef07e6c699d Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Fri, 12 Nov 2021 15:08:03 +0000 Subject: [PATCH 07/16] maxRespDelat doesn't take h2d --- .../InternalMMIOMachine.v | 4 +-- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 36 +++++++++---------- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index f738d3205..eb039049e 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -79,7 +79,7 @@ Module device. (* max number of device cycles this device takes to serve read/write requests, ie max number of run1 calls with active read/write request until the device responds *) - maxRespDelay: state -> tl_h2d -> nat; + maxRespDelay: state -> nat; }. (* Note: there are two levels of "polling until a response is available": - on the hardware level, using runUntilResp, which appears as @@ -177,7 +177,7 @@ Section WithParams. OState (ExtraRiscvMachine D) word := mach <- get; let (respo, new_device_state) := - device.runUntilResp h2d (device.maxRespDelay mach.(getExtraState) h2d) + device.runUntilResp h2d (device.maxRespDelay mach.(getExtraState)) mach.(getExtraState) in put (withExtraState new_device_state mach);; resp <- fail_if_None respo; diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index e5d0e7c0d..bca98e6ae 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -81,11 +81,11 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ List.length (device.tl_inflight_ops sL') = 0%nat; state_machine_read_to_device_read_or_later_wait: forall log2_nbytes r sH sL sL' d2h, @@ -100,7 +100,7 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL (set_d_ready true tl_h2d_default))%nat /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat; (* for each high-level state sH in which an n-byte write to register r with value v is possible, @@ -129,11 +129,11 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' h2d < device.maxRespDelay sL h2d)%nat /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ List.length (device.tl_inflight_ops sL') = 0%nat; state_machine_write_to_device_write_or_later_wait: forall log2_nbytes r v sH sL sL' d2h, @@ -148,7 +148,7 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte List.length (device.tl_inflight_ops sL') = 0%nat else device_state_related sH sL' /\ - (device.maxRespDelay sL' (set_d_ready true tl_h2d_default) < device.maxRespDelay sL (set_d_ready true tl_h2d_default))%nat /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ List.length (device.tl_inflight_ops sL') = 1%nat; (* If two steps starting in the same high-level state agree on what gets appended to the trace, @@ -191,14 +191,14 @@ Section WithParams. device_state_related sH sL -> List.length (device.tl_inflight_ops sL) = 1%nat -> exists d2h sL' sH', - device.waitForResp (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) sL = (Some d2h, sL') /\ + device.waitForResp (device.maxRespDelay sL) sL = (Some d2h, sL') /\ device_state_related sH' sL' /\ state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ List.length (device.tl_inflight_ops sL') = 0%nat. Proof. - intros. remember (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) as fuel. + intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. - assert (device.maxRespDelay sL (set_d_ready true tl_h2d_default) <= fuel < B)%nat as HB by lia. + assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. revert fuel sH sL H H0 H1 HB. induction B; intros. @@ -218,14 +218,14 @@ Section WithParams. device_state_related sH sL -> List.length (device.tl_inflight_ops sL) = 1%nat -> exists d2h sL' sH', - device.waitForResp (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) sL = (Some d2h, sL') /\ + device.waitForResp (device.maxRespDelay sL) sL = (Some d2h, sL') /\ device_state_related sH' sL' /\ state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ List.length (device.tl_inflight_ops sL') = 0%nat. Proof. - intros. remember (device.maxRespDelay sL (set_d_ready true tl_h2d_default)) as fuel. + intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. - assert (device.maxRespDelay sL (set_d_ready true tl_h2d_default) <= fuel < B)%nat as HB by lia. + assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. revert fuel sH sL H H0 H1 HB. induction B; intros. @@ -263,13 +263,13 @@ Section WithParams. d_ready h2d = true -> List.length (device.tl_inflight_ops sL) = 0%nat -> exists d2h sL' sH', - device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some d2h, sL') /\ + device.runUntilResp h2d (device.maxRespDelay sL) sL = (Some d2h, sL') /\ device_state_related sH' sL' /\ state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ List.length (device.tl_inflight_ops sL') = 0%nat. Proof. - intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. - assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. + intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. + assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. revert fuel sH sL H H0 HB H6. induction B; intros. - exfalso. lia. @@ -311,13 +311,13 @@ Section WithParams. d_ready h2d = true -> List.length (device.tl_inflight_ops sL) = 0%nat -> exists ignored sL' sH', - device.runUntilResp h2d (device.maxRespDelay sL h2d) sL = (Some ignored, sL') /\ + device.runUntilResp h2d (device.maxRespDelay sL) sL = (Some ignored, sL') /\ device_state_related sH' sL' /\ state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ List.length (device.tl_inflight_ops sL') = 0%nat. Proof. - intros. remember (device.maxRespDelay sL h2d) as fuel. remember (S fuel) as B. - assert (device.maxRespDelay sL h2d <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. + intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. + assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. revert fuel sH sL H H0 HB H7. induction B; intros. - exfalso. lia. From 049df723881a7143c4e8a137bef1aee5aa311ffe Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 30 Oct 2021 12:09:00 +0100 Subject: [PATCH 08/16] New TLUL spec --- cava2/TLUL.v | 321 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 205 insertions(+), 116 deletions(-) diff --git a/cava2/TLUL.v b/cava2/TLUL.v index 2561b35e1..c4fe28f33 100644 --- a/cava2/TLUL.v +++ b/cava2/TLUL.v @@ -17,6 +17,8 @@ Require Import Coq.Lists.List. Require Import Coq.ZArith.ZArith. +Import ListNotations. + Require Import Cava.Expr. Require Import Cava.ExprProperties. Require Import Cava.Invariant. @@ -351,28 +353,28 @@ Section TLULSpec. | OutstandingGet (reqid : N) (reqsz : N) | OutstandingPutFullData (reqid : N). - Definition tlul_repr := option TLULState. - Compute denote_type (input_of tlul_adapter_reg). + Fixpoint outstanding_h2d (inputs : list tl_h2d) := + match inputs with + | [] => None + | h :: tl => + match outstanding_h2d tl with + | None => if a_valid h then Some h else None + | Some h' => if d_ready h then None else Some h' + end + end. + + Definition tlul_repr := list tl_h2d. + Instance tlul_specification : specification_for (tlul_adapter_reg (reg_count:=reg_count)) tlul_repr := - {| reset_repr := None; + {| reset_repr := []; update_repr := fun (input : denote_type (input_of (tlul_adapter_reg (reg_count:=reg_count)))) (repr : tlul_repr) => let '(h2d, (_regs, tt)) := input in - match repr with - | None => - if a_valid h2d then - if a_opcode h2d =? Get then - Some (OutstandingGet (a_source h2d) (a_size h2d)) - else if a_opcode h2d =? PutFullData then - Some (OutstandingPutFullData (a_source h2d)) - else (* unrechable *) repr - else None - | Some _ => if d_ready h2d then None else repr - end; + h2d :: repr; precondition := fun (input : denote_type (input_of tlul_adapter_reg)) @@ -386,22 +388,11 @@ Section TLULSpec. fun (input : denote_type (input_of (tlul_adapter_reg (reg_count:=reg_count)))) (repr : tlul_repr) (output : denote_type (output_of (tlul_adapter_reg (reg_count:=reg_count)))) => - exists h2d regs d2h io_re io_we io_address io_data io_mask repr', + exists h2d regs d2h io_re io_we io_address io_data io_mask, input = (h2d, (regs, tt)) - /\ repr' = - match repr with - | None => - if a_valid h2d then - if a_opcode h2d =? Get then - Some (OutstandingGet (a_source h2d) (a_size h2d)) - else if a_opcode h2d =? PutFullData then - Some (OutstandingPutFullData (a_source h2d)) - else (* unrechable *) repr - else None - | Some _ => if d_ready h2d then None else repr - end /\ output = (d2h, (io_re, (io_we, (io_address, (io_data, io_mask))))) - /\ match repr' with + + /\ match outstanding_h2d (h2d :: repr) with | None => d_valid d2h = false /\ d_param d2h = 0 @@ -412,64 +403,67 @@ Section TLULSpec. /\ io_re = false /\ io_we = false - | Some (OutstandingGet reqid reqsz) => - d_valid d2h = true - /\ d_opcode d2h = AccessAckData - /\ d_param d2h = 0 - /\ d_size d2h = reqsz - /\ d_source d2h = reqid - /\ d_sink d2h = 0 - /\ d_data d2h = List.nth (N.to_nat (((a_address h2d / 4) mod (2 ^ 30)))) regs 0%N - /\ d_user d2h = 0 - /\ d_error d2h = false - /\ a_ready d2h = false - /\ match repr with - | None => if a_valid h2d then - io_re = true - /\ io_address = a_address h2d - else True - | _ => True - end - /\ io_we = false - - | Some (OutstandingPutFullData reqid) => - d_valid d2h = true - /\ d_opcode d2h = AccessAck - /\ d_param d2h = 0 - (* /\ d_size d2h = *) - /\ d_source d2h = reqid - /\ d_sink d2h = 0 - /\ d_user d2h = 0 - /\ d_error d2h = false - /\ a_ready d2h = false - /\ io_re = false - /\ match repr with - | None => if a_valid h2d then - io_we = true - /\ io_address = a_address h2d - /\ io_data = a_data h2d - /\ io_mask = a_mask h2d - else True - | _ => True - end + | Some h2d' => + if a_opcode h2d' =? Get then + d_valid d2h = true + /\ d_opcode d2h = AccessAckData + /\ d_param d2h = 0 + /\ d_size d2h = a_size h2d' + /\ d_source d2h = a_source h2d' + /\ d_sink d2h = 0 + /\ d_data d2h = List.nth (N.to_nat (((a_address h2d / 4) mod (2 ^ 30)))) regs 0%N + /\ d_user d2h = 0 + /\ d_error d2h = false + /\ a_ready d2h = false + /\ match outstanding_h2d repr with + | None => if a_valid h2d then + io_re = true + /\ io_address = a_address h2d + else True + | _ => True + end + /\ io_we = false + else if a_opcode h2d' =? PutFullData then + d_valid d2h = true + /\ d_opcode d2h = AccessAck + /\ d_param d2h = 0 + (* /\ d_size d2h = *) + /\ d_source d2h = a_source h2d' + /\ d_sink d2h = 0 + /\ d_user d2h = 0 + /\ d_error d2h = false + /\ a_ready d2h = false + /\ io_re = false + /\ match outstanding_h2d repr with + | None => if a_valid h2d then + io_we = true + /\ io_address = a_address h2d + /\ io_data = a_data h2d + /\ io_mask = a_mask h2d + else True + | _ => True + end + else True end |}. Global Instance tlul_invariant : invariant_for (tlul_adapter_reg (reg_count:=reg_count)) tlul_repr := fun (state : denote_type (state_of tlul_adapter_reg)) repr => tlul_adapter_reg_state_error state = false - /\ match repr with + /\ match outstanding_h2d repr with | None => tlul_adapter_reg_state_outstanding (reg_count:=reg_count) state = false - | Some (OutstandingGet reqid reqsz) => - tlul_adapter_reg_state_outstanding state = true - /\ tlul_adapter_reg_state_reqid state = reqid - /\ tlul_adapter_reg_state_reqsz state = reqsz - /\ tlul_adapter_reg_state_rspop state = AccessAckData - | Some (OutstandingPutFullData reqid) => - tlul_adapter_reg_state_outstanding state = true - /\ tlul_adapter_reg_state_reqid state = reqid - /\ tlul_adapter_reg_state_rspop state = AccessAck + | Some h2d => + if a_opcode h2d =? Get then + tlul_adapter_reg_state_outstanding state = true + /\ tlul_adapter_reg_state_reqid state = a_source h2d + /\ tlul_adapter_reg_state_reqsz state = a_size h2d + /\ tlul_adapter_reg_state_rspop state = AccessAckData + else if a_opcode h2d =? PutFullData then + tlul_adapter_reg_state_outstanding state = true + /\ tlul_adapter_reg_state_reqid state = a_source h2d + /\ tlul_adapter_reg_state_rspop state = AccessAck + else False end. Lemma tlul_adapter_reg_invariant_at_reset : invariant_at_reset tlul_adapter_reg. @@ -488,24 +482,65 @@ Section TLULSpec. intros; subst. simplify_invariant (tlul_adapter_reg (reg_count:=reg_count)). simplify_spec (tlul_adapter_reg (reg_count:=reg_count)). - cbv [tlul_adapter_reg]. stepsimpl. logical_simplify. + cbv [tlul_adapter_reg]. + stepsimpl. tlul_adapter_reg_state_simpl. tlsimpl. + logical_simplify. match goal with | h : reg_count = _ |- _ => clear h end. repeat (destruct_pair_let; cbn [fst snd]). - destruct repr as [[|]|]; [| |]. - 1-2: (* repr = Some _ *) - logical_simplify; subst; - tlul_adapter_reg_state_simpl; boolsimpl; cbn [fst snd]; - destruct d_ready0; ssplit; reflexivity. - (* repr = None *) - subst. tlul_adapter_reg_state_simpl. boolsimpl. - destruct a_valid0; - try match goal with - | h: true = true -> _ |- _ => destruct h; subst - end; - cbn; ssplit; reflexivity. + tlul_adapter_reg_state_simpl. + split. + - destruct (a_valid0 && negb outstanding)%bool; subst; reflexivity. + - remember (outstanding_h2d + ((a_valid0, + (a_opcode0, + (a_param0, (a_size0, (a_source0, (a_address0, (a_mask0, (a_data0, (a_user0, d_ready0))))))))) :: repr)) as outs eqn:Eouts. + destruct outs; subst. + + simpl in Eouts. + remember (outstanding_h2d repr) as outs' eqn:Eouts'. + destruct outs'; subst. + * destruct d_ready0; subst. + -- discriminate Eouts. + -- inversion Eouts; subst; clear Eouts. + destruct (a_opcode t0 =? Get). + ++ logical_simplify. subst. boolsimpl. + ssplit; reflexivity. + ++ destruct (a_opcode t0 =? PutFullData). + ** logical_simplify. subst. boolsimpl. + ssplit; reflexivity. + ** auto. + * destruct a_valid0. + -- inversion Eouts; subst; clear Eouts. + cbn. + destruct (a_opcode0 =? Get) eqn:Hget. + ++ ssplit; reflexivity. + ++ destruct (a_opcode0 =? PutFullData) eqn:Hput. + ** ssplit; reflexivity. + ** apply N.eqb_neq in Hget, Hput. + destruct H1. + --- reflexivity. + --- apply Hget. assumption. + --- apply Hput. assumption. + -- discriminate Eouts. + + simpl in Eouts. + remember (outstanding_h2d repr) as outs' eqn:Eouts'. + destruct outs'; subst. + -- destruct (a_opcode t =? Get) eqn:Hget. + ++ logical_simplify; subst. boolsimpl. + destruct d_ready0. + ** reflexivity. + ** discriminate Eouts. + ++ destruct (a_opcode t =? PutFullData) eqn:Hput. + ** logical_simplify; subst. boolsimpl. + destruct d_ready0. + --- reflexivity. + --- discriminate Eouts. + ** inversion H2. + -- destruct a_valid0. + +++ discriminate Eouts. + +++ boolsimpl. reflexivity. Qed. Lemma tlul_adapter_reg_output_correct : output_correct tlul_adapter_reg. @@ -525,31 +560,85 @@ Section TLULSpec. end. subst. repeat (destruct_pair_let; cbn [fst snd]). - destruct repr as [repr'|]. - - (* repr = Some _ *) - destruct repr'; logical_simplify; subst; boolsimpl; - eexists _, _, _, _, _, _, _, _, _; - cbn -[N.ones]; repeat (rewrite pair_equal_spec); - tlsimpl; ssplit; try reflexivity; - destruct d_ready0; simpl; ssplit; auto; []. - rewrite N.land_ones. - replace 4 with (2 ^ 2) by reflexivity. - rewrite <- ! N.shiftr_div_pow2. - reflexivity. - - (* repr = None *) - subst. - eexists _, _, _, _, _, _, _, _, _. - cbn -[N.ones]. repeat (rewrite pair_equal_spec). - tlsimpl. ssplit; try reflexivity; []. - destruct a_valid0; simpl; ssplit; try reflexivity; []. - match goal with - | h: true = true -> _ |- _ => - destruct h; [reflexivity|..] - end; subst; simpl; ssplit; try reflexivity; []. - rewrite N.land_ones. - replace 4 with (2 ^ 2) by reflexivity. - rewrite <- ! N.shiftr_div_pow2. - reflexivity. + remember (outstanding_h2d + ((a_valid0, + (a_opcode0, + (a_param0, (a_size0, (a_source0, (a_address0, (a_mask0, (a_data0, (a_user0, d_ready0))))))))) :: repr)) as outs eqn:Eouts. + destruct outs; subst. + - simpl in Eouts. + remember (outstanding_h2d repr) as outs' eqn:Eouts'. + destruct outs'; subst; + destruct d_ready0; try discriminate Eouts; inversion Eouts; subst; clear Eouts. + + destruct (a_opcode t0 =? Get) eqn:Hget; logical_simplify; subst; boolsimpl. + * do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. rewrite Hget. tlsimpl. + ssplit; try reflexivity. + rewrite N.land_ones. + replace 4 with (2 ^ 2) by reflexivity. + rewrite <- ! N.shiftr_div_pow2. + reflexivity. + * destruct (a_opcode t0 =? PutFullData) eqn:Hput; logical_simplify; subst; boolsimpl. + -- do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. rewrite Hget, Hput. tlsimpl. + ssplit; reflexivity. + -- inversion H1. + + destruct a_valid0; try discriminate H0. + inversion H0; subst. clear H0. + do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. tlsimpl. + destruct H2. + * reflexivity. + * rewrite H. boolsimpl. cbn -[N.ones]. + ssplit; try reflexivity. + rewrite N.land_ones. + replace 4 with (2 ^ 2) by reflexivity. + rewrite <- ! N.shiftr_div_pow2. + reflexivity. + * rewrite H. boolsimpl. cbn. ssplit; reflexivity. + + destruct a_valid0; try discriminate H0. + inversion H0; subst. clear H0. + do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. tlsimpl. + destruct H2. + * reflexivity. + * rewrite H. boolsimpl. cbn -[N.ones]. + ssplit; try reflexivity. + rewrite N.land_ones. + replace 4 with (2 ^ 2) by reflexivity. + rewrite <- ! N.shiftr_div_pow2. + reflexivity. + * rewrite H. boolsimpl. cbn. ssplit; reflexivity. + - simpl in Eouts. + remember (outstanding_h2d repr) as outs' eqn:Eouts'. + destruct outs'; subst; + destruct d_ready0; try discriminate Eouts; inversion Eouts; subst; clear Eouts. + + destruct (a_opcode t =? Get) eqn:Hget; logical_simplify; subst; boolsimpl. + * do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. tlsimpl. + ssplit; reflexivity. + * destruct (a_opcode t =? PutFullData) eqn:Hput; logical_simplify; subst; boolsimpl. + -- do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. tlsimpl. + ssplit; reflexivity. + -- inversion H1. + + destruct a_valid0; try discriminate H0. + clear H0. + do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. tlsimpl. + ssplit; reflexivity. + + destruct a_valid0; try discriminate H0. + clear H0. + do 8 eexists. split. 1: reflexivity. + cbn -[N.ones]. split. 1: reflexivity. + subst. rewrite <- Eouts'. tlsimpl. + ssplit; reflexivity. Qed. Existing Instances tlul_adapter_reg_invariant_at_reset tlul_adapter_reg_invariant_preserved From 29aae21e8786187af20d73d34da6aafede566253 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 4 Nov 2021 18:50:37 +0000 Subject: [PATCH 09/16] Fix TLUL + new incr with spec --- cava2/TLUL.v | 50 +- firmware/IncrementWait/CavaIncrementDevice.v | 611 +++++++++++++++++-- 2 files changed, 577 insertions(+), 84 deletions(-) diff --git a/cava2/TLUL.v b/cava2/TLUL.v index c4fe28f33..300cb2a86 100644 --- a/cava2/TLUL.v +++ b/cava2/TLUL.v @@ -419,8 +419,8 @@ Section TLULSpec. | None => if a_valid h2d then io_re = true /\ io_address = a_address h2d - else True - | _ => True + else io_re = false + | _ => io_re = false end /\ io_we = false else if a_opcode h2d' =? PutFullData then @@ -440,8 +440,8 @@ Section TLULSpec. /\ io_address = a_address h2d /\ io_data = a_data h2d /\ io_mask = a_mask h2d - else True - | _ => True + else io_we = false + | _ => io_we = false end else True end @@ -449,7 +449,10 @@ Section TLULSpec. Global Instance tlul_invariant : invariant_for (tlul_adapter_reg (reg_count:=reg_count)) tlul_repr := fun (state : denote_type (state_of tlul_adapter_reg)) repr => - tlul_adapter_reg_state_error state = false + Forall (fun h2d => (a_valid h2d = true + -> (a_opcode h2d = Get \/ a_opcode h2d = PutFullData))) + repr + /\ tlul_adapter_reg_state_error state = false /\ match outstanding_h2d repr with | None => tlul_adapter_reg_state_outstanding (reg_count:=reg_count) state = false @@ -491,7 +494,8 @@ Section TLULSpec. end. repeat (destruct_pair_let; cbn [fst snd]). tlul_adapter_reg_state_simpl. - split. + ssplit. + - apply Forall_cons; assumption. - destruct (a_valid0 && negb outstanding)%bool; subst; reflexivity. - remember (outstanding_h2d ((a_valid0, @@ -537,7 +541,7 @@ Section TLULSpec. destruct d_ready0. --- reflexivity. --- discriminate Eouts. - ** inversion H2. + ** exfalso. assumption. -- destruct a_valid0. +++ discriminate Eouts. +++ boolsimpl. reflexivity. @@ -583,35 +587,35 @@ Section TLULSpec. cbn -[N.ones]. split. 1: reflexivity. subst. rewrite <- Eouts'. rewrite Hget, Hput. tlsimpl. ssplit; reflexivity. - -- inversion H1. - + destruct a_valid0; try discriminate H0. - inversion H0; subst. clear H0. + -- exfalso. assumption. + + destruct a_valid0; try discriminate H1. + inversion H1; subst. clear H1. do 8 eexists. split. 1: reflexivity. cbn -[N.ones]. split. 1: reflexivity. subst. rewrite <- Eouts'. tlsimpl. - destruct H2. + destruct H3. * reflexivity. - * rewrite H. boolsimpl. cbn -[N.ones]. + * subst. boolsimpl. cbn -[N.ones]. ssplit; try reflexivity. rewrite N.land_ones. replace 4 with (2 ^ 2) by reflexivity. rewrite <- ! N.shiftr_div_pow2. reflexivity. - * rewrite H. boolsimpl. cbn. ssplit; reflexivity. - + destruct a_valid0; try discriminate H0. - inversion H0; subst. clear H0. + * subst. boolsimpl. cbn. ssplit; reflexivity. + + destruct a_valid0; try discriminate H1. + inversion H1; subst. clear H1. do 8 eexists. split. 1: reflexivity. cbn -[N.ones]. split. 1: reflexivity. subst. rewrite <- Eouts'. tlsimpl. - destruct H2. + destruct H3. * reflexivity. - * rewrite H. boolsimpl. cbn -[N.ones]. + * subst. boolsimpl. cbn -[N.ones]. ssplit; try reflexivity. rewrite N.land_ones. replace 4 with (2 ^ 2) by reflexivity. rewrite <- ! N.shiftr_div_pow2. reflexivity. - * rewrite H. boolsimpl. cbn. ssplit; reflexivity. + * subst. boolsimpl. cbn. ssplit; reflexivity. - simpl in Eouts. remember (outstanding_h2d repr) as outs' eqn:Eouts'. destruct outs'; subst; @@ -626,15 +630,15 @@ Section TLULSpec. cbn -[N.ones]. split. 1: reflexivity. subst. rewrite <- Eouts'. tlsimpl. ssplit; reflexivity. - -- inversion H1. - + destruct a_valid0; try discriminate H0. - clear H0. + -- exfalso. assumption. + + destruct a_valid0; try discriminate H1. + clear H1. do 8 eexists. split. 1: reflexivity. cbn -[N.ones]. split. 1: reflexivity. subst. rewrite <- Eouts'. tlsimpl. ssplit; reflexivity. - + destruct a_valid0; try discriminate H0. - clear H0. + + destruct a_valid0; try discriminate H1. + clear H1. do 8 eexists. split. 1: reflexivity. cbn -[N.ones]. split. 1: reflexivity. subst. rewrite <- Eouts'. tlsimpl. diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index 5686bf24d..25d72a513 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -1,18 +1,25 @@ -From Coq Require Import - Lists.List - ZArith.ZArith. +Require Import Coq.Lists.List. +Require Import Coq.micromega.Lia. +Require Import Coq.ZArith.ZArith. + +Require Import Cava.Expr. +Require Import Cava.ExprProperties. +Require Import Cava.Invariant. +Require Import Cava.Primitives. +Require Import Cava.Semantics. +Require Import Cava.TLUL. +Require Import Cava.Types. +Require Import Cava.Util.BitArithmetic. +Require Import Cava.Util.List. +Require Import Cava.Util.Tactics. -Import ListNotations. +Require Import coqutil.Tactics.Simp. +Require Import coqutil.Tactics.Tactics. -From Cava Require Import - Expr - Primitives - Semantics - TLUL - Types - Util.BitArithmetic. +Import ListNotations. Section Var. + Import Expr. Import ExprNotations. Import PrimitiveNotations. @@ -26,6 +33,31 @@ Section Var. Definition Busy2 := Constant incr_state 2. Definition Done := Constant incr_state 3. + Definition inner + : Circuit _ [Bit; BitVec 32] (Bit ** BitVec 32) + := {{ + fun valid data => + let/delay '(istate; value) := + let istate' := + if istate == `Busy1` then `Busy2` + else if istate == `Busy2` then `Done` + else if istate == `Done` then `Idle` + else (* istate == `Idle` *) + if valid then `Busy1` + else `Idle` in + + let value' := + if istate == `Busy2` then value + `K 1` + else if istate == `Idle` then data + else value in + + (istate', value') + initially default + : denote_type (incr_state ** BitVec 32) + in + (istate == `Done`, value) + }}. + Definition incr : Circuit _ [tl_h2d_t] tl_d2h_t := {{ @@ -42,8 +74,8 @@ Section Var. , a_data , a_user ; d_ready) := tl_h2d in - (* Bit #2 of the address determines which register is being accessed - (STATUS or VALUE). Zero out the other bits. *) + (* Bit #2 of the address determines which register is being accessed *) + (* (STATUS or VALUE). Zero out the other bits. *) let a_address := a_address & (`K 1` << 2) in let tl_h2d := (a_valid , a_opcode @@ -56,50 +88,46 @@ Section Var. , a_user , d_ready) in - let/delay '(istate, value; tl_d2h) := - (* Compute the value of the status register *) - let status := - if istate == `Done` then `K 4` - else if istate == `Busy1` || istate == `Busy2` then `K 2` - else (* istate == `Idle` *) `K 1` in - - (* Handle the input: - - a_opcode = Get: the adapter will do all the work; - - a_opcode = PutFullData: further handling is needed, the adapter - will output more info to req. *) - let '(tl_d2h'; req) := `tlul_adapter_reg` tl_h2d (value :> status :> []) in - let '(is_read - , is_write - , address - , write_data - ; _write_mask) := req in + let/delay '(busy, done, registers; tl_d2h) := + let '(tl_d2h'; req) := `tlul_adapter_reg` tl_h2d registers in + let '(is_read, is_write, address, write_data; _write_mask) := req in - let istate' := - if istate == `Busy1` then `Busy2` - else if istate == `Busy2` then `Done` - else if istate == `Done` then - if is_read && address == `K 0` then `Idle` - else `Done` - else (* istate == `Idle` *) - if is_write then `Busy1` - else `Idle` in + let '(inner_res_valid; inner_res) := `inner` (!busy && !done && is_write) write_data in - let value' := - if istate == `Busy2` then value + `K 1` - else if istate == `Idle` then write_data - else value in + let busy' := + if busy then !inner_res_valid + else !done && is_write in - (istate', value', tl_d2h') - initially (0, - (0, - (false, (0, (0, (0, (0, (0, (0, (0, (false, false))))))))))) - : denote_type (incr_state ** BitVec 32 ** tl_d2h_t) + let done' := + if busy then inner_res_valid + else if done then !(is_read && address == `K 0`) + else done in + + let registers' := + if inner_res_valid then `replace` registers `K (sz:=1) 0` inner_res + else registers in + + let registers' := + if busy' then `replace` registers' `K (sz:=1) 1` `K 2` + else if done' then `replace` registers' `K (sz:=1) 1` `K 4` + else `replace` registers' `K (sz:=1) 1` `K 1` in + + (busy', done', registers', tl_d2h') initially default + : denote_type (Bit ** Bit ** Vec (BitVec 32) 2 ** tl_d2h_t) in tl_d2h }}. End Var. +Definition sim {s i o} (c : Circuit s i o) (input : list (denote_type i)) + : list (denote_type s * denote_type i * denote_type o) := + fst (List.fold_left (fun '(acc, s) i => + let '(s', o) := step c s i in + (acc ++ [(s, i, o)], s')) + input + ([], reset_state c)). + Example sample_trace := Eval compute in let nop := set_d_ready true tl_h2d_default in @@ -117,21 +145,482 @@ Example sample_trace := (set_a_data v (set_d_ready true tl_h2d_default))))) in - simulate incr - [ (nop, tt) - ; (read_reg 4, tt) (* status *) - ; (nop, tt) - ; (write_val 42, tt) - ; (nop, tt) - ; (nop, tt) - ; (read_reg 4, tt) (* status *) - ; (nop, tt) - ; (read_reg 0, tt) (* value *) - ; (nop, tt) - ; (read_reg 4, tt) (* status *) - ]%N. + sim incr + [ (nop, tt) + ; (read_reg 4, tt) (* status *) + ; (nop, tt) + ; (write_val 42, tt) + ; (nop, tt) + ; (nop, tt) + ; (read_reg 4, tt) (* status *) + ; (nop, tt) + ; (read_reg 0, tt) (* value *) + ; (nop, tt) + ; (read_reg 4, tt) (* status *) + ]%N. (* Print sample_trace. *) +Section Spec. + Local Open Scope N. + + Variant inner_state := + | IISIdle + | IISBusy (data : N) (count : nat) + | IISDone (res : N). + + Notation inner_repr := inner_state. + + Global Instance inner_invariant : invariant_for inner inner_repr := + fun (state : denote_type (state_of inner)) repr => + let '(istate, value) := state in + match repr with + | IISIdle => istate = 0 + | IISBusy data c => (0 < c <= 2)%nat /\ istate = N.of_nat c /\ value = data + | IISDone res => istate = 3 /\ value = res + end. + + Definition inner_spec_step (input : denote_type (input_of inner)) repr := + let '(valid, (data, tt)) := input in + match repr with + | IISIdle => if valid then IISBusy data 1 else IISIdle + | IISBusy data 2 => IISDone ((data + 1) mod 2^32) + | IISBusy data c => IISBusy data (c + 1) + | IISDone _ => IISIdle + end. + + Instance inner_specification + : specification_for inner inner_repr := + {| reset_repr := IISIdle; + + update_repr := + fun (input : denote_type (input_of inner)) repr => + inner_spec_step input repr; + + precondition := + fun (input : denote_type (input_of inner)) repr => True; + + postcondition := + fun (input : denote_type (input_of inner)) repr + (output : denote_type (output_of inner)) => + let repr' := inner_spec_step input repr in + match repr' with + | IISDone res => output = (true, res) + | _ => exists res, output = (false, res) + end; + |}. + + Lemma inner_invariant_at_reset : invariant_at_reset inner. + Proof. + simplify_invariant inner. reflexivity. + Qed. + + Lemma inner_invariant_preserved : invariant_preserved inner. + Proof. + intros (valid, (data, t)) state repr. destruct t. + cbn in * |-. destruct state as (istate, value). + intros repr' ? Hinvar Hprec; subst. + simplify_invariant inner. + simplify_spec inner. + cbv [inner inner_spec_step]. stepsimpl. + repeat (destruct_pair_let; cbn [fst snd]). + destruct repr as [|? iiscount|?]; logical_simplify; subst. + - destruct valid; cbn; try ssplit; lia. + - destruct iiscount as [|[|[|iiscount]]]; cbn; ssplit; lia. + - reflexivity. + Qed. + + Lemma inner_output_correct : output_correct inner. + Proof. + intros (valid, (data, t)) state repr. destruct t. + cbn in * |-. destruct state as (istate, value). + remember (update_repr (c:=inner) (valid, (data, tt)) repr) as repr'. + intros Hinvar Hprec. + simplify_invariant inner. + simplify_spec inner. + cbv [inner inner_spec_step]. stepsimpl. + repeat (destruct_pair_let; cbn [fst snd]). + destruct repr as [|? iiscount|?]; logical_simplify; subst. + - destruct valid; eexists; cbn; try ssplit; reflexivity. + - destruct iiscount as [|[|[|iiscount]]]; try lia; try eexists; reflexivity. + - eexists. reflexivity. + Qed. + + Existing Instances inner_invariant_at_reset inner_invariant_preserved + inner_output_correct. + Global Instance inner_correctness : correctness_for inner. + Proof. constructor; typeclasses eauto. Defined. + + + Variant repr_state := + | RSIdle + | RSBusy (data : N) + | RSDone (res : N). + + Notation repr := (repr_state * list N * list tl_h2d * inner_repr)%type. + + Global Instance incr_invariant : invariant_for incr repr := + fun (state : denote_type (state_of incr)) repr => + let '((s_busy, (s_done, (s_regs, s_d2h))), (s_tlul, s_inner)) := state in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + tlul_invariant (reg_count:=2) s_tlul r_tlul + /\ inner_invariant s_inner r_inner + /\ match r_state with + | RSIdle => s_busy = false /\ s_done = false + /\ r_inner = IISIdle + | RSBusy data => s_busy = true /\ s_done = false + /\ exists c, r_inner = IISBusy data c + | RSDone res => s_busy = false /\ s_done = true + /\ (r_inner = IISDone res \/ r_inner = IISIdle) + end + /\ s_regs = r_regs. + + Existing Instance tlul_specification. + + Instance incr_specification + : specification_for incr repr := + {| reset_repr := (RSIdle, [0; 0], [], IISIdle); + + update_repr := + fun (input : denote_type (input_of incr)) repr => + let '(i_h2d, tt) := input in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + + let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in + + let r_tlul' := + let tlul_input := (h2d, (r_regs, tt)) in + update_repr (c:=tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul in + + (* compute (some) tlul output *) + let '(is_read, is_write, address, write_data) := + match outstanding_h2d (h2d :: r_tlul) with + | None => (false, false, 0, 0) + | Some h2d' => + if a_opcode h2d' =? Get then + match outstanding_h2d r_tlul with + | None => (a_valid h2d, false, a_address h2d, 0) + | _ => (false, false, 0, 0) + end + else if a_opcode h2d' =? PutFullData then + match outstanding_h2d r_tlul with + | None => (false, a_valid h2d, a_address h2d, a_data h2d) + | _ => (false, false, 0, 0) + end + else (false, false, 0, 0) + end in + + let r_inner' := + let inner_input := (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) in + update_repr (c:=inner) inner_input r_inner in + + let r_state' := + match r_state with + | RSDone _ => + if negb (is_read && (address =? 0)) then r_state + else RSIdle + | _ => + match r_inner' with + | IISBusy data _ => RSBusy data + | IISDone res => RSDone res + | _ => r_state + end + end in + + let r_regs' := + match r_inner' with + | IISDone res => replace 0 res r_regs + | _ => r_regs + end in + + let r_regs' := + match r_state' with + | RSIdle => replace 1 1 r_regs' + | RSBusy _ => replace 1 2 r_regs' + | RSDone _ => replace 1 4 r_regs' + end in + + (r_state', r_regs', h2d :: r_tlul, r_inner'); + + precondition := + fun (input : denote_type (input_of incr)) repr => + let '(i_h2d, tt) := input in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + + let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in + + let tlul_input := (h2d, (r_regs, tt)) in + + let prec_tlul := + precondition (tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul in + + let prec_inner := + forall d2h is_read is_write address write_data write_mask, + postcondition (tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul + (d2h, (is_read, (is_write, (address, (write_data, write_mask))))) + -> precondition inner (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) r_inner in + + prec_tlul /\ prec_inner; + + postcondition := + fun (input : denote_type (input_of incr)) repr + (output : denote_type (output_of incr)) => + let '(i_h2d, tt) := input in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + + let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in + + let postc_tlul := + let tlul_input := (h2d, (r_regs, tt)) in + exists req, + postcondition (tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul + (output, req) in + postc_tlul; + |}. + + Lemma incr_invariant_at_reset : invariant_at_reset incr. + Proof. + simplify_invariant incr. + cbn. ssplit; try reflexivity. + apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2)). + Qed. + + Existing Instance tlul_adapter_reg_correctness. + + (* TODO: move these lemmas to TLUL.v *) + Lemma outstanding_in_repr {reg_count : nat} : forall r_tlul t, + outstanding_h2d r_tlul = Some t -> + In t r_tlul. + Proof. + intros ? ?. + induction r_tlul; intros Houts; cbn in Houts. + - discriminate. + - destruct (outstanding_h2d r_tlul) eqn:Houts'. + + destruct d_ready. + * discriminate. + * apply in_cons. auto. + + destruct (a_valid a). + * inversion Houts. apply in_eq. + * discriminate. + Qed. + + Lemma outstanding_a_valid {reg_count : nat} : forall r_tlul t, + outstanding_h2d r_tlul = Some t -> + a_valid t = true. + Proof. + intros ? ?. + induction r_tlul; intros Houts; cbn in Houts. + - discriminate. + - destruct (outstanding_h2d r_tlul) eqn:Houts'. + + destruct d_ready. + * discriminate. + * auto. + + destruct (a_valid a) eqn:Hvalid. + * inversion Houts. subst. assumption. + * discriminate. + Qed. + + Lemma outstanding_prec {reg_count : nat} : forall tl_st r_tlul t, + tlul_invariant (reg_count:=reg_count) tl_st r_tlul -> + outstanding_h2d r_tlul = Some t -> + a_opcode t = Get \/ a_opcode t = PutFullData. + Proof. + intros ? ? ? Hinvar Houts. simpl in *. + apply (outstanding_in_repr (reg_count:=reg_count)) in Houts as Hin. + unfold tlul_invariant in Hinvar. logical_simplify. + eapply Forall_forall in H. 2: apply Hin. + apply H. + eapply (outstanding_a_valid (reg_count:=reg_count)). + apply Houts. + Qed. + + + Lemma incr_invariant_preserved : invariant_preserved incr. + Proof. + intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. + cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). + destruct_tl_h2d. destruct_tl_d2h. + intros repr' ? Hinvar Hprec; subst. + simplify_invariant incr. logical_simplify. subst. + simplify_spec incr. logical_simplify. subst. + (* destruct Hprec as [regs Hprec]. *) + cbv [incr]. stepsimpl. + use_correctness. + match goal with + | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => + rename H into Htl_postc + end. + repeat (destruct_pair_let; cbn [fst snd]). + ssplit. + - eapply tlul_adapter_reg_invariant_preserved. + 2: apply H. + + reflexivity. + + assumption. + - eapply inner_invariant_preserved. + 2: apply H0. + + simpl in *. + destruct r_inner; try reflexivity. + destruct (outstanding_h2d r_tlul) eqn:Houts. + * destruct d_ready; logical_simplify; subst. + -- boolsimpl. destruct r_state; reflexivity. + -- eapply outstanding_prec in H as Hprec_t. 2: apply Houts. + destruct Hprec_t as [Hprec_t|Hprec_t]; + rewrite Hprec_t in *; cbn in Htl_postc |- *; logical_simplify; subst; + boolsimpl; destruct r_state; reflexivity. + * destruct a_valid eqn:Hvalid; logical_simplify; subst. + -- cbn in Htl_postc. + match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; + boolsimpl; destruct r_state; logical_simplify; subst; + reflexivity. + -- boolsimpl; destruct r_state; reflexivity. + + match goal with + | H: context [_ -> precondition inner _ r_inner] |- _ => + eapply H + end. + do 8 eexists. ssplit. + 1-2: reflexivity. + apply Htl_postc. + - match goal with + | H: context [_ -> precondition inner _ r_inner] |- _ => clear H + end. + destruct r_inner; destruct r_state; destruct inner_st; + unfold inner_invariant in H0; logical_simplify; subst; + try discriminate; + try (destruct H4; discriminate). + all: destruct (outstanding_h2d r_tlul) eqn:Houts; + cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. + all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. + all: cbn; try (ssplit; reflexivity). + all: try (eapply outstanding_prec in H; + try match goal with + | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => + apply H + end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; + logical_simplify; subst; ssplit; + try (left; reflexivity); + try (right; reflexivity); + reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; destruct H2; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; + try eexists; reflexivity). + all: try (destruct a_valid; ssplit; + try (left; reflexivity); + try (right; reflexivity); + reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; destruct H2; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; + boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + cbn; try (rewrite Haddr); ssplit; + try (left; reflexivity); + try (right; reflexivity); + reflexivity). + all: (inversion H4; subst; clear H4; + destruct x as [|[|[|?]]]; cbn; ssplit; + try eexists; + try (left; reflexivity); + try (right; reflexivity); + try reflexivity; + exfalso; lia). + - match goal with + | H: context [_ -> precondition inner _ r_inner] |- _ => clear H + end. + destruct r_inner; destruct r_state; destruct inner_st; + unfold inner_invariant in H0; logical_simplify; subst; + try discriminate. + all: destruct (outstanding_h2d r_tlul) eqn:Houts; + cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. + all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. + all: try reflexivity. + all: try (eapply outstanding_prec in H; + try match goal with + | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => + apply H + end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; + logical_simplify; subst; cbn; reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; destruct H2; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; destruct H2; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; + boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + cbn; try (rewrite Haddr); reflexivity). + all: try (inversion H4; subst; clear H4; + destruct x as [|[|[|?]]]; try reflexivity; exfalso; lia). + all: try (destruct H4; discriminate). + Qed. + + Lemma incr_output_correct : output_correct incr. + Proof. + intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. + cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). + destruct_tl_h2d. destruct_tl_d2h. + intros Hinvar Hprec; subst. + simplify_invariant incr. logical_simplify. subst. + simplify_spec incr. logical_simplify. subst. + cbv [incr]. stepsimpl. + use_correctness. + match goal with + | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => + rename H into Htl_postc + end. + repeat (destruct_pair_let; cbn [fst snd]). + tlsimpl. + destruct r_inner; destruct r_state; destruct inner_st; + unfold inner_invariant in H0; logical_simplify; subst; + try discriminate; + try (destruct H5; discriminate). + all: destruct (outstanding_h2d r_tlul) eqn:Houts; + cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. + all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. + all: do 9 eexists. + all: ssplit; try reflexivity; tlsimpl; ssplit; try reflexivity; try assumption. + all: try (eapply outstanding_prec in H; + try match goal with + | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => + apply H + end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; + logical_simplify; subst; ssplit; + try (left; reflexivity); + try (right; reflexivity); + try assumption; + reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; destruct H2; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; + try eexists; try assumption; reflexivity). + Unshelve. all: auto. + Qed. + + Existing Instances incr_invariant_at_reset incr_invariant_preserved + incr_output_correct. + Global Instance incr_correctness : correctness_for incr. + Proof. constructor; typeclasses eauto. Defined. +End Spec. + Require Import Coq.micromega.Lia. Require Import riscv.Utility.Utility. From e06cb0fcbb368364f955b2e05c1f2660b7a43dbe Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Fri, 5 Nov 2021 10:40:23 +0000 Subject: [PATCH 10/16] TLUL lemmas --- cava2/TLUL.v | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/cava2/TLUL.v b/cava2/TLUL.v index 300cb2a86..818518ca0 100644 --- a/cava2/TLUL.v +++ b/cava2/TLUL.v @@ -650,4 +650,51 @@ Section TLULSpec. Global Instance tlul_adapter_reg_correctness : correctness_for tlul_adapter_reg. Proof. constructor; typeclasses eauto. Defined. + + + Lemma outstanding_in_repr : forall r_tlul t, + outstanding_h2d r_tlul = Some t -> + In t r_tlul. + Proof. + intros ? ?. + induction r_tlul; intros Houts; cbn in Houts. + - discriminate. + - destruct (outstanding_h2d r_tlul) eqn:Houts'. + + destruct d_ready. + * discriminate. + * apply in_cons. auto. + + destruct (a_valid a). + * inversion Houts. apply in_eq. + * discriminate. + Qed. + + Lemma outstanding_a_valid : forall r_tlul t, + outstanding_h2d r_tlul = Some t -> + a_valid t = true. + Proof. + intros ? ?. + induction r_tlul; intros Houts; cbn in Houts. + - discriminate. + - destruct (outstanding_h2d r_tlul) eqn:Houts'. + + destruct d_ready. + * discriminate. + * auto. + + destruct (a_valid a) eqn:Hvalid. + * inversion Houts. subst. assumption. + * discriminate. + Qed. + + Lemma outstanding_prec : forall tl_st r_tlul t, + tlul_invariant tl_st r_tlul -> + outstanding_h2d r_tlul = Some t -> + a_opcode t = Get \/ a_opcode t = PutFullData. + Proof. + intros ? ? ? Hinvar Houts. simpl in *. + apply outstanding_in_repr in Houts as Hin. + unfold tlul_invariant in Hinvar. logical_simplify. + eapply Forall_forall in H. 2: apply Hin. + apply H. + eapply outstanding_a_valid. + apply Houts. + Qed. End TLULSpec. From 16af868d95df2e2afc33d180b31efd909336d12b Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 10 Nov 2021 08:40:50 +0000 Subject: [PATCH 11/16] Half way through end2end proof for incr --- cava/Cava/Util/List.v | 9 + firmware/IncrementWait/CavaIncrementDevice.v | 1184 ++++++------------ firmware/IncrementWait/Incr.v | 598 +++++++++ 3 files changed, 966 insertions(+), 825 deletions(-) create mode 100644 firmware/IncrementWait/Incr.v diff --git a/cava/Cava/Util/List.v b/cava/Cava/Util/List.v index 280a29642..9731ac9db 100644 --- a/cava/Cava/Util/List.v +++ b/cava/Cava/Util/List.v @@ -1027,6 +1027,15 @@ Section Replace. | S n' => x :: replace n' a xs end end%list. + + Lemma length_replace {A} : forall n a (ls: list A), + length (replace n a ls) = length ls. + Proof. + intros. generalize dependent n. + induction ls; intros; destruct n; + try reflexivity; + cbn; auto. + Qed. End Replace. (* Proofs about fold_right and fold_left *) diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index 25d72a513..e1fa7bb7e 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -13,633 +13,23 @@ Require Import Cava.Util.BitArithmetic. Require Import Cava.Util.List. Require Import Cava.Util.Tactics. +Require Import coqutil.Map.Interface coqutil.Map.Properties. Require Import coqutil.Tactics.Simp. Require Import coqutil.Tactics.Tactics. - -Import ListNotations. - -Section Var. - Import Expr. - Import ExprNotations. - Import PrimitiveNotations. - - Local Open Scope N. - - Context {var : tvar}. - - Definition incr_state := BitVec 2. - Definition Idle := Constant incr_state 0. - Definition Busy1 := Constant incr_state 1. - Definition Busy2 := Constant incr_state 2. - Definition Done := Constant incr_state 3. - - Definition inner - : Circuit _ [Bit; BitVec 32] (Bit ** BitVec 32) - := {{ - fun valid data => - let/delay '(istate; value) := - let istate' := - if istate == `Busy1` then `Busy2` - else if istate == `Busy2` then `Done` - else if istate == `Done` then `Idle` - else (* istate == `Idle` *) - if valid then `Busy1` - else `Idle` in - - let value' := - if istate == `Busy2` then value + `K 1` - else if istate == `Idle` then data - else value in - - (istate', value') - initially default - : denote_type (incr_state ** BitVec 32) - in - (istate == `Done`, value) - }}. - - Definition incr - : Circuit _ [tl_h2d_t] tl_d2h_t - := {{ - fun tl_h2d => - (* Destruct and reassemble tl_h2d with a_address that matches the - tlul_adapter_reg interface. *) - let '(a_valid - , a_opcode - , a_param - , a_size - , a_source - , a_address - , a_mask - , a_data - , a_user - ; d_ready) := tl_h2d in - (* Bit #2 of the address determines which register is being accessed *) - (* (STATUS or VALUE). Zero out the other bits. *) - let a_address := a_address & (`K 1` << 2) in - let tl_h2d := (a_valid - , a_opcode - , a_param - , a_size - , a_source - , a_address - , a_mask - , a_data - , a_user - , d_ready) in - - let/delay '(busy, done, registers; tl_d2h) := - let '(tl_d2h'; req) := `tlul_adapter_reg` tl_h2d registers in - let '(is_read, is_write, address, write_data; _write_mask) := req in - - let '(inner_res_valid; inner_res) := `inner` (!busy && !done && is_write) write_data in - - let busy' := - if busy then !inner_res_valid - else !done && is_write in - - let done' := - if busy then inner_res_valid - else if done then !(is_read && address == `K 0`) - else done in - - let registers' := - if inner_res_valid then `replace` registers `K (sz:=1) 0` inner_res - else registers in - - let registers' := - if busy' then `replace` registers' `K (sz:=1) 1` `K 2` - else if done' then `replace` registers' `K (sz:=1) 1` `K 4` - else `replace` registers' `K (sz:=1) 1` `K 1` in - - (busy', done', registers', tl_d2h') initially default - : denote_type (Bit ** Bit ** Vec (BitVec 32) 2 ** tl_d2h_t) - in - - tl_d2h - }}. -End Var. - -Definition sim {s i o} (c : Circuit s i o) (input : list (denote_type i)) - : list (denote_type s * denote_type i * denote_type o) := - fst (List.fold_left (fun '(acc, s) i => - let '(s', o) := step c s i in - (acc ++ [(s, i, o)], s')) - input - ([], reset_state c)). - -Example sample_trace := - Eval compute in - let nop := set_d_ready true tl_h2d_default in - let read_reg (r : N) := - set_a_valid true - (set_a_opcode Get - (set_a_size 2%N - (set_a_address r - (set_d_ready true tl_h2d_default)))) in - let write_val (v : N) := - set_a_valid true - (set_a_opcode PutFullData - (set_a_size 2%N - (set_a_address 0%N (* value-ref *) - (set_a_data v - (set_d_ready true tl_h2d_default))))) in - - sim incr - [ (nop, tt) - ; (read_reg 4, tt) (* status *) - ; (nop, tt) - ; (write_val 42, tt) - ; (nop, tt) - ; (nop, tt) - ; (read_reg 4, tt) (* status *) - ; (nop, tt) - ; (read_reg 0, tt) (* value *) - ; (nop, tt) - ; (read_reg 4, tt) (* status *) - ]%N. -(* Print sample_trace. *) - -Section Spec. - Local Open Scope N. - - Variant inner_state := - | IISIdle - | IISBusy (data : N) (count : nat) - | IISDone (res : N). - - Notation inner_repr := inner_state. - - Global Instance inner_invariant : invariant_for inner inner_repr := - fun (state : denote_type (state_of inner)) repr => - let '(istate, value) := state in - match repr with - | IISIdle => istate = 0 - | IISBusy data c => (0 < c <= 2)%nat /\ istate = N.of_nat c /\ value = data - | IISDone res => istate = 3 /\ value = res - end. - - Definition inner_spec_step (input : denote_type (input_of inner)) repr := - let '(valid, (data, tt)) := input in - match repr with - | IISIdle => if valid then IISBusy data 1 else IISIdle - | IISBusy data 2 => IISDone ((data + 1) mod 2^32) - | IISBusy data c => IISBusy data (c + 1) - | IISDone _ => IISIdle - end. - - Instance inner_specification - : specification_for inner inner_repr := - {| reset_repr := IISIdle; - - update_repr := - fun (input : denote_type (input_of inner)) repr => - inner_spec_step input repr; - - precondition := - fun (input : denote_type (input_of inner)) repr => True; - - postcondition := - fun (input : denote_type (input_of inner)) repr - (output : denote_type (output_of inner)) => - let repr' := inner_spec_step input repr in - match repr' with - | IISDone res => output = (true, res) - | _ => exists res, output = (false, res) - end; - |}. - - Lemma inner_invariant_at_reset : invariant_at_reset inner. - Proof. - simplify_invariant inner. reflexivity. - Qed. - - Lemma inner_invariant_preserved : invariant_preserved inner. - Proof. - intros (valid, (data, t)) state repr. destruct t. - cbn in * |-. destruct state as (istate, value). - intros repr' ? Hinvar Hprec; subst. - simplify_invariant inner. - simplify_spec inner. - cbv [inner inner_spec_step]. stepsimpl. - repeat (destruct_pair_let; cbn [fst snd]). - destruct repr as [|? iiscount|?]; logical_simplify; subst. - - destruct valid; cbn; try ssplit; lia. - - destruct iiscount as [|[|[|iiscount]]]; cbn; ssplit; lia. - - reflexivity. - Qed. - - Lemma inner_output_correct : output_correct inner. - Proof. - intros (valid, (data, t)) state repr. destruct t. - cbn in * |-. destruct state as (istate, value). - remember (update_repr (c:=inner) (valid, (data, tt)) repr) as repr'. - intros Hinvar Hprec. - simplify_invariant inner. - simplify_spec inner. - cbv [inner inner_spec_step]. stepsimpl. - repeat (destruct_pair_let; cbn [fst snd]). - destruct repr as [|? iiscount|?]; logical_simplify; subst. - - destruct valid; eexists; cbn; try ssplit; reflexivity. - - destruct iiscount as [|[|[|iiscount]]]; try lia; try eexists; reflexivity. - - eexists. reflexivity. - Qed. - - Existing Instances inner_invariant_at_reset inner_invariant_preserved - inner_output_correct. - Global Instance inner_correctness : correctness_for inner. - Proof. constructor; typeclasses eauto. Defined. - - - Variant repr_state := - | RSIdle - | RSBusy (data : N) - | RSDone (res : N). - - Notation repr := (repr_state * list N * list tl_h2d * inner_repr)%type. - - Global Instance incr_invariant : invariant_for incr repr := - fun (state : denote_type (state_of incr)) repr => - let '((s_busy, (s_done, (s_regs, s_d2h))), (s_tlul, s_inner)) := state in - let '(r_state, r_regs, r_tlul, r_inner) := repr in - tlul_invariant (reg_count:=2) s_tlul r_tlul - /\ inner_invariant s_inner r_inner - /\ match r_state with - | RSIdle => s_busy = false /\ s_done = false - /\ r_inner = IISIdle - | RSBusy data => s_busy = true /\ s_done = false - /\ exists c, r_inner = IISBusy data c - | RSDone res => s_busy = false /\ s_done = true - /\ (r_inner = IISDone res \/ r_inner = IISIdle) - end - /\ s_regs = r_regs. - - Existing Instance tlul_specification. - - Instance incr_specification - : specification_for incr repr := - {| reset_repr := (RSIdle, [0; 0], [], IISIdle); - - update_repr := - fun (input : denote_type (input_of incr)) repr => - let '(i_h2d, tt) := input in - let '(r_state, r_regs, r_tlul, r_inner) := repr in - - let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in - - let r_tlul' := - let tlul_input := (h2d, (r_regs, tt)) in - update_repr (c:=tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul in - - (* compute (some) tlul output *) - let '(is_read, is_write, address, write_data) := - match outstanding_h2d (h2d :: r_tlul) with - | None => (false, false, 0, 0) - | Some h2d' => - if a_opcode h2d' =? Get then - match outstanding_h2d r_tlul with - | None => (a_valid h2d, false, a_address h2d, 0) - | _ => (false, false, 0, 0) - end - else if a_opcode h2d' =? PutFullData then - match outstanding_h2d r_tlul with - | None => (false, a_valid h2d, a_address h2d, a_data h2d) - | _ => (false, false, 0, 0) - end - else (false, false, 0, 0) - end in - - let r_inner' := - let inner_input := (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) in - update_repr (c:=inner) inner_input r_inner in - - let r_state' := - match r_state with - | RSDone _ => - if negb (is_read && (address =? 0)) then r_state - else RSIdle - | _ => - match r_inner' with - | IISBusy data _ => RSBusy data - | IISDone res => RSDone res - | _ => r_state - end - end in - - let r_regs' := - match r_inner' with - | IISDone res => replace 0 res r_regs - | _ => r_regs - end in - - let r_regs' := - match r_state' with - | RSIdle => replace 1 1 r_regs' - | RSBusy _ => replace 1 2 r_regs' - | RSDone _ => replace 1 4 r_regs' - end in - - (r_state', r_regs', h2d :: r_tlul, r_inner'); - - precondition := - fun (input : denote_type (input_of incr)) repr => - let '(i_h2d, tt) := input in - let '(r_state, r_regs, r_tlul, r_inner) := repr in - - let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in - - let tlul_input := (h2d, (r_regs, tt)) in - - let prec_tlul := - precondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul in - - let prec_inner := - forall d2h is_read is_write address write_data write_mask, - postcondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul - (d2h, (is_read, (is_write, (address, (write_data, write_mask))))) - -> precondition inner (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) r_inner in - - prec_tlul /\ prec_inner; - - postcondition := - fun (input : denote_type (input_of incr)) repr - (output : denote_type (output_of incr)) => - let '(i_h2d, tt) := input in - let '(r_state, r_regs, r_tlul, r_inner) := repr in - - let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in - - let postc_tlul := - let tlul_input := (h2d, (r_regs, tt)) in - exists req, - postcondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul - (output, req) in - postc_tlul; - |}. - - Lemma incr_invariant_at_reset : invariant_at_reset incr. - Proof. - simplify_invariant incr. - cbn. ssplit; try reflexivity. - apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2)). - Qed. - - Existing Instance tlul_adapter_reg_correctness. - - (* TODO: move these lemmas to TLUL.v *) - Lemma outstanding_in_repr {reg_count : nat} : forall r_tlul t, - outstanding_h2d r_tlul = Some t -> - In t r_tlul. - Proof. - intros ? ?. - induction r_tlul; intros Houts; cbn in Houts. - - discriminate. - - destruct (outstanding_h2d r_tlul) eqn:Houts'. - + destruct d_ready. - * discriminate. - * apply in_cons. auto. - + destruct (a_valid a). - * inversion Houts. apply in_eq. - * discriminate. - Qed. - - Lemma outstanding_a_valid {reg_count : nat} : forall r_tlul t, - outstanding_h2d r_tlul = Some t -> - a_valid t = true. - Proof. - intros ? ?. - induction r_tlul; intros Houts; cbn in Houts. - - discriminate. - - destruct (outstanding_h2d r_tlul) eqn:Houts'. - + destruct d_ready. - * discriminate. - * auto. - + destruct (a_valid a) eqn:Hvalid. - * inversion Houts. subst. assumption. - * discriminate. - Qed. - - Lemma outstanding_prec {reg_count : nat} : forall tl_st r_tlul t, - tlul_invariant (reg_count:=reg_count) tl_st r_tlul -> - outstanding_h2d r_tlul = Some t -> - a_opcode t = Get \/ a_opcode t = PutFullData. - Proof. - intros ? ? ? Hinvar Houts. simpl in *. - apply (outstanding_in_repr (reg_count:=reg_count)) in Houts as Hin. - unfold tlul_invariant in Hinvar. logical_simplify. - eapply Forall_forall in H. 2: apply Hin. - apply H. - eapply (outstanding_a_valid (reg_count:=reg_count)). - apply Houts. - Qed. - - - Lemma incr_invariant_preserved : invariant_preserved incr. - Proof. - intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. - cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). - destruct_tl_h2d. destruct_tl_d2h. - intros repr' ? Hinvar Hprec; subst. - simplify_invariant incr. logical_simplify. subst. - simplify_spec incr. logical_simplify. subst. - (* destruct Hprec as [regs Hprec]. *) - cbv [incr]. stepsimpl. - use_correctness. - match goal with - | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => - rename H into Htl_postc - end. - repeat (destruct_pair_let; cbn [fst snd]). - ssplit. - - eapply tlul_adapter_reg_invariant_preserved. - 2: apply H. - + reflexivity. - + assumption. - - eapply inner_invariant_preserved. - 2: apply H0. - + simpl in *. - destruct r_inner; try reflexivity. - destruct (outstanding_h2d r_tlul) eqn:Houts. - * destruct d_ready; logical_simplify; subst. - -- boolsimpl. destruct r_state; reflexivity. - -- eapply outstanding_prec in H as Hprec_t. 2: apply Houts. - destruct Hprec_t as [Hprec_t|Hprec_t]; - rewrite Hprec_t in *; cbn in Htl_postc |- *; logical_simplify; subst; - boolsimpl; destruct r_state; reflexivity. - * destruct a_valid eqn:Hvalid; logical_simplify; subst. - -- cbn in Htl_postc. - match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; - boolsimpl; destruct r_state; logical_simplify; subst; - reflexivity. - -- boolsimpl; destruct r_state; reflexivity. - + match goal with - | H: context [_ -> precondition inner _ r_inner] |- _ => - eapply H - end. - do 8 eexists. ssplit. - 1-2: reflexivity. - apply Htl_postc. - - match goal with - | H: context [_ -> precondition inner _ r_inner] |- _ => clear H - end. - destruct r_inner; destruct r_state; destruct inner_st; - unfold inner_invariant in H0; logical_simplify; subst; - try discriminate; - try (destruct H4; discriminate). - all: destruct (outstanding_h2d r_tlul) eqn:Houts; - cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. - all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. - all: cbn; try (ssplit; reflexivity). - all: try (eapply outstanding_prec in H; - try match goal with - | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => - apply H - end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; - logical_simplify; subst; ssplit; - try (left; reflexivity); - try (right; reflexivity); - reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; destruct H2; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; - try eexists; reflexivity). - all: try (destruct a_valid; ssplit; - try (left; reflexivity); - try (right; reflexivity); - reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; destruct H2; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; - boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; - cbn; try (rewrite Haddr); ssplit; - try (left; reflexivity); - try (right; reflexivity); - reflexivity). - all: (inversion H4; subst; clear H4; - destruct x as [|[|[|?]]]; cbn; ssplit; - try eexists; - try (left; reflexivity); - try (right; reflexivity); - try reflexivity; - exfalso; lia). - - match goal with - | H: context [_ -> precondition inner _ r_inner] |- _ => clear H - end. - destruct r_inner; destruct r_state; destruct inner_st; - unfold inner_invariant in H0; logical_simplify; subst; - try discriminate. - all: destruct (outstanding_h2d r_tlul) eqn:Houts; - cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. - all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. - all: try reflexivity. - all: try (eapply outstanding_prec in H; - try match goal with - | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => - apply H - end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; - logical_simplify; subst; cbn; reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; destruct H2; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; destruct H2; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; - boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; - cbn; try (rewrite Haddr); reflexivity). - all: try (inversion H4; subst; clear H4; - destruct x as [|[|[|?]]]; try reflexivity; exfalso; lia). - all: try (destruct H4; discriminate). - Qed. - - Lemma incr_output_correct : output_correct incr. - Proof. - intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. - cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). - destruct_tl_h2d. destruct_tl_d2h. - intros Hinvar Hprec; subst. - simplify_invariant incr. logical_simplify. subst. - simplify_spec incr. logical_simplify. subst. - cbv [incr]. stepsimpl. - use_correctness. - match goal with - | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => - rename H into Htl_postc - end. - repeat (destruct_pair_let; cbn [fst snd]). - tlsimpl. - destruct r_inner; destruct r_state; destruct inner_st; - unfold inner_invariant in H0; logical_simplify; subst; - try discriminate; - try (destruct H5; discriminate). - all: destruct (outstanding_h2d r_tlul) eqn:Houts; - cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. - all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. - all: do 9 eexists. - all: ssplit; try reflexivity; tlsimpl; ssplit; try reflexivity; try assumption. - all: try (eapply outstanding_prec in H; - try match goal with - | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => - apply H - end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; - logical_simplify; subst; ssplit; - try (left; reflexivity); - try (right; reflexivity); - try assumption; - reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; destruct H2; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; - try eexists; try assumption; reflexivity). - Unshelve. all: auto. - Qed. - - Existing Instances incr_invariant_at_reset incr_invariant_preserved - incr_output_correct. - Global Instance incr_correctness : correctness_for incr. - Proof. constructor; typeclasses eauto. Defined. -End Spec. - -Require Import Coq.micromega.Lia. +Require Import coqutil.Word.Interface coqutil.Word.Properties. Require Import riscv.Utility.Utility. -Require Import coqutil.Map.Interface coqutil.Map.Properties. -Require Import coqutil.Word.Interface coqutil.Word.Properties. -Require Import coqutil.Tactics.Tactics. -Require Import coqutil.Tactics.Simp. -Require Import coqutil.Tactics.fwd. - Require Import bedrock2.ZnWords. Require Import Bedrock2Experiments.RiscvMachineWithCavaDevice.InternalMMIOMachine. Require Import Bedrock2Experiments.IncrementWait.Constants. +Require Import Bedrock2Experiments.IncrementWait.Incr. Require Import Bedrock2Experiments.IncrementWait.IncrementWaitSemantics. Require Import Bedrock2Experiments.StateMachineSemantics. Require Import Bedrock2Experiments.RiscvMachineWithCavaDevice.MMIOToCava. -Require Import Cava.Util.Tactics. +Import ListNotations. Section WithParameters. Instance var : tvar := denote_type. @@ -647,32 +37,10 @@ Section WithParameters. Context {word: Interface.word 32} {word_ok: word.ok word} {Mem: map.map word byte} {Registers: map.map Z word}. - Definition consistent_states - '((reqid, (reqsz, (rspop, (error, (outstanding, (_we_o, _re_o)))))) - : denote_type (state_of (tlul_adapter_reg (reg_count := 2)))) - '((d_valid, (d_opcode, (d_param, (d_size, (d_source, (d_sink, (d_data, (d_user, (d_error, a_ready))))))))) - : denote_type tl_d2h_t) - : Prop := - d_valid = outstanding /\ - d_opcode = rspop /\ - (* d_param = 0 /\ *) - d_size = reqsz /\ - d_source = reqid /\ - (* d_sink = 0 /\ *) - (* d_data = ?? *) - (* d_user = 0 /\ *) - d_error = error /\ - a_ready = negb outstanding. - - Definition mk_counter_state (istate : N) (val : N) tl_d2h tlul_state - : denote_type (state_of incr) := - ((istate, (val, tl_d2h)), tlul_state). - Global Instance counter_device: device := {| device.state := denote_type (state_of incr); - device.is_ready_state s := exists val tl_d2h tlul_state, - consistent_states tlul_state tl_d2h - /\ s = mk_counter_state 0 val tl_d2h tlul_state; + device.is_ready_state s := exists r_regs r_tlul r_inner, + incr_invariant s (RSIdle, r_regs, r_tlul, r_inner); device.run1 s i := Semantics.step incr s (i, tt); device.addr_range_start := INCR_BASE_ADDR; device.addr_range_pastend := INCR_END_ADDR; @@ -687,27 +55,26 @@ Section WithParameters. Global Instance circuit_spec : circuit_behavior := {| ncycles_processing := 15%nat |}. - Inductive counter_related: IncrementWaitSemantics.state -> denote_type (state_of incr) -> Prop := - | IDLE_related: forall val tl_d2h tlul_state, - consistent_states tlul_state tl_d2h -> - counter_related IDLE (mk_counter_state 0 val tl_d2h tlul_state) - | BUSY1_related: forall val tl_d2h tlul_state ncycles, - (1 < ncycles)%nat -> - consistent_states tlul_state tl_d2h -> - counter_related (BUSY val ncycles) (mk_counter_state 1 (word_to_N val) tl_d2h tlul_state) - | BUSY2_related: forall val tl_d2h tlul_state ncycles, + Inductive counter_related_spec: IncrementWaitSemantics.state -> repr -> Prop := + | IDLE_related: forall r_regs r_tl r_inner, + counter_related_spec IDLE (RSIdle, r_regs, r_tl, r_inner) + | BUSY_related: forall r_regs r_tl r_inner val ncycles, (0 < ncycles)%nat -> - consistent_states tlul_state tl_d2h -> - counter_related (BUSY val ncycles) (mk_counter_state 2 (word_to_N val) tl_d2h tlul_state) + counter_related_spec (BUSY val ncycles) + (RSBusy (word_to_N val), r_regs, r_tl, r_inner) (* the hardware is already done, but the software hasn't polled it yet to find out, so we have to relate a software-BUSY to a hardware-done: *) - | BUSY_done_related: forall val tl_d2h tlul_state ncycles, - consistent_states tlul_state tl_d2h -> - counter_related (BUSY val ncycles) - (mk_counter_state 3 (word_to_N (word.add (word.of_Z 1) val)) tl_d2h tlul_state) - | DONE_related: forall val tl_d2h tlul_state, - consistent_states tlul_state tl_d2h -> - counter_related (DONE val) (mk_counter_state 3 (word_to_N val) tl_d2h tlul_state). + | BUSY_done_related: forall r_regs r_tl r_inner val ncycles, + counter_related_spec (BUSY val ncycles) + (RSDone (word_to_N (word.add (word.of_Z 1) val)), r_regs, r_tl, r_inner) + | DONE_related: forall r_regs r_tl r_inner val, + nth 0 r_regs 0%N = (word_to_N val) + -> counter_related_spec (DONE val) + (RSDone (word_to_N val), r_regs, r_tl, r_inner). + + Definition counter_related (sH : IncrementWaitSemantics.state) + (sL : denote_type (state_of incr)) : Prop := + exists repr, counter_related_spec sH repr /\ incr_invariant sL repr. (* This should be in bedrock2.ZnWords. It is use by ZnWords, which is used in the two following Lemmas. *) @@ -737,198 +104,365 @@ Section WithParameters. eapply pair_equal_spec in H; destruct H as [?H0 ?H1] end. - Ltac destruct_tlul_adapter_reg_state := - match goal with - | H : N * (N * (N * (bool * (bool * (bool * bool))))) |- _ => - destruct H as [?reqid [?reqsz [?rspop [?error [?outstanding [?we_o ?re_o]]]]]] - end. - - Ltac destruct_consistent_states := - match goal with - | H : consistent_states _ _ |- _ => - destruct H as (Hvalid & Hopcode & Hsize & Hsource & Herror & Hready) - end. + (* Ltac destruct_tlul_adapter_reg_state := *) + (* match goal with *) + (* | H : N * (N * (N * (bool * (bool * (bool * bool))))) |- _ => *) + (* destruct H as [?reqid [?reqsz [?rspop [?error [?outstanding [?we_o ?re_o]]]]]] *) + (* end. *) Lemma N_to_word_word_to_N: forall v, N_to_word (word_to_N v) = v. Proof. intros. unfold N_to_word, word_to_N. ZnWords. Qed. -(* TODO move to coqutil *) -Ltac contradictory H := - lazymatch type of H with - | ?x <> ?x => exfalso; apply (H eq_refl) - | False => case H - end. -Require Import coqutil.Tactics.autoforward. -Ltac fwd_step ::= - match goal with - | H: ?T |- _ => is_destructible_and T; destr_and H - | H: exists y, _ |- _ => let yf := fresh y in destruct H as [yf H] - | H: ?x = ?x |- _ => clear H - | H: True |- _ => clear H - | H: ?LHS = ?RHS |- _ => - let h1 := head_of_app LHS in is_constructor h1; - let h2 := head_of_app RHS in is_constructor h2; - (* if not eq, H is a contradiction, but we don't want to change the number - of open goals in this tactic *) - constr_eq h1 h2; - (* we don't use `inversion H` or `injection H` because they unfold definitions *) - inv_rec LHS RHS; - clear H - | E: ?x = ?RHS |- context[match ?x with _ => _ end] => - let h := head_of_app RHS in is_constructor h; rewrite E in * - | H: context[match ?x with _ => _ end], E: ?x = ?RHS |- _ => - let h := head_of_app RHS in is_constructor h; rewrite E in * - | H: context[match ?x with _ => _ end] |- _ => - (* note: recursive invocation of fwd_step for contradictory cases *) - destr x; try solve [repeat fwd_step; contradictory H]; [] - | H: _ |- _ => autoforward with typeclass_instances in H - | |- _ => progress subst - | |- _ => progress fwd_rewrites - end. - - Axiom TODO: False. + Existing Instance Incr.inner_specification. + Existing Instance Incr.inner_correctness. + Existing Instance Incr.inner_invariant. + + Existing Instance TLUL.tlul_specification. + Existing Instance TLUL.tlul_adapter_reg_correctness. + Existing Instance TLUL.tlul_invariant. + + Existing Instance incr_specification. + Existing Instance incr_correctness. + + Lemma runUntilResp_big_step : forall s h2d repr, + precondition incr (h2d, tt) repr + -> a_valid h2d = true + -> d_ready h2d = true (* TODO: do we need this? *) + -> incr_invariant s repr + -> exists n inputs s' repr' d2h s'', + device.runUntilResp h2d device.maxRespDelay s = (Some d2h, s'') + /\ n <= device.maxRespDelay + /\ inputs = repeat (h2d, tt) n + /\ s' = snd (simulate' incr inputs s) + (* /\ (s'', d2h) = Semantics.step incr s' (h2d, tt) *) + /\ repr' = fold_left (fun r i => update_repr (c:=incr) i r) inputs repr + (* /\ invariant s' repr' *) + /\ postcondition incr (h2d, tt) repr' d2h + /\ d_valid d2h = true + /\ incr_invariant s'' (update_repr (c:=incr) (h2d, tt) repr'). + Proof. + intros ? ? ? Hprec Ea_valid Ed_ready Hinv. + unfold device.maxRespDelay, device.runUntilResp, device.state, device.run1, counter_device, + state_machine.read_step, increment_wait_state_machine, read_step in *. + eapply output_correct_pf in Hinv as Houtput. + apply Houtput in Hprec as Hpostc. clear Houtput. + cbn in s, h2d. destruct_tl_h2d. + destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner). + assert (Hprec_temp := Hprec). + unfold precondition, incr_specification in Hprec_temp. + logical_simplify. + unfold precondition, tlul_specification in H. + logical_simplify. tlsimpl. subst. + unfold postcondition, incr_specification in Hpostc. + unfold postcondition, tlul_specification in Hpostc. + destruct Hpostc as [[is_read [is_write [address [w_val w_mask]]]] [h2d' [regs' [d2h' [is_read' [is_write' [address' [w_val' [w_mask' Hpostc]]]]]]]]]. + destruct_tl_h2d. destruct_tl_d2h. tlsimpl. + destruct Hpostc as [Hpostc1 [Hpostc2 Hpostc3]]. + subst. + apply pair_equal_spec in Hpostc2. + logical_simplify. + cbn [outstanding_h2d] in Hpostc3. + destruct (outstanding_h2d r_tl) eqn:Eouts. + - cbn in Hpostc3. logical_simplify. subst. + assert (Hprec': + precondition incr + (true, + (a_opcode0, + (a_param0, (a_size0, (a_source0, (a_address, (a_mask0, (a_data0, (a_user0, true)))))))), tt) + (update_repr (c:=incr) + (true, + (a_opcode0, + (a_param0, (a_size0, (a_source0, (a_address, (a_mask0, (a_data0, (a_user0, true)))))))), tt) + (r_state, regs', r_tl, r_inner))). + { simplify_spec incr. + cbn [outstanding_h2d]. rewrite Eouts. + tlsimpl. ssplit. + - simplify_spec (tlul_adapter_reg (reg_count:=2)). tlsimpl. split; [|assumption]. + match goal with + | |- context [length (match ?m with | _=> _ end)] => + destruct m + end; + match goal with + | |- context [replace _ _ (match ?m with | _=> _ end)] => + destruct m + end; rewrite ! length_replace; assumption. + - simplify_spec Incr.inner. intros. apply I. + } + destruct H1; [auto|..]; subst. + all: exists 1. + all: destruct_pair_let; + match goal with + | |- context [if d_valid ?c then _ else _] => + match type of H2 with + | _ = ?r => replace c with r + end + end. + all: tlsimpl; + assert (Hinv' := Hprec); + eapply incr_invariant_preserved in Hinv; + [apply Hinv in Hinv'|reflexivity]; clear Hinv. + all: eapply output_correct_pf in Hinv' as Houtput'; + apply Houtput' in Hprec' as Hpostc'; clear Houtput'; + assert (Hpostc'' := Hpostc'); + unfold postcondition, incr_specification in Hpostc'; + unfold postcondition, tlul_specification in Hpostc'; + cbn [update_repr outstanding_h2d] in Hpostc'; + rewrite Eouts in Hpostc'; cbn -[Semantics.step] in Hpostc'; + destruct Hpostc' as [[is_read [is_write [address [w_val w_mask]]]] [h2d' [regs'' [d2h' [is_read' [is_write' [address'' [w_val'' [w_mask'' Hpostc']]]]]]]]]. + all: destruct_tl_h2d; destruct_tl_d2h; tlsimpl; + destruct Hpostc' as [Hpostc1' [Hpostc2' Hpostc3']]; + subst; + apply pair_equal_spec in Hpostc2'; + logical_simplify; + rewrite Eouts in Hpostc3'; + tlsimpl. + all: cbn in Hpostc3'; logical_simplify; subst. + all: do 5 eexists; ssplit; try reflexivity. + 1,5: destruct_pair_let; + match goal with + | |- context [if d_valid ?c then _ else _] => + match type of H1 with + | _ = ?r => replace c with r + end + end; tlsimpl; reflexivity. + 1,4: cbn [repeat fold_left]; + match goal with + | H: postcondition incr _ _ ?c |- _ => + match type of H1 with + | _ = ?r => replace c with r in H; apply H + end + end. + 1,3: reflexivity. + 1,2: cbn [repeat fold_left]; + eapply incr_invariant_preserved; [reflexivity|assumption..]. + - destruct H1; [auto|..]; subst; cbn in Hpostc3; logical_simplify; subst. + all: exists 0. + all: do 5 eexists; ssplit; try reflexivity; try lia. + 1,5: destruct_pair_let; + match goal with + | |- context [if d_valid ?c then _ else _] => + match type of H2 with + | _ = ?r => replace c with r + end + end; tlsimpl; reflexivity. + 1,4: cbn [repeat fold_left]; + eapply output_correct_pf in Hinv as Houtput; + apply Houtput in Hprec; + match goal with + | H: postcondition incr _ _ ?c |- _ => + match type of H2 with + | _ = ?r => replace c with r in H; apply H + end + end. + 1,3: reflexivity. + 1,2: cbn [repeat fold_left]; + eapply incr_invariant_preserved; [reflexivity|assumption..]. + Qed. (* Set Printing All. *) Global Instance cava_counter_satisfies_state_machine: device_implements_state_machine counter_device increment_wait_state_machine. Proof. - eapply Build_device_implements_state_machine with (device_state_related := counter_related); - intros. + eapply Build_device_implements_state_machine with (device_state_related := counter_related). - (* mmioAddrs_match: *) reflexivity. - (* initial_state_is_ready_state: *) - simpl in *. subst. inversion H0. subst. eexists _, _, _. eauto. + intros ? ? Hinit Hrel. + cbn in *. subst. destruct Hrel as [?repr [?Hrel ?Hinv]]. + inversion Hrel. subst. + do 3 eexists. eapply Hinv. - (* initial_states_are_related: *) - simpl in *. destruct H0 as (val & tl_d2h & tlul_state & H0 & H1). subst. - eauto using IDLE_related. + intros ? ? Hinit Hready. + cbn in *. destruct Hready as (?r_regs & ?r_tl & ?r_inner & ?Hinv). subst. + unfold counter_related. eexists. split; [|apply Hinv]. + apply IDLE_related. - (* initial_state_exists: *) - simpl in *. destruct H as (val & tl_d2h & tlul_state & H0 & H1). subst. - eauto using IDLE_related. + intros ? Hready. + cbn in *. destruct Hready as (?r_regs & ?r_tl & ?r_inner & ?Hinv). + eexists. split; [reflexivity|]. + unfold counter_related. eexists. split; [|apply Hinv]. + apply IDLE_related. - (* nonMMIO_device_step_preserves_state_machine_state: *) - simpl in sL1, sL2. - destruct_tl_h2d. simpl in H. subst. - cbn in H1. - repeat (destruct_pair_let_hyp; - repeat (destruct_pair_equal_hyp; subst; cbn [fst snd])). - inversion H0; subst; + intros ? ? ? ? ? Ha_valid Hrel. + (* cbn in sL1, sL2. *) + (* destruct sL2 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). *) + (* destruct_tl_h2d. destruct_tl_d2h. tlsimpl. subst. *) + unfold device.run1. unfold counter_device. + intros Hstep. + destruct Hrel as [?repr [?Hrel ?Hinv]]. + assert (Hprec: precondition incr (h2d, tt) repr). + { destruct_tl_h2d. destruct_tl_d2h. tlsimpl. + cbn in sL1; destruct sL1 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner). + simplify_invariant incr. logical_simplify. + subst. cbn. ssplit. + - auto. + - intros. discriminate. + - intros. auto. + } + eapply incr_invariant_preserved in Hinv as Hinv'; [|reflexivity]. + unfold counter_related. exists (update_repr (c:=incr) (h2d, tt) repr). + rewrite surjective_pairing with (A:=counter_device) (B:=tl_d2h) + (p:=Semantics.step incr sL1 (h2d, tt)) in Hstep. + apply pair_equal_spec in Hstep. destruct Hstep as [Hstep1 Hstep2]. subst. + split; [| apply Hinv'; apply Hprec]. + inversion Hrel; subst; + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst; + cbn in sL1; destruct sL1 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + simplify_invariant incr; logical_simplify; subst; + cbn -[replace]. + all: try (destruct x as [|[|[|]]]); + destruct (outstanding_h2d r_tl), d_ready; + try destruct (TLUL.a_opcode t =? Get)%N, (TLUL.a_opcode t =? PutFullData)%N; try (rewrite incrN_word_to_bv); - try (constructor; try lia; simpl; boolsimpl; ssplit; reflexivity). - - (* state_machine_read_to_device_read_or_later: *) - case TODO. - (* - cbn [counter_device device.state device.is_ready_state device.run1 device.addr_range_start - device.addr_range_pastend device.maxRespDelay] in *. - cbn [increment_wait_state_machine - state_machine.state - state_machine.register - state_machine.is_initial_state - state_machine.read_step - state_machine.write_step - state_machine.reg_addr - state_machine.isMMIOAddr] in *. - simpl in sL. destruct sL as ((istate & value & tl_d2h) & tlul_state). - destruct_tl_d2h. destruct_tlul_adapter_reg_state. - destruct H as [v [sH' [Hbytes H]]]. rewrite Hbytes. - tlsimpl. - destruct r; simp. + boolsimpl; constructor; try assumption. + all: destruct H6; subst; destruct r_regs; cbn in H |- *; assumption. + - (* state_machine_read_to_device_read: *) + (* simpler because device.maxRespDelay=1 *) + intros ? ? ? ? [v [sH'' Hex_read]] [repr Hrel]. + cbn in Hex_read. logical_simplify. rewrite H1. + unfold counter_related. + match goal with + | |- context [ device.runUntilResp ?x _ _ ] => + remember x as h2d eqn:Eh2d; replace x with h2d + end. + assert (Hprec: precondition incr (h2d, tt) repr). + { destruct_tl_h2d. tlsimpl. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner). + simplify_invariant incr. logical_simplify. + subst. cbn. ssplit; intros; auto. + } + pose (r_ := r). destruct r. + (* r=VALUE *) - destruct_tl_h2d. - cbn in *. subst. - - destruct_consistent_states. subst. - destruct outstanding; cbn in H1|-*; fwd. - - - eexists _, _, _; ssplit; try reflexivity; cbn; rewrite Z_word_N by lia; - try (eapply IDLE_related; unfold consistent_states; ssplit; reflexivity); - try (apply N_to_word_word_to_N). + pose (sH_ := sH); destruct sH; cbn in H2; try (exfalso; assumption); logical_simplify; subst. + inversion H; subst. + eapply runUntilResp_big_step with (s:=sL) in Hprec + as [n [inputs [sL' [repr' [d2h [sL'' [HrunU [HmaxRespDelay [Einputs [EsL' [Erepr' [Hpostc' [Ed_valid Hinv'']]]]]]]]]]]]]; subst; auto. + exists d2h, sL'', IDLE. + ssplit. + 3: cbn; ssplit; try reflexivity; []. + * assumption. + * eexists. + split; [|apply Hinv'']. + simplify_invariant incr. + simplify_invariant Incr.inner. + simplify_invariant (tlul_adapter_reg (reg_count:=2)). + cbn in sL''; destruct sL'' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + clear HrunU. + pose (n_:=n). destruct n as [|[|n]]. + 3: unfold device.maxRespDelay, counter_device in HmaxRespDelay; exfalso; lia. + all: cbn [repeat fold_left] in *. + -- destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]. + logical_simplify. + cbn in H5. + destruct (outstanding_h2d r_tl) eqn:Houts. + ++ logical_simplify. rewrite Ed_valid in * |-. discriminate. + ++ cbn in H5. logical_simplify. + destruct_tl_d2h. tlsimpl. subst. + simplify_invariant incr. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + cbn in Hinv'' |- *. + rewrite Houts in Hinv'' |- *. cbn in Hinv''. logical_simplify. + cbn in *. + logical_simplify. subst. + rewrite Z_word_N in * by lia. cbn in *. logical_simplify. subst. + apply IDLE_related. + -- cbn in Hpostc'. + destruct (outstanding_h2d r_tl) eqn:Houts; + destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]; + logical_simplify; + cbn in H5; rewrite Houts in H5; cbn in H5; logical_simplify; subst. + ++ destruct_tl_d2h. tlsimpl. subst. + simplify_invariant incr. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + cbn in Hinv'' |- *. + rewrite Houts in Hinv'' |- *. cbn in Hinv'' |- *. logical_simplify. + rewrite Houts. cbn. + rewrite Z_word_N in * by lia. cbn in *. + destruct H8; subst; apply IDLE_related. + ++ rewrite Ed_valid in * |-. discriminate. + * pose (n_:=n). destruct n as [|[|n]]. + -- cbn [repeat fold_left] in *. + destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]. + logical_simplify. + cbn in H5. + destruct (outstanding_h2d r_tl) eqn:Houts. + ++ logical_simplify. rewrite Ed_valid in * |-. discriminate. + ++ cbn in H5. logical_simplify. + destruct_tl_d2h. tlsimpl. subst. + simplify_invariant incr. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + cbn in sL''; destruct sL'' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + cbn in Hinv''. + rewrite Houts in Hinv''. cbn in Hinv''. logical_simplify. + cbn in *. + logical_simplify. subst. + rewrite Z_word_N in * by lia. cbn in *. logical_simplify. subst. + rewrite H3. apply N_to_word_word_to_N. + -- cbn [repeat fold_left] in *. + cbn in Hpostc'. + destruct (outstanding_h2d r_tl) eqn:Houts; + destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]; + logical_simplify; + cbn in H5; rewrite Houts in H5; cbn in H5; logical_simplify; subst. + ++ destruct_tl_d2h. tlsimpl. subst. + simplify_invariant incr. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + cbn in sL''; destruct sL'' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + cbn in Hinv''. + rewrite Houts in Hinv''. cbn in Hinv''. logical_simplify. + rewrite Z_word_N in * by lia. cbn -[replace] in *. + destruct H8; subst; destruct r_regs; cbn in H3 |- *; + rewrite H3; apply N_to_word_word_to_N. + ++ rewrite Ed_valid in * |-. discriminate. + -- unfold device.maxRespDelay, counter_device in HmaxRespDelay. exfalso. lia. + (* r=STATUS *) - destruct sH; [| |]. - * (* sH=IDLE *) - inversion H0. subst. - destruct_consistent_states. subst. cbn. - repeat (rewrite Z_word_N by lia; cbn). - unfold status_value, STATUS_IDLE, N_to_word, word_to_N. - destruct outstanding; eexists _, _, _; ssplit; try reflexivity; - try (apply IDLE_related; simpl; ssplit; reflexivity); - try (simpl; unfold N_to_word; ZnWords). - * (* sH=BUSY *) - simpl. - unfold STATUS_ADDR, INCR_BASE_ADDR, N_to_word, word_to_N, status_value, STATUS_BUSY. - rewrite word.unsigned_of_Z. unfold word.wrap. - inversion H0; subst; [| |]. - -- (* BUSY1_related *) - destruct outstanding; eexists _, _, _; simpl; [|]. - ++ ssplit; try reflexivity; [|]. - ** rewrite incrN_word_to_bv. - apply BUSY_done_related; unfold consistent_states; ssplit; reflexivity. - ** right. eexists. ssplit; try reflexivity; [|]. - --- apply Nat.pred_inj; try lia. rewrite Nat.pred_succ. reflexivity. - --- simpl. ZnWords. - ++ ssplit; try reflexivity; [|]. - ** apply BUSY2_related. 1: shelve. unfold consistent_states. ssplit; reflexivity. - ** right. eexists. ssplit; try reflexivity; [|]. - --- apply Nat.pred_inj; try lia. rewrite Nat.pred_succ. reflexivity. - --- simpl. ZnWords. - Unshelve. lia. - -- (* BUSY2_related *) - destruct outstanding; eexists _, _, _; simpl; [|]. - ++ ssplit; try reflexivity; [|]. - ** rewrite incrN_word_to_bv. - apply DONE_related; unfold consistent_states; ssplit; reflexivity. - ** left. simpl. ssplit; try reflexivity. ZnWords. - ++ ssplit; try reflexivity; [|]. - ** rewrite incrN_word_to_bv. - apply BUSY_done_related; unfold consistent_states; ssplit; reflexivity. - ** right. eexists. ssplit; try reflexivity; [|]. - --- apply Nat.pred_inj; try lia. rewrite Nat.pred_succ. reflexivity. - --- simpl. ZnWords. - -- (* BUSY_done_related *) - (* the transition that was used to show that sH is not stuck was *) - (* a transition from BUSY to BUSY returning a busy flag, but *) - (* since the device already is in done state, it will return a *) - (* done flag in this transition, so the transition we use to *) - (* simulate what happened in the device is a BUSY-to-DONE *) - (* transition returning a done flag instead of a BUSY-to-BUSY *) - (* transition returning a busy flag. *) - destruct outstanding; eexists _, _, _; boolsimpl; simpl; - ssplit; try reflexivity; - try (apply DONE_related; unfold consistent_states; ssplit; reflexivity); - try (left; split; try reflexivity; simpl; ZnWords). - * (* sH=DONE *) - simpl. - unfold STATUS_ADDR, INCR_BASE_ADDR, N_to_word, word_to_N, status_value, STATUS_BUSY. - rewrite !word.unsigned_of_Z. unfold word.wrap. - inversion H0. subst. - destruct outstanding; eexists _, _, _; boolsimpl; simpl; - ssplit; try reflexivity; - try (eapply DONE_related; unfold consistent_states; ssplit; reflexivity); - try (simpl; ZnWords). - *) - - (* state_machine_write_to_device_write_or_later: *) - case TODO. - (* - destruct H as (sH' & ? & ?). subst. - unfold write_step in H1. - destruct r. 2: contradiction. - destruct sH; try contradiction. subst. - inversion H0. simpl in tl_d2h. simpl in tlul_state. - destruct_tl_d2h. destruct_tlul_adapter_reg_state. subst. cbn. - unfold word_to_N. - rewrite word.unsigned_of_Z_nowrap by (cbv; intuition discriminate). - destruct outstanding; boolsimpl; simpl; - eexists _, _, _; ssplit; try reflexivity; try assumption; apply BUSY1_related; - try lia; - try (unfold consistent_states; ssplit; reflexivity). - *) + eapply runUntilResp_big_step in Hprec as [n [inputs [sL' [repr' [d2h [sL'' [HrunU [HmaxRespDelay [Einputs [EsL' [Erepr' [Hpostc' [Ed_valid Hinv'']]]]]]]]]]]]]; subst; auto; [|eassumption]. + inversion H; subst. + * do 3 eexists; ssplit. + -- rewrite HrunU; reflexivity. + -- eexists; split; [|eassumption]; + destruct n as [|[|n]]; + [| |unfold device.maxRespDelay, counter_device in HmaxRespDelay; exfalso; lia]; + cbn [repeat fold_left] in *; + simplify_invariant incr; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + logical_simplify; subst; + cbn; destruct (outstanding_h2d r_tl) eqn:Eouts; + try (cbn; rewrite Eouts; cbn); + apply IDLE_related. + -- cbn. ssplit; try reflexivity. + destruct n as [|[|n]]; + [| |unfold device.maxRespDelay, counter_device in HmaxRespDelay; exfalso; lia]; + cbn [repeat fold_left] in *; simplify_spec incr; + simplify_spec (tlul_adapter_reg (reg_count:=2)). + ++ destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]; logical_simplify; cbn in H5; + destruct (outstanding_h2d r_tl) eqn:Eouts; + [logical_simplify; rewrite Ed_valid in *; discriminate|]; + cbn in H5; logical_simplify; rewrite H9. + unfold status_value, STATUS_IDLE, N_to_word, word_to_N. + simplify_invariant incr. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). + logical_simplify. + replace (N.to_nat ((N.land (Z.to_N (word.unsigned (word.of_Z 16388))) 4 / 4) mod 1073741824)) with 1. + ** ZnWords. + ** ZnWords_pre. rewrite Zmod_small; [|lia]. + rewrite N.mod_small; cbn; lia. + ++ admit. + * admit. + * admit. + * admit. + - (* state_machine_write_to_device_write: *) + admit. - (* read_step_unique: *) - simpl in *. unfold read_step in *. simp. + intros. simpl in *. unfold read_step in *. simp. destruct v; destruct r; try contradiction; simp; try reflexivity. destruct Hp1; destruct H0p1; simp; try reflexivity; unfold status_value in *; exfalso; ZnWords. - (* write_step_unique: *) - simpl in *. unfold write_step in *. simp. subst. reflexivity. + intros. simpl in *. unfold write_step in *. simp. subst. reflexivity. - (* initial_state_unique: *) - simpl in *. subst. reflexivity. + intros. simpl in *. subst. reflexivity. Qed. End WithParameters. diff --git a/firmware/IncrementWait/Incr.v b/firmware/IncrementWait/Incr.v new file mode 100644 index 000000000..d91c57b7f --- /dev/null +++ b/firmware/IncrementWait/Incr.v @@ -0,0 +1,598 @@ +Require Import Coq.Lists.List. +Require Import Coq.micromega.Lia. +Require Import Coq.ZArith.ZArith. + +Require Import Cava.Expr. +Require Import Cava.ExprProperties. +Require Import Cava.Invariant. +Require Import Cava.Primitives. +Require Import Cava.Semantics. +Require Import Cava.TLUL. +Require Import Cava.Types. +Require Import Cava.Util.BitArithmetic. +Require Import Cava.Util.List. +Require Import Cava.Util.Tactics. + +Require Import coqutil.Tactics.Simp. +Require Import coqutil.Tactics.Tactics. + +Import ListNotations. + +Section Var. + Import Expr. + Import ExprNotations. + Import PrimitiveNotations. + + Local Open Scope N. + + Context {var : tvar}. + + Definition incr_state := BitVec 2. + Definition Idle := Constant incr_state 0. + Definition Busy1 := Constant incr_state 1. + Definition Busy2 := Constant incr_state 2. + Definition Done := Constant incr_state 3. + + Definition inner + : Circuit _ [Bit; BitVec 32] (Bit ** BitVec 32) + := {{ + fun valid data => + let/delay '(istate; value) := + let istate' := + if istate == `Busy1` then `Busy2` + else if istate == `Busy2` then `Done` + else if istate == `Done` then `Idle` + else (* istate == `Idle` *) + if valid then `Busy1` + else `Idle` in + + let value' := + if istate == `Busy2` then value + `K 1` + else if istate == `Idle` then data + else value in + + (istate', value') + initially default + : denote_type (incr_state ** BitVec 32) + in + (istate == `Done`, value) + }}. + + Definition incr + : Circuit _ [tl_h2d_t] tl_d2h_t + := {{ + fun tl_h2d => + (* Destruct and reassemble tl_h2d with a_address that matches the + tlul_adapter_reg interface. *) + let '(a_valid + , a_opcode + , a_param + , a_size + , a_source + , a_address + , a_mask + , a_data + , a_user + ; d_ready) := tl_h2d in + (* Bit #2 of the address determines which register is being accessed *) + (* (STATUS or VALUE). Zero out the other bits. *) + let a_address := a_address & (`K 1` << 2) in + let tl_h2d := (a_valid + , a_opcode + , a_param + , a_size + , a_source + , a_address + , a_mask + , a_data + , a_user + , d_ready) in + + let/delay '(busy, done, registers; tl_d2h) := + let '(tl_d2h'; req) := `tlul_adapter_reg` tl_h2d registers in + let '(is_read, is_write, address, write_data; _write_mask) := req in + + let '(inner_res_valid; inner_res) := `inner` (!busy && !done && is_write) write_data in + + let busy' := + if busy then !inner_res_valid + else !done && is_write in + + let done' := + if busy then inner_res_valid + else if done then !(is_read && address == `K 0`) + else done in + + let registers' := + if inner_res_valid then `replace` registers `K (sz:=1) 0` inner_res + else registers in + + let registers' := + if busy' then `replace` registers' `K (sz:=1) 1` `K 2` + else if done' then `replace` registers' `K (sz:=1) 1` `K 4` + else `replace` registers' `K (sz:=1) 1` `K 1` in + + (busy', done', registers', tl_d2h') initially + (false, (false, ([0; 1], default (t:=tl_d2h_t)))) + : denote_type (Bit ** Bit ** Vec (BitVec 32) 2 ** tl_d2h_t) + in + + tl_d2h + }}. +End Var. + +Definition sim {s i o} (c : Circuit s i o) (input : list (denote_type i)) + : list (denote_type s * denote_type i * denote_type o) := + fst (List.fold_left (fun '(acc, s) i => + let '(s', o) := step c s i in + (acc ++ [(s, i, o)], s')) + input + ([], reset_state c)). +(* Print sample_trace. *) + +Example sample_trace := + Eval compute in + let nop := set_d_ready true tl_h2d_default in + let read_reg (r : N) := + set_a_valid true + (set_a_opcode Get + (set_a_size 2%N + (set_a_address r + (set_d_ready true tl_h2d_default)))) in + let write_val (v : N) := + set_a_valid true + (set_a_opcode PutFullData + (set_a_size 2%N + (set_a_address 0%N (* value-ref *) + (set_a_data v + (set_d_ready true tl_h2d_default))))) in + + sim incr + [ (nop, tt) + ; (read_reg 4, tt) (* status *) + ; (nop, tt) + ; (write_val 42, tt) + ; (nop, tt) + ; (nop, tt) + ; (read_reg 4, tt) (* status *) + ; (nop, tt) + ; (read_reg 0, tt) (* value *) + ; (nop, tt) + ; (read_reg 4, tt) (* status *) + ]%N. + +Section Spec. + Local Open Scope N. + + Variant inner_state := + | IISIdle + | IISBusy (data : N) (count : nat) + | IISDone (res : N). + + Notation inner_repr := inner_state. + + Global Instance inner_invariant : invariant_for inner inner_repr := + fun (state : denote_type (state_of inner)) repr => + let '(istate, value) := state in + match repr with + | IISIdle => istate = 0 + | IISBusy data c => (0 < c <= 2)%nat /\ istate = N.of_nat c /\ value = data + | IISDone res => istate = 3 /\ value = res + end. + + Definition inner_spec_step (input : denote_type (input_of inner)) repr := + let '(valid, (data, tt)) := input in + match repr with + | IISIdle => if valid then IISBusy data 1 else IISIdle + | IISBusy data 2 => IISDone ((data + 1) mod 2^32) + | IISBusy data c => IISBusy data (c + 1) + | IISDone _ => IISIdle + end. + + Instance inner_specification + : specification_for inner inner_repr := + {| reset_repr := IISIdle; + + update_repr := + fun (input : denote_type (input_of inner)) repr => + inner_spec_step input repr; + + precondition := + fun (input : denote_type (input_of inner)) repr => True; + + postcondition := + fun (input : denote_type (input_of inner)) repr + (output : denote_type (output_of inner)) => + let repr' := inner_spec_step input repr in + match repr' with + | IISDone res => output = (true, res) + | _ => exists res, output = (false, res) + end; + |}. + + Lemma inner_invariant_at_reset : invariant_at_reset inner. + Proof. + simplify_invariant inner. reflexivity. + Qed. + + Lemma inner_invariant_preserved : invariant_preserved inner. + Proof. + intros (valid, (data, t)) state repr. destruct t. + cbn in * |-. destruct state as (istate, value). + intros repr' ? Hinvar Hprec; subst. + simplify_invariant inner. + simplify_spec inner. + cbv [inner inner_spec_step]. stepsimpl. + repeat (destruct_pair_let; cbn [fst snd]). + destruct repr as [|? iiscount|?]; logical_simplify; subst. + - destruct valid; cbn; try ssplit; lia. + - destruct iiscount as [|[|[|iiscount]]]; cbn; ssplit; lia. + - reflexivity. + Qed. + + Lemma inner_output_correct : output_correct inner. + Proof. + intros (valid, (data, t)) state repr. destruct t. + cbn in * |-. destruct state as (istate, value). + remember (update_repr (c:=inner) (valid, (data, tt)) repr) as repr'. + intros Hinvar Hprec. + simplify_invariant inner. + simplify_spec inner. + cbv [inner inner_spec_step]. stepsimpl. + repeat (destruct_pair_let; cbn [fst snd]). + destruct repr as [|? iiscount|?]; logical_simplify; subst. + - destruct valid; eexists; cbn; try ssplit; reflexivity. + - destruct iiscount as [|[|[|iiscount]]]; try lia; try eexists; reflexivity. + - eexists. reflexivity. + Qed. + + Existing Instances inner_invariant_at_reset inner_invariant_preserved + inner_output_correct. + Global Instance inner_correctness : correctness_for inner. + Proof. constructor; typeclasses eauto. Defined. + + + Variant repr_state := + | RSIdle + | RSBusy (data : N) + | RSDone (res : N). + + Definition repr := (repr_state * list N * list tl_h2d * inner_repr)%type. + + Global Instance incr_invariant : invariant_for incr repr := + fun (state : denote_type (state_of incr)) repr => + let '((s_busy, (s_done, (s_regs, s_d2h))), (s_tlul, s_inner)) := state in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + tlul_invariant (reg_count:=2) s_tlul r_tlul + /\ inner_invariant s_inner r_inner + /\ match r_state with + | RSIdle => s_busy = false /\ s_done = false + /\ r_inner = IISIdle + /\ nth 1 r_regs 0%N = 1 + | RSBusy data => s_busy = true /\ s_done = false + /\ (exists c, r_inner = IISBusy data c) + /\ nth 1 r_regs 0%N = 2 + | RSDone res => s_busy = false /\ s_done = true + /\ (r_inner = IISDone res \/ r_inner = IISIdle) + /\ nth 0 r_regs 0%N = res + /\ nth 1 r_regs 0%N = 4 + end + /\ s_regs = r_regs + /\ length r_regs = 2%nat. + + Existing Instance tlul_specification. + + Instance incr_specification + : specification_for incr repr := + {| reset_repr := (RSIdle, [0; 1], [], IISIdle); + + update_repr := + fun (input : denote_type (input_of incr)) repr => + let '(i_h2d, tt) := input in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + + let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in + + let r_tlul' := + let tlul_input := (h2d, (r_regs, tt)) in + update_repr (c:=tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul in + + (* compute (some) tlul output *) + let '(is_read, is_write, address, write_data) := + match outstanding_h2d (h2d :: r_tlul) with + | None => (false, false, 0, 0) + | Some h2d' => + if a_opcode h2d' =? Get then + match outstanding_h2d r_tlul with + | None => (a_valid h2d, false, a_address h2d, 0) + | _ => (false, false, 0, 0) + end + else if a_opcode h2d' =? PutFullData then + match outstanding_h2d r_tlul with + | None => (false, a_valid h2d, a_address h2d, a_data h2d) + | _ => (false, false, 0, 0) + end + else (false, false, 0, 0) + end in + + let r_inner' := + let inner_input := (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) in + update_repr (c:=inner) inner_input r_inner in + + let r_state' := + match r_state with + | RSDone _ => + if negb (is_read && (address =? 0)) then r_state + else RSIdle + | _ => + match r_inner' with + | IISBusy data _ => RSBusy data + | IISDone res => RSDone res + | _ => r_state + end + end in + + let r_regs' := + match r_inner' with + | IISDone res => replace 0 res r_regs + | _ => r_regs + end in + + let r_regs' := + match r_state' with + | RSIdle => replace 1 1 r_regs' + | RSBusy _ => replace 1 2 r_regs' + | RSDone _ => replace 1 4 r_regs' + end in + + (r_state', r_regs', h2d :: r_tlul, r_inner'); + + precondition := + fun (input : denote_type (input_of incr)) repr => + let '(i_h2d, tt) := input in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + + let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in + + let tlul_input := (h2d, (r_regs, tt)) in + + let prec_tlul := + precondition (tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul in + + let prec_inner := + forall d2h is_read is_write address write_data write_mask, + postcondition (tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul + (d2h, (is_read, (is_write, (address, (write_data, write_mask))))) + -> precondition inner (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) r_inner in + + prec_tlul /\ prec_inner; + + postcondition := + fun (input : denote_type (input_of incr)) repr + (output : denote_type (output_of incr)) => + let '(i_h2d, tt) := input in + let '(r_state, r_regs, r_tlul, r_inner) := repr in + + let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in + + let postc_tlul := + let tlul_input := (h2d, (r_regs, tt)) in + exists req, + postcondition (tlul_adapter_reg (reg_count:=2)) + tlul_input r_tlul + (output, req) in + postc_tlul; + |}. + + Lemma incr_invariant_at_reset : invariant_at_reset incr. + Proof. + simplify_invariant incr. + cbn. ssplit; try reflexivity. + apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2)). + Qed. + + Existing Instance tlul_adapter_reg_correctness. + + Lemma incr_invariant_preserved : invariant_preserved incr. + Proof. + intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. + cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). + destruct_tl_h2d. destruct_tl_d2h. + intros repr' ? Hinvar Hprec; subst. + simplify_invariant incr. logical_simplify. subst. + simplify_spec incr. logical_simplify. subst. + (* destruct Hprec as [regs Hprec]. *) + cbv [incr]. stepsimpl. + use_correctness. + match goal with + | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => + rename H into Htl_postc + end. + repeat (destruct_pair_let; cbn [fst snd]). + ssplit. + - eapply tlul_adapter_reg_invariant_preserved. + 2: apply H. + + reflexivity. + + assumption. + - eapply inner_invariant_preserved. + 2: apply H0. + + simpl in *. + destruct r_inner; try reflexivity. + destruct (outstanding_h2d r_tlul) eqn:Houts. + * destruct d_ready; logical_simplify; subst. + -- boolsimpl. destruct r_state; reflexivity. + -- eapply outstanding_prec in H as Hprec_t. 2: apply Houts. + destruct Hprec_t as [Hprec_t|Hprec_t]; + rewrite Hprec_t in *; cbn in Htl_postc |- *; logical_simplify; subst; + boolsimpl; destruct r_state; reflexivity. + * destruct a_valid eqn:Hvalid; logical_simplify; subst. + -- cbn in Htl_postc. + match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; + boolsimpl; destruct r_state; logical_simplify; subst; + reflexivity. + -- boolsimpl; destruct r_state; reflexivity. + + match goal with + | H: context [_ -> precondition inner _ r_inner] |- _ => + eapply H + end. + do 8 eexists. ssplit. + 1-2: reflexivity. + apply Htl_postc. + - match goal with + | H: context [_ -> precondition inner _ r_inner] |- _ => clear H + end. + destruct r_inner; destruct r_state; destruct inner_st; + unfold inner_invariant in H0; logical_simplify; subst; + try discriminate; + try (destruct H4; discriminate). + all: destruct (outstanding_h2d r_tlul) eqn:Houts; + cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. + all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. + all: cbn; try (ssplit; try reflexivity; + destruct x0 as [|? [|]]; try discriminate H3; reflexivity). + all: try (eapply outstanding_prec in H; + try match goal with + | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => + apply H + end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; + logical_simplify; subst; ssplit; + try (left; reflexivity); + try (right; reflexivity); + try reflexivity; + destruct x0 as [|? [|]]; try discriminate H3; reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + logical_simplify; tlsimpl; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; try cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; + try eexists; + try reflexivity; + destruct x0 as [|? [|]]; try discriminate H3; reflexivity). + all: try (destruct a_valid; ssplit; + try (left; reflexivity); + try (right; reflexivity); + try reflexivity; + destruct x0 as [|? [|]]; try discriminate H3; reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; logical_simplify; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; try cbn in Htl_postc; logical_simplify; subst; + boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + cbn; try (rewrite Haddr); ssplit; + try (left; reflexivity); + try (right; reflexivity); + try reflexivity; + destruct x0 as [|? [|]]; try discriminate H3; reflexivity). + all: try (inversion H5; subst; clear H5; + destruct x as [|[|[|?]]]; cbn; ssplit; + try eexists; + try (left; reflexivity); + try (right; reflexivity); + try reflexivity; + try (destruct x0 as [|? [|]]; try discriminate H3; reflexivity); + exfalso; lia). + all: destruct H5; discriminate. + - match goal with + | H: context [_ -> precondition inner _ r_inner] |- _ => clear H + end. + destruct r_inner; destruct r_state; destruct inner_st; + unfold inner_invariant in H0; logical_simplify; subst; + try discriminate. + all: destruct (outstanding_h2d r_tlul) eqn:Houts; + cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. + all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. + all: try reflexivity. + all: try (destruct H5; discriminate). + all: try (inversion H5; subst; clear H5; + destruct x as [|[|[|?]]]; try reflexivity; exfalso; lia). + all: try (eapply outstanding_prec in H; + try match goal with + | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => + apply H + end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; + logical_simplify; subst; cbn; reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; logical_simplify; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; try cbn in Htl_postc; logical_simplify; subst; reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; logical_simplify; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; try cbn in Htl_postc; logical_simplify; subst; + boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + cbn; try (rewrite Haddr); reflexivity). + - all: match goal with + | |- length (match ?v with _ => _ end) = 2%nat => destruct v + end; + match goal with + | |- context [update_repr ?ui ?ur] => + remember (update_repr (c:=inner) ui ur) as up eqn:?H; + replace (update_repr (c:=inner) ui ur) with up; + destruct up + end; + rewrite ! length_replace; assumption. + Qed. + + Lemma incr_output_correct : output_correct incr. + Proof. + intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. + cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). + destruct_tl_h2d. destruct_tl_d2h. + intros Hinvar Hprec; subst. + simplify_invariant incr. logical_simplify. subst. + simplify_spec incr. logical_simplify. subst. + cbv [incr]. stepsimpl. + use_correctness. + match goal with + | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => + rename H into Htl_postc + end. + repeat (destruct_pair_let; cbn [fst snd]). + tlsimpl. + destruct r_inner; destruct r_state; destruct inner_st; + unfold inner_invariant in H0; logical_simplify; subst; + try discriminate; + try (destruct H5; discriminate). + all: destruct (outstanding_h2d r_tlul) eqn:Houts; + cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. + all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. + all: do 9 eexists. + all: ssplit; try reflexivity; tlsimpl; ssplit; try reflexivity; try assumption. + all: try (eapply outstanding_prec in H; + try match goal with + | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => + apply H + end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; + logical_simplify; subst; ssplit; + try (left; reflexivity); + try (right; reflexivity); + try assumption; + reflexivity). + all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); + tlsimpl; destruct H2; + try match goal with + | H: true = true -> _ |- _ => + destruct H; try reflexivity; subst + end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; + try eexists; try assumption; reflexivity). + Unshelve. all: auto. + Qed. + + Existing Instances incr_invariant_at_reset incr_invariant_preserved + incr_output_correct. + Global Instance incr_correctness : correctness_for incr. + Proof. constructor; typeclasses eauto. Defined. +End Spec. From 86e0bba084a2191feac2f6fccb6c0883e79a13f0 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 24 Nov 2021 08:59:34 +0000 Subject: [PATCH 12/16] wip --- cava2/TLUL.v | 386 +++------ firmware/IncrementWait/CavaIncrementDevice.v | 791 ++++++++++-------- firmware/IncrementWait/Incr.v | 381 +++++---- .../InternalMMIOMachine.v | 21 +- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 245 +++--- 5 files changed, 881 insertions(+), 943 deletions(-) diff --git a/cava2/TLUL.v b/cava2/TLUL.v index 818518ca0..9ed1dc319 100644 --- a/cava2/TLUL.v +++ b/cava2/TLUL.v @@ -133,7 +133,7 @@ Section Var. Definition sha_digest := Vec sha_word 8. Definition tlul_adapter_state := - (BitVec TL_AIW ** BitVec TL_SZW ** BitVec 3 ** Bit ** Bit ** Bit ** Bit)%circuit_type. + (BitVec TL_AIW ** BitVec TL_SZW ** BitVec 3 ** BitVec 32 ** Bit ** Bit ** Bit ** Bit)%circuit_type. (* Convert TLUL packets to a simple read/write register interface *) (* This is similar to OpenTitan's tlul_adapter_reg, but for simplicity we @@ -155,7 +155,9 @@ Section Var. , a_user ; d_ready) := incoming_tlp in - let/delay '(reqid, reqsz, rspop, error, outstanding, we_o; re_o) := + let/delay '(reqid, reqsz, rspop, reqaddress, error, outstanding, + (* output only signals: *) + we_o; re_o) := let a_ack := a_valid && !outstanding in let d_ack := outstanding && d_ready in @@ -168,24 +170,25 @@ Section Var. let err_internal := `Zero` in let error_i := `Zero` in - let '(reqid, reqsz, rspop, error; outstanding) := - if a_ack then - ( a_source - , a_size - , if rd_req then `K AccessAckData` else `K AccessAck` - , error_i || err_internal - , `One` - ) - else - (reqid, reqsz, rspop, error, if d_ack then `Zero` else outstanding) + let '(reqid, reqsz, rspop, reqaddress, error; outstanding) := + if a_ack then + ( a_source + , a_size + , if rd_req then `K AccessAckData` else `K AccessAck` + , a_address + , error_i || err_internal + , `One` + ) + else + (reqid, reqsz, rspop, reqaddress, error, if d_ack then `Zero` else outstanding) in let we_o := wr_req && !err_internal in let re_o := rd_req && !err_internal in - (reqid, reqsz, rspop, error, outstanding, we_o, re_o) - initially (0,(0,(0,(false,(false,(false,false)))))) - : denote_type (BitVec _ ** BitVec _ ** BitVec _ ** Bit ** Bit ** Bit ** Bit) + (reqid, reqsz, rspop, reqaddress, error, outstanding, we_o, re_o) + initially default + : denote_type (BitVec _ ** BitVec _ ** BitVec _ ** BitVec _ ** Bit ** Bit ** Bit ** Bit) in let wdata_o := a_data in @@ -197,7 +200,7 @@ Section Var. , reqsz , reqid , `K 0` - , `index` registers (`bvslice 2 30` a_address) + , `index` registers (`bvslice 2 30` reqaddress) , `K 0` , error , !outstanding @@ -210,7 +213,7 @@ End Var. Ltac destruct_tlul_adapter_reg_state reg_count := destruct_state (tlul_adapter_reg (var:=denote_type) (reg_count:=reg_count)) - ipattern:((?reqid, (?reqsz, (?rspop, (?error, (?outstanding, (?we_o, ?re_o))))))). + ipattern:((?reqid, (?reqsz, (?rspop, (?reqaddress, (?error, (?outstanding, (?we_o, ?re_o)))))))). Section StateGetters. Definition var : tvar := denote_type. @@ -222,6 +225,9 @@ Section StateGetters. : N := ltac:(destruct_tlul_adapter_reg_state reg_count; apply reqsz). Definition tlul_adapter_reg_state_rspop (s : denote_type (state_of (tlul_adapter_reg (reg_count:=reg_count)))) : N := ltac:(destruct_tlul_adapter_reg_state reg_count; apply rspop). + Definition tlul_adapter_reg_state_reqaddress (s : denote_type (state_of (tlul_adapter_reg (reg_count:=reg_count)))) + : N := ltac:(destruct_tlul_adapter_reg_state reg_count; apply reqaddress). + Definition tlul_adapter_reg_state_error (s : denote_type (state_of (tlul_adapter_reg (reg_count:=reg_count)))) : bool := ltac:(destruct_tlul_adapter_reg_state reg_count; apply error). Definition tlul_adapter_reg_state_outstanding (s : denote_type (state_of (tlul_adapter_reg (reg_count:=reg_count)))) @@ -234,9 +240,9 @@ End StateGetters. Ltac tlul_adapter_reg_state_simpl := cbn [tlul_adapter_reg_state_reqid tlul_adapter_reg_state_reqsz - tlul_adapter_reg_state_rspop tlul_adapter_reg_state_error - tlul_adapter_reg_state_outstanding tlul_adapter_reg_state_we_o - tlul_adapter_reg_state_re_o] in *. + tlul_adapter_reg_state_rspop tlul_adapter_reg_state_reqaddress + tlul_adapter_reg_state_error tlul_adapter_reg_state_outstanding + tlul_adapter_reg_state_we_o tlul_adapter_reg_state_re_o] in *. Definition tl_h2d := denote_type tl_h2d_t. Definition tl_h2d_default := default (t := tl_h2d_t). @@ -344,41 +350,45 @@ Ltac tlsimpl := set_d_sink set_d_data set_d_user set_d_error set_a_ready d_valid d_opcode d_param d_size d_source d_sink d_data d_user d_error a_ready] in *. -Section TLULSpec. +Section TLSpec. Local Open Scope N_scope. Context {reg_count : nat}. - Variant TLULState := - | OutstandingGet (reqid : N) (reqsz : N) - | OutstandingPutFullData (reqid : N). - - - Fixpoint outstanding_h2d (inputs : list tl_h2d) := - match inputs with - | [] => None - | h :: tl => - match outstanding_h2d tl with - | None => if a_valid h then Some h else None - | Some h' => if d_ready h then None else Some h' - end + Variant repr_state := + | Idle + | OutstandingAccessAckData (h2d : tl_h2d) (regs : list N) + | OutstandingAccessAck (h2d : tl_h2d). + + Definition update_repr_state (input : denote_type (input_of (tlul_adapter_reg (reg_count:=reg_count)))) repr := + let '(h2d, (regs, tt)) := input in + match repr with + | Idle => + if a_valid h2d then + if a_opcode h2d =? Get then + OutstandingAccessAckData h2d regs + else if a_opcode h2d =? PutFullData then + OutstandingAccessAck h2d + else (* unreachable *) repr + else + repr + | _ => + if d_ready h2d then Idle + else match repr with + | OutstandingAccessAckData h2d _ => OutstandingAccessAckData h2d regs + | _ => repr + end end. - Definition tlul_repr := list tl_h2d. + Instance tl_specification + : specification_for (tlul_adapter_reg (reg_count:=reg_count)) repr_state := + {| reset_repr := Idle; - Instance tlul_specification - : specification_for (tlul_adapter_reg (reg_count:=reg_count)) tlul_repr := - {| reset_repr := []; - - update_repr := - fun (input : denote_type (input_of (tlul_adapter_reg (reg_count:=reg_count)))) - (repr : tlul_repr) => - let '(h2d, (_regs, tt)) := input in - h2d :: repr; + update_repr := update_repr_state; precondition := fun (input : denote_type (input_of tlul_adapter_reg)) - (repr : tlul_repr) => + (repr : repr_state) => let '(h2d, (regs, tt)) := input in reg_count = length regs /\ (a_valid h2d = true @@ -386,14 +396,14 @@ Section TLULSpec. postcondition := fun (input : denote_type (input_of (tlul_adapter_reg (reg_count:=reg_count)))) - (repr : tlul_repr) + (repr : repr_state) (output : denote_type (output_of (tlul_adapter_reg (reg_count:=reg_count)))) => - exists h2d regs d2h io_re io_we io_address io_data io_mask, + exists h2d regs repr' d2h io_re io_we io_address io_data io_mask, input = (h2d, (regs, tt)) /\ output = (d2h, (io_re, (io_we, (io_address, (io_data, io_mask))))) - - /\ match outstanding_h2d (h2d :: repr) with - | None => + /\ repr' = update_repr_state input repr + /\ match repr' with + | Idle => d_valid d2h = false /\ d_param d2h = 0 /\ d_sink d2h = 0 @@ -403,39 +413,39 @@ Section TLULSpec. /\ io_re = false /\ io_we = false - | Some h2d' => - if a_opcode h2d' =? Get then + | OutstandingAccessAckData h2d regs => d_valid d2h = true /\ d_opcode d2h = AccessAckData /\ d_param d2h = 0 - /\ d_size d2h = a_size h2d' - /\ d_source d2h = a_source h2d' + /\ d_size d2h = (a_size h2d) + /\ d_source d2h = (a_source h2d) /\ d_sink d2h = 0 - /\ d_data d2h = List.nth (N.to_nat (((a_address h2d / 4) mod (2 ^ 30)))) regs 0%N + /\ d_data d2h = (List.nth (N.to_nat ((((a_address h2d) / 4) mod (2 ^ 30)))) regs 0%N) /\ d_user d2h = 0 /\ d_error d2h = false /\ a_ready d2h = false - /\ match outstanding_h2d repr with - | None => if a_valid h2d then + /\ match repr with + | Idle => if a_valid h2d then io_re = true /\ io_address = a_address h2d else io_re = false | _ => io_re = false end /\ io_we = false - else if a_opcode h2d' =? PutFullData then + + | OutstandingAccessAck h2d => d_valid d2h = true /\ d_opcode d2h = AccessAck /\ d_param d2h = 0 (* /\ d_size d2h = *) - /\ d_source d2h = a_source h2d' + /\ d_source d2h = (a_source h2d) /\ d_sink d2h = 0 /\ d_user d2h = 0 /\ d_error d2h = false /\ a_ready d2h = false /\ io_re = false - /\ match outstanding_h2d repr with - | None => if a_valid h2d then + /\ match repr with + | Idle => if a_valid h2d then io_we = true /\ io_address = a_address h2d /\ io_data = a_data h2d @@ -443,30 +453,28 @@ Section TLULSpec. else io_we = false | _ => io_we = false end - else True - end + end; |}. - Global Instance tlul_invariant : invariant_for (tlul_adapter_reg (reg_count:=reg_count)) tlul_repr := + Global Instance tlul_invariant : invariant_for (tlul_adapter_reg (reg_count:=reg_count)) repr_state := fun (state : denote_type (state_of tlul_adapter_reg)) repr => - Forall (fun h2d => (a_valid h2d = true - -> (a_opcode h2d = Get \/ a_opcode h2d = PutFullData))) - repr - /\ tlul_adapter_reg_state_error state = false - /\ match outstanding_h2d repr with - | None => + tlul_adapter_reg_state_error state = false + /\ match repr with + | Idle => tlul_adapter_reg_state_outstanding (reg_count:=reg_count) state = false - | Some h2d => - if a_opcode h2d =? Get then - tlul_adapter_reg_state_outstanding state = true - /\ tlul_adapter_reg_state_reqid state = a_source h2d - /\ tlul_adapter_reg_state_reqsz state = a_size h2d - /\ tlul_adapter_reg_state_rspop state = AccessAckData - else if a_opcode h2d =? PutFullData then - tlul_adapter_reg_state_outstanding state = true - /\ tlul_adapter_reg_state_reqid state = a_source h2d - /\ tlul_adapter_reg_state_rspop state = AccessAck - else False + | OutstandingAccessAckData h2d regs => + tlul_adapter_reg_state_outstanding state = true + /\ tlul_adapter_reg_state_reqid state = (a_source h2d) + /\ tlul_adapter_reg_state_reqsz state = (a_size h2d) + /\ tlul_adapter_reg_state_rspop state = AccessAckData + /\ tlul_adapter_reg_state_reqaddress state = (a_address h2d) + /\ reg_count = length regs + /\ a_opcode h2d = Get + | OutstandingAccessAck h2d => + tlul_adapter_reg_state_outstanding state = true + /\ tlul_adapter_reg_state_reqid state = (a_source h2d) + /\ tlul_adapter_reg_state_rspop state = AccessAck + /\ a_opcode h2d = PutFullData end. Lemma tlul_adapter_reg_invariant_at_reset : invariant_at_reset tlul_adapter_reg. @@ -479,72 +487,26 @@ Section TLULSpec. Lemma tlul_adapter_reg_invariant_preserved : invariant_preserved tlul_adapter_reg. Proof. - intros (h2d, (regs, t)) state repr. destruct t. + intros (h2d & regs & t) state repr. destruct t. cbn in state. destruct_tlul_adapter_reg_state reg_count. destruct_tl_h2d. intros; subst. simplify_invariant (tlul_adapter_reg (reg_count:=reg_count)). simplify_spec (tlul_adapter_reg (reg_count:=reg_count)). - cbv [tlul_adapter_reg]. - stepsimpl. + cbv [tlul_adapter_reg]. stepsimpl. tlul_adapter_reg_state_simpl. tlsimpl. logical_simplify. - match goal with - | h : reg_count = _ |- _ => clear h - end. repeat (destruct_pair_let; cbn [fst snd]). tlul_adapter_reg_state_simpl. + subst. ssplit. - - apply Forall_cons; assumption. - - destruct (a_valid0 && negb outstanding)%bool; subst; reflexivity. - - remember (outstanding_h2d - ((a_valid0, - (a_opcode0, - (a_param0, (a_size0, (a_source0, (a_address0, (a_mask0, (a_data0, (a_user0, d_ready0))))))))) :: repr)) as outs eqn:Eouts. - destruct outs; subst. - + simpl in Eouts. - remember (outstanding_h2d repr) as outs' eqn:Eouts'. - destruct outs'; subst. - * destruct d_ready0; subst. - -- discriminate Eouts. - -- inversion Eouts; subst; clear Eouts. - destruct (a_opcode t0 =? Get). - ++ logical_simplify. subst. boolsimpl. - ssplit; reflexivity. - ++ destruct (a_opcode t0 =? PutFullData). - ** logical_simplify. subst. boolsimpl. - ssplit; reflexivity. - ** auto. - * destruct a_valid0. - -- inversion Eouts; subst; clear Eouts. - cbn. - destruct (a_opcode0 =? Get) eqn:Hget. - ++ ssplit; reflexivity. - ++ destruct (a_opcode0 =? PutFullData) eqn:Hput. - ** ssplit; reflexivity. - ** apply N.eqb_neq in Hget, Hput. - destruct H1. - --- reflexivity. - --- apply Hget. assumption. - --- apply Hput. assumption. - -- discriminate Eouts. - + simpl in Eouts. - remember (outstanding_h2d repr) as outs' eqn:Eouts'. - destruct outs'; subst. - -- destruct (a_opcode t =? Get) eqn:Hget. - ++ logical_simplify; subst. boolsimpl. - destruct d_ready0. - ** reflexivity. - ** discriminate Eouts. - ++ destruct (a_opcode t =? PutFullData) eqn:Hput. - ** logical_simplify; subst. boolsimpl. - destruct d_ready0. - --- reflexivity. - --- discriminate Eouts. - ** exfalso. assumption. - -- destruct a_valid0. - +++ discriminate Eouts. - +++ boolsimpl. reflexivity. + - destruct (a_valid0 && negb outstanding)%bool; reflexivity. + - unfold update_repr_state. + destruct repr; [destruct a_valid0 | destruct d_ready0 ..]; + tlsimpl; boolsimpl. + 2-6: logical_simplify; subst outstanding; boolsimpl; ssplit; try reflexivity; assumption. + destruct H1; [reflexivity|..]; subst outstanding a_opcode0; cbn; [|auto]. + ssplit; try reflexivity; assumption. Qed. Lemma tlul_adapter_reg_output_correct : output_correct tlul_adapter_reg. @@ -558,143 +520,29 @@ Section TLULSpec. simplify_spec (tlul_adapter_reg (reg_count:=reg_count)). cbv [tlul_adapter_reg]. stepsimpl. logical_simplify. tlul_adapter_reg_state_simpl. tlsimpl. - rewrite List.resize_noop by assumption. - match goal with - | h : reg_count = _ |- _ => clear h - end. + (* match goal with *) + (* | h : reg_count = _ |- _ => clear h *) + (* end. *) subst. repeat (destruct_pair_let; cbn [fst snd]). - remember (outstanding_h2d - ((a_valid0, - (a_opcode0, - (a_param0, (a_size0, (a_source0, (a_address0, (a_mask0, (a_data0, (a_user0, d_ready0))))))))) :: repr)) as outs eqn:Eouts. - destruct outs; subst. - - simpl in Eouts. - remember (outstanding_h2d repr) as outs' eqn:Eouts'. - destruct outs'; subst; - destruct d_ready0; try discriminate Eouts; inversion Eouts; subst; clear Eouts. - + destruct (a_opcode t0 =? Get) eqn:Hget; logical_simplify; subst; boolsimpl. - * do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. rewrite Hget. tlsimpl. - ssplit; try reflexivity. - rewrite N.land_ones. - replace 4 with (2 ^ 2) by reflexivity. - rewrite <- ! N.shiftr_div_pow2. - reflexivity. - * destruct (a_opcode t0 =? PutFullData) eqn:Hput; logical_simplify; subst; boolsimpl. - -- do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. rewrite Hget, Hput. tlsimpl. - ssplit; reflexivity. - -- exfalso. assumption. - + destruct a_valid0; try discriminate H1. - inversion H1; subst. clear H1. - do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. tlsimpl. - destruct H3. - * reflexivity. - * subst. boolsimpl. cbn -[N.ones]. - ssplit; try reflexivity. - rewrite N.land_ones. - replace 4 with (2 ^ 2) by reflexivity. - rewrite <- ! N.shiftr_div_pow2. - reflexivity. - * subst. boolsimpl. cbn. ssplit; reflexivity. - + destruct a_valid0; try discriminate H1. - inversion H1; subst. clear H1. - do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. tlsimpl. - destruct H3. - * reflexivity. - * subst. boolsimpl. cbn -[N.ones]. - ssplit; try reflexivity. - rewrite N.land_ones. - replace 4 with (2 ^ 2) by reflexivity. - rewrite <- ! N.shiftr_div_pow2. - reflexivity. - * subst. boolsimpl. cbn. ssplit; reflexivity. - - simpl in Eouts. - remember (outstanding_h2d repr) as outs' eqn:Eouts'. - destruct outs'; subst; - destruct d_ready0; try discriminate Eouts; inversion Eouts; subst; clear Eouts. - + destruct (a_opcode t =? Get) eqn:Hget; logical_simplify; subst; boolsimpl. - * do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. tlsimpl. - ssplit; reflexivity. - * destruct (a_opcode t =? PutFullData) eqn:Hput; logical_simplify; subst; boolsimpl. - -- do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. tlsimpl. - ssplit; reflexivity. - -- exfalso. assumption. - + destruct a_valid0; try discriminate H1. - clear H1. - do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. tlsimpl. - ssplit; reflexivity. - + destruct a_valid0; try discriminate H1. - clear H1. - do 8 eexists. split. 1: reflexivity. - cbn -[N.ones]. split. 1: reflexivity. - subst. rewrite <- Eouts'. tlsimpl. - ssplit; reflexivity. + destruct repr; destruct a_valid0; destruct d_ready0; + tlsimpl; boolsimpl; subst. + all: try match goal with + | H: true = true -> _ |- _ => + destruct H; [auto|subst..] + end. + all: logical_simplify; subst; boolsimpl. + all: repeat eexists; cbn. + all: rewrite List.resize_noop by assumption. + all: change 1073741823 with (N.ones 30); + rewrite N.land_ones; + replace 4 with (2 ^ 2) by reflexivity; + rewrite <- ! N.shiftr_div_pow2; + try reflexivity. Qed. Existing Instances tlul_adapter_reg_invariant_at_reset tlul_adapter_reg_invariant_preserved tlul_adapter_reg_output_correct. Global Instance tlul_adapter_reg_correctness : correctness_for tlul_adapter_reg. Proof. constructor; typeclasses eauto. Defined. - - - - Lemma outstanding_in_repr : forall r_tlul t, - outstanding_h2d r_tlul = Some t -> - In t r_tlul. - Proof. - intros ? ?. - induction r_tlul; intros Houts; cbn in Houts. - - discriminate. - - destruct (outstanding_h2d r_tlul) eqn:Houts'. - + destruct d_ready. - * discriminate. - * apply in_cons. auto. - + destruct (a_valid a). - * inversion Houts. apply in_eq. - * discriminate. - Qed. - - Lemma outstanding_a_valid : forall r_tlul t, - outstanding_h2d r_tlul = Some t -> - a_valid t = true. - Proof. - intros ? ?. - induction r_tlul; intros Houts; cbn in Houts. - - discriminate. - - destruct (outstanding_h2d r_tlul) eqn:Houts'. - + destruct d_ready. - * discriminate. - * auto. - + destruct (a_valid a) eqn:Hvalid. - * inversion Houts. subst. assumption. - * discriminate. - Qed. - - Lemma outstanding_prec : forall tl_st r_tlul t, - tlul_invariant tl_st r_tlul -> - outstanding_h2d r_tlul = Some t -> - a_opcode t = Get \/ a_opcode t = PutFullData. - Proof. - intros ? ? ? Hinvar Houts. simpl in *. - apply outstanding_in_repr in Houts as Hin. - unfold tlul_invariant in Hinvar. logical_simplify. - eapply Forall_forall in H. 2: apply Hin. - apply H. - eapply outstanding_a_valid. - apply Houts. - Qed. -End TLULSpec. +End TLSpec. diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index e1fa7bb7e..adae7a8c3 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -34,47 +34,96 @@ Import ListNotations. Section WithParameters. Instance var : tvar := denote_type. + Existing Instance Incr.inner_specification. + Existing Instance Incr.inner_correctness. + Existing Instance Incr.inner_invariant. + + Existing Instance TLUL.tl_specification. + Existing Instance TLUL.tlul_invariant. + Existing Instance TLUL.tlul_adapter_reg_correctness. + + Existing Instance incr_specification. + Existing Instance incr_invariant. + Existing Instance incr_correctness. + Context {word: Interface.word 32} {word_ok: word.ok word} {Mem: map.map word byte} {Registers: map.map Z word}. Global Instance counter_device: device := {| device.state := denote_type (state_of incr); - device.is_ready_state s := exists r_regs r_tlul r_inner, - incr_invariant s (RSIdle, r_regs, r_tlul, r_inner); - device.run1 s i := Semantics.step incr s (i, tt); + device.is_ready_state s := exists r_prev_state r_regs r_inner, + incr_invariant s (RSIdle, r_prev_state, r_regs, TLUL.Idle, r_inner); + device.last_d2h '((_, (_, (_, d2h))), _) := d2h; + device.tl_inflight_ops '((_, (_, (_, d2h))), _) := + if d_valid d2h then [d_source d2h] else []; + device.run1 s i := fst (Semantics.step incr s (i, tt)); device.addr_range_start := INCR_BASE_ADDR; device.addr_range_pastend := INCR_END_ADDR; - device.maxRespDelay '((istate, (val, tl_d2h)), tlul_state) h2d := - (* if the value register was requested, and we're in state Busy1, it will take one - more cycle to respond, else we will respond immediately *) - if ((a_address h2d mod 8 =? 0(*register address=VALUE*))%N && (istate =? 1 (*Busy1*))%N)%bool - then 1%nat else 0%nat; + device.maxRespDelay '((_, (_, (_, d2h))), _) := + if a_ready d2h then 2 + else if d_valid d2h then 1 + else 0; + (* The last [else] is not reachable, because [d_valid] is always the + negation of [a_ready]. *) |}. (* conservative upper bound matching the instance given in IncrementWaitToRiscv *) Global Instance circuit_spec : circuit_behavior := {| ncycles_processing := 15%nat |}. - Inductive counter_related_spec: IncrementWaitSemantics.state -> repr -> Prop := - | IDLE_related: forall r_regs r_tl r_inner, - counter_related_spec IDLE (RSIdle, r_regs, r_tl, r_inner) - | BUSY_related: forall r_regs r_tl r_inner val ncycles, + + Inductive counter_related_base: IncrementWaitSemantics.state -> Incr.repr_state -> Incr.inner_state -> Prop := + | IDLE_related: forall r_innr, + counter_related_base IDLE RSIdle r_innr + | BUSY1_related: forall val ncycles, + (1 < ncycles)%nat -> + counter_related_base (BUSY val ncycles) (RSBusy (word_to_N val)) + (IISBusy (word_to_N val) 1) + | BUSY2_related: forall val ncycles, (0 < ncycles)%nat -> - counter_related_spec (BUSY val ncycles) - (RSBusy (word_to_N val), r_regs, r_tl, r_inner) + counter_related_base (BUSY val ncycles) (RSBusy (word_to_N val)) + (IISBusy (word_to_N val) 2) (* the hardware is already done, but the software hasn't polled it yet to find out, so we have to relate a software-BUSY to a hardware-done: *) - | BUSY_done_related: forall r_regs r_tl r_inner val ncycles, - counter_related_spec (BUSY val ncycles) - (RSDone (word_to_N (word.add (word.of_Z 1) val)), r_regs, r_tl, r_inner) - | DONE_related: forall r_regs r_tl r_inner val, - nth 0 r_regs 0%N = (word_to_N val) - -> counter_related_spec (DONE val) - (RSDone (word_to_N val), r_regs, r_tl, r_inner). - - Definition counter_related (sH : IncrementWaitSemantics.state) - (sL : denote_type (state_of incr)) : Prop := - exists repr, counter_related_spec sH repr /\ incr_invariant sL repr. + | BUSY_done_related: forall val ncycles r_innr, + counter_related_base (BUSY val ncycles) (RSDone (word_to_N (word.add (word.of_Z 1) val))) r_innr + | DONE_related: forall val r_innr, + counter_related_base (DONE val) (RSDone (word_to_N val)) r_innr. + + Inductive counter_related_spec: IncrementWaitSemantics.state -> repr -> + list tl_h2d -> Prop := + | No_inflight: forall sH r_state r_prev_state r_regs r_inner, + counter_related_base sH r_state r_inner -> + counter_related_spec sH (r_state, r_prev_state, r_regs, TLUL.Idle, r_inner) [] + | Inflight_read_status: forall sH r_state r_prev_state r_regs r_tl r_tl_regs r_inner h2d, + counter_related_base sH r_state r_inner -> + r_tl = TLUL.OutstandingAccessAckData (set_a_address 4 h2d) r_tl_regs -> + a_valid h2d = true -> + a_opcode h2d = Get -> + a_address h2d = word_to_N (state_machine.reg_addr STATUS) -> + counter_related_spec sH (r_state, r_prev_state, r_regs, r_tl, r_inner) [h2d] + | Inflight_read_value: forall r_prev_state r_regs r_tl r_tl_regs r_inner val h2d, + r_tl = TLUL.OutstandingAccessAckData (set_a_address 0 h2d) r_tl_regs -> + nth 0 r_tl_regs 0%N = word_to_N val -> + a_valid h2d = true -> + a_opcode h2d = Get -> + a_address h2d = word_to_N (state_machine.reg_addr VALUE) -> + counter_related_spec (DONE val) + (RSIdle, r_prev_state, r_regs, r_tl, r_inner) + [h2d] + | Inflight_write_value: forall r_prev_state r_regs r_tl r_inner val h2d, + r_tl = TLUL.OutstandingAccessAck (set_a_address 0 h2d) -> + a_valid h2d = true -> + a_opcode h2d = PutFullData -> + a_address h2d = word_to_N (state_machine.reg_addr VALUE) -> + a_data h2d = (word_to_N val) -> + counter_related_spec (IDLE) + (RSBusy (word_to_N val), r_prev_state, r_regs, r_tl, r_inner) + [h2d]. + + Definition counter_related {invariant : invariant_for incr repr} (sH : IncrementWaitSemantics.state) + (sL : denote_type (state_of incr)) (inflight_h2ds : list tl_h2d) : Prop := + exists repr, counter_related_spec sH repr inflight_h2ds /\ invariant sL repr. (* This should be in bedrock2.ZnWords. It is use by ZnWords, which is used in the two following Lemmas. *) @@ -104,162 +153,81 @@ Section WithParameters. eapply pair_equal_spec in H; destruct H as [?H0 ?H1] end. - (* Ltac destruct_tlul_adapter_reg_state := *) - (* match goal with *) - (* | H : N * (N * (N * (bool * (bool * (bool * bool))))) |- _ => *) - (* destruct H as [?reqid [?reqsz [?rspop [?error [?outstanding [?we_o ?re_o]]]]]] *) - (* end. *) - Lemma N_to_word_word_to_N: forall v, N_to_word (word_to_N v) = v. Proof. intros. unfold N_to_word, word_to_N. ZnWords. Qed. - Existing Instance Incr.inner_specification. - Existing Instance Incr.inner_correctness. - Existing Instance Incr.inner_invariant. +(* TODO move to coqutil *) +Ltac contradictory H := + lazymatch type of H with + | ?x <> ?x => exfalso; apply (H eq_refl) + | False => case H + end. - Existing Instance TLUL.tlul_specification. - Existing Instance TLUL.tlul_adapter_reg_correctness. - Existing Instance TLUL.tlul_invariant. +Require Import coqutil.Tactics.autoforward. - Existing Instance incr_specification. - Existing Instance incr_correctness. +Ltac fwd_step ::= + match goal with + | H: ?T |- _ => is_destructible_and T; destr_and H + | H: exists y, _ |- _ => let yf := fresh y in destruct H as [yf H] + | H: ?x = ?x |- _ => clear H + | H: True |- _ => clear H + | H: ?LHS = ?RHS |- _ => + let h1 := head_of_app LHS in is_constructor h1; + let h2 := head_of_app RHS in is_constructor h2; + (* if not eq, H is a contradiction, but we don't want to change the number + of open goals in this tactic *) + constr_eq h1 h2; + (* we don't use `inversion H` or `injection H` because they unfold definitions *) + inv_rec LHS RHS; + clear H + | E: ?x = ?RHS |- context[match ?x with _ => _ end] => + let h := head_of_app RHS in is_constructor h; rewrite E in * + | H: context[match ?x with _ => _ end], E: ?x = ?RHS |- _ => + let h := head_of_app RHS in is_constructor h; rewrite E in * + | H: context[match ?x with _ => _ end] |- _ => + (* note: recursive invocation of fwd_step for contradictory cases *) + destr x; try solve [repeat fwd_step; contradictory H]; [] + | H: _ |- _ => autoforward with typeclass_instances in H + | |- _ => progress subst + | |- _ => progress fwd_rewrites + end. - Lemma runUntilResp_big_step : forall s h2d repr, - precondition incr (h2d, tt) repr - -> a_valid h2d = true - -> d_ready h2d = true (* TODO: do we need this? *) - -> incr_invariant s repr - -> exists n inputs s' repr' d2h s'', - device.runUntilResp h2d device.maxRespDelay s = (Some d2h, s'') - /\ n <= device.maxRespDelay - /\ inputs = repeat (h2d, tt) n - /\ s' = snd (simulate' incr inputs s) - (* /\ (s'', d2h) = Semantics.step incr s' (h2d, tt) *) - /\ repr' = fold_left (fun r i => update_repr (c:=incr) i r) inputs repr - (* /\ invariant s' repr' *) - /\ postcondition incr (h2d, tt) repr' d2h - /\ d_valid d2h = true - /\ incr_invariant s'' (update_repr (c:=incr) (h2d, tt) repr'). - Proof. - intros ? ? ? Hprec Ea_valid Ed_ready Hinv. - unfold device.maxRespDelay, device.runUntilResp, device.state, device.run1, counter_device, - state_machine.read_step, increment_wait_state_machine, read_step in *. - eapply output_correct_pf in Hinv as Houtput. - apply Houtput in Hprec as Hpostc. clear Houtput. - cbn in s, h2d. destruct_tl_h2d. - destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner). - assert (Hprec_temp := Hprec). - unfold precondition, incr_specification in Hprec_temp. - logical_simplify. - unfold precondition, tlul_specification in H. - logical_simplify. tlsimpl. subst. - unfold postcondition, incr_specification in Hpostc. - unfold postcondition, tlul_specification in Hpostc. - destruct Hpostc as [[is_read [is_write [address [w_val w_mask]]]] [h2d' [regs' [d2h' [is_read' [is_write' [address' [w_val' [w_mask' Hpostc]]]]]]]]]. - destruct_tl_h2d. destruct_tl_d2h. tlsimpl. - destruct Hpostc as [Hpostc1 [Hpostc2 Hpostc3]]. - subst. - apply pair_equal_spec in Hpostc2. - logical_simplify. - cbn [outstanding_h2d] in Hpostc3. - destruct (outstanding_h2d r_tl) eqn:Eouts. - - cbn in Hpostc3. logical_simplify. subst. - assert (Hprec': - precondition incr - (true, - (a_opcode0, - (a_param0, (a_size0, (a_source0, (a_address, (a_mask0, (a_data0, (a_user0, true)))))))), tt) - (update_repr (c:=incr) - (true, - (a_opcode0, - (a_param0, (a_size0, (a_source0, (a_address, (a_mask0, (a_data0, (a_user0, true)))))))), tt) - (r_state, regs', r_tl, r_inner))). - { simplify_spec incr. - cbn [outstanding_h2d]. rewrite Eouts. - tlsimpl. ssplit. - - simplify_spec (tlul_adapter_reg (reg_count:=2)). tlsimpl. split; [|assumption]. - match goal with - | |- context [length (match ?m with | _=> _ end)] => - destruct m - end; - match goal with - | |- context [replace _ _ (match ?m with | _=> _ end)] => - destruct m - end; rewrite ! length_replace; assumption. - - simplify_spec Incr.inner. intros. apply I. - } - destruct H1; [auto|..]; subst. - all: exists 1. - all: destruct_pair_let; - match goal with - | |- context [if d_valid ?c then _ else _] => - match type of H2 with - | _ = ?r => replace c with r - end - end. - all: tlsimpl; - assert (Hinv' := Hprec); - eapply incr_invariant_preserved in Hinv; - [apply Hinv in Hinv'|reflexivity]; clear Hinv. - all: eapply output_correct_pf in Hinv' as Houtput'; - apply Houtput' in Hprec' as Hpostc'; clear Houtput'; - assert (Hpostc'' := Hpostc'); - unfold postcondition, incr_specification in Hpostc'; - unfold postcondition, tlul_specification in Hpostc'; - cbn [update_repr outstanding_h2d] in Hpostc'; - rewrite Eouts in Hpostc'; cbn -[Semantics.step] in Hpostc'; - destruct Hpostc' as [[is_read [is_write [address [w_val w_mask]]]] [h2d' [regs'' [d2h' [is_read' [is_write' [address'' [w_val'' [w_mask'' Hpostc']]]]]]]]]. - all: destruct_tl_h2d; destruct_tl_d2h; tlsimpl; - destruct Hpostc' as [Hpostc1' [Hpostc2' Hpostc3']]; - subst; - apply pair_equal_spec in Hpostc2'; - logical_simplify; - rewrite Eouts in Hpostc3'; - tlsimpl. - all: cbn in Hpostc3'; logical_simplify; subst. - all: do 5 eexists; ssplit; try reflexivity. - 1,5: destruct_pair_let; - match goal with - | |- context [if d_valid ?c then _ else _] => - match type of H1 with - | _ = ?r => replace c with r - end - end; tlsimpl; reflexivity. - 1,4: cbn [repeat fold_left]; - match goal with - | H: postcondition incr _ _ ?c |- _ => - match type of H1 with - | _ = ?r => replace c with r in H; apply H - end - end. - 1,3: reflexivity. - 1,2: cbn [repeat fold_left]; - eapply incr_invariant_preserved; [reflexivity|assumption..]. - - destruct H1; [auto|..]; subst; cbn in Hpostc3; logical_simplify; subst. - all: exists 0. - all: do 5 eexists; ssplit; try reflexivity; try lia. - 1,5: destruct_pair_let; - match goal with - | |- context [if d_valid ?c then _ else _] => - match type of H2 with - | _ = ?r => replace c with r - end - end; tlsimpl; reflexivity. - 1,4: cbn [repeat fold_left]; - eapply output_correct_pf in Hinv as Houtput; - apply Houtput in Hprec; - match goal with - | H: postcondition incr _ _ ?c |- _ => - match type of H2 with - | _ = ?r => replace c with r in H; apply H - end - end. - 1,3: reflexivity. - 1,2: cbn [repeat fold_left]; - eapply incr_invariant_preserved; [reflexivity|assumption..]. - Qed. + Axiom TODO: False. + + Ltac use_spec := + match goal with + | Hrun: device.run1 ?sL ?input = ?sL', + Hinv: incr_invariant ?sL ?repr + |- _ => + assert (Hprec: precondition incr (input, tt) repr); + [| + (* pose proof (output_correct_pf (c:=incr) (input, tt) sL repr Hinv Hprec) as Hpostc. *) + remember (update_repr (c:=incr) (input, tt) repr) as repr' eqn:Erepr'; + pose proof (invariant_preserved_pf (c:=incr) (input, tt) sL repr repr' Erepr' Hinv Hprec) as Hinv'; + unfold device.run1, counter_device in Hrun; + match type of Hrun with + | fst ?step = _ => + remember step as res eqn:Hstep; + destruct res as (?sL'' & ?d2h); + cbn in Hrun; subst sL''; clear Hstep + end; + cbn [fst] in Hinv'] + end. + + Ltac inversion_rel_spec := + match goal with + | H: counter_related_spec _ _ _ |- _ => inversion H; subst + end. + Ltac inversion_rel_base := + match goal with + | H: counter_related_base _ _ _ |- _ => inversion H; subst + end. + + (* Lemma output_last_d2h : forall s h2d s' d2h, *) + (* (s', d2h) = Semantics.step incr s (h2d, tt) -> *) + (* device.last_d2h s' = d2h. *) + (* Proof. *) - (* Set Printing All. *) Global Instance cava_counter_satisfies_state_machine: device_implements_state_machine counter_device increment_wait_state_machine. Proof. @@ -267,194 +235,323 @@ Section WithParameters. - (* mmioAddrs_match: *) reflexivity. - (* initial_state_is_ready_state: *) - intros ? ? Hinit Hrel. + intros ? ? ? Hrel. cbn in *. subst. destruct Hrel as [?repr [?Hrel ?Hinv]]. - inversion Hrel. subst. - do 3 eexists. eapply Hinv. + inversion_rel_spec. inversion_rel_base. + repeat eexists. eapply Hinv. - (* initial_states_are_related: *) - intros ? ? Hinit Hready. - cbn in *. destruct Hready as (?r_regs & ?r_tl & ?r_inner & ?Hinv). subst. + intros ? ? ? Hready. + cbn in *. destruct Hready as (?r_prev_state & ?r_regs & ?r_inner & ?Hinv). subst. unfold counter_related. eexists. split; [|apply Hinv]. - apply IDLE_related. + apply No_inflight, IDLE_related. - (* initial_state_exists: *) intros ? Hready. - cbn in *. destruct Hready as (?r_regs & ?r_tl & ?r_inner & ?Hinv). + cbn in *. destruct Hready as (?r_prev_state & ?r_regs & ?r_inner & ?Hinv). eexists. split; [reflexivity|]. unfold counter_related. eexists. split; [|apply Hinv]. - apply IDLE_related. + apply No_inflight, IDLE_related. - (* nonMMIO_device_step_preserves_state_machine_state: *) - intros ? ? ? ? ? Ha_valid Hrel. - (* cbn in sL1, sL2. *) - (* destruct sL2 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). *) - (* destruct_tl_h2d. destruct_tl_d2h. tlsimpl. subst. *) - unfold device.run1. unfold counter_device. - intros Hstep. - destruct Hrel as [?repr [?Hrel ?Hinv]]. - assert (Hprec: precondition incr (h2d, tt) repr). + intros ? ? ? ? Ha_valid [repr [Hrel Hinv]] **. + use_spec. { destruct_tl_h2d. destruct_tl_d2h. tlsimpl. cbn in sL1; destruct sL1 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner). + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner). simplify_invariant incr. logical_simplify. - subst. cbn. ssplit. - - auto. - - intros. discriminate. - - intros. auto. + subst. cbn. ssplit; intros; [auto|discriminate|auto]. } - eapply incr_invariant_preserved in Hinv as Hinv'; [|reflexivity]. - unfold counter_related. exists (update_repr (c:=incr) (h2d, tt) repr). - rewrite surjective_pairing with (A:=counter_device) (B:=tl_d2h) - (p:=Semantics.step incr sL1 (h2d, tt)) in Hstep. - apply pair_equal_spec in Hstep. destruct Hstep as [Hstep1 Hstep2]. subst. - split; [| apply Hinv'; apply Hprec]. - inversion Hrel; subst; + exists repr'; split; [|auto]. + inversion_rel_spec; inversion_rel_base; destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst; cbn in sL1; destruct sL1 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - simplify_invariant incr; logical_simplify; subst; - cbn -[replace]. - all: try (destruct x as [|[|[|]]]); - destruct (outstanding_h2d r_tl), d_ready; - try destruct (TLUL.a_opcode t =? Get)%N, (TLUL.a_opcode t =? PutFullData)%N; - try (rewrite incrN_word_to_bv); - boolsimpl; constructor; try assumption. - all: destruct H6; subst; destruct r_regs; cbn in H |- *; assumption. - - (* state_machine_read_to_device_read: *) - (* simpler because device.maxRespDelay=1 *) - intros ? ? ? ? [v [sH'' Hex_read]] [repr Hrel]. - cbn in Hex_read. logical_simplify. rewrite H1. - unfold counter_related. - match goal with - | |- context [ device.runUntilResp ?x _ _ ] => - remember x as h2d eqn:Eh2d; replace x with h2d - end. - assert (Hprec: precondition incr (h2d, tt) repr). - { destruct_tl_h2d. tlsimpl. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner). - simplify_invariant incr. logical_simplify. - subst. cbn. ssplit; intros; auto. - } - pose (r_ := r). destruct r. - + (* r=VALUE *) - pose (sH_ := sH); destruct sH; cbn in H2; try (exfalso; assumption); logical_simplify; subst. - inversion H; subst. - eapply runUntilResp_big_step with (s:=sL) in Hprec - as [n [inputs [sL' [repr' [d2h [sL'' [HrunU [HmaxRespDelay [Einputs [EsL' [Erepr' [Hpostc' [Ed_valid Hinv'']]]]]]]]]]]]]; subst; auto. - exists d2h, sL'', IDLE. - ssplit. - 3: cbn; ssplit; try reflexivity; []. - * assumption. - * eexists. - split; [|apply Hinv'']. + simplify_invariant incr; logical_simplify; subst; cbn -[replace]; + apply No_inflight; try (constructor; lia); []. + replace ((word_to_N val + 1) mod 4294967296)%N with + (word_to_N (word.add (word.of_Z 1) val)) by + (unfold word_to_N; ZnWords); + apply BUSY_done_related. + + - (* [state_machine_read_to_device_send_read_or_later] *) + intros ? ? ? ? ? ? [v [sH'' Hex_read]] [repr [Hrel Hinv]] **. + cbn in Hex_read. logical_simplify. + rewrite H5. clear H5. + use_spec. + 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; + simplify_invariant incr; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + destruct_tl_h2d; tlsimpl; logical_simplify; subst; + ssplit; intros; auto. + + destruct_one_match; [destruct_one_match|]. + (* case 1: device ready, valid response + In our TL implementation [a_ready = negb d_valid], hence this case + is not possible. + case 3: device not ready + If the inflight queue is empty, the device must be ready, hence + this case is not possible. *) + 1,3: exfalso; + unfold device.last_d2h, counter_device in *; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; + inversion_rel_spec; logical_simplify; discriminate. + (* device ready, no valid response: *) + ssplit. + 1: eexists; split; [|eassumption]; []. + all: + unfold device.tl_inflight_ops, device.last_d2h, device.maxRespDelay, + counter_device, counter_related in *; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + cbn in sL'; destruct sL' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + destruct_tl_d2h; destruct_tl_h2d; + simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); + simplify_invariant incr; + logical_simplify; tlsimpl; subst; + cbn in Hinv'; logical_simplify; subst. + + destruct r. + * (* [r:=VALUE] *) + inversion_rel_spec; inversion_rel_base; destruct H6; subst. + cbn; replace (N.land (word_to_N (word.of_Z 16384)) 4) with 0%N + by (rewrite Z_word_N by lia; reflexivity); + cbn; eapply Inflight_read_value; [eauto| |reflexivity..]. + logical_simplify. assumption. + * (* [r:=STATUS] *) + inversion_rel_spec; inversion_rel_base; subst; logical_simplify; subst; cbn. + eapply Inflight_read_status; try (constructor; lia). + all: replace (N.land (word_to_N (word.of_Z 16388)) 4) with 4%N + by (rewrite Z_word_N by lia; reflexivity); eauto. + all: cbn; replace ((word_to_N val + 1) mod 4294967296)%N with + (word_to_N (word.add (word.of_Z 1) val)) by + (unfold word_to_N; ZnWords); constructor. + + + inversion_rel_spec; inversion_rel_base; subst; logical_simplify; subst; lia. + + - (* [state_machine_read_to_device_ack_read_or_later] *) + intros ? ? ? ? ? ? [v [sH'' Hex_read]] [repr [Hrel Hinv]] **. + (* assert (Hex_rel: exists sL'' h2d', device.run1 sL'' (set_d_ready true h2d') = sL /\ *) + (* counter_related sH sL'' []). *) + (* { admit. } *) + (* logical_simplify. destruct H0 as [repr'' [Hrel'' Hinv'']]. *) + (* use_spec. 1: admit. *) + (* rename Hprec into Hprec''. rename repr' into repr'''. rename Erepr' into Erepr''. rename Hinv' into Hinv'''. *) + cbn in Hex_read. logical_simplify. + rewrite H2. clear H2. rename H3 into Hex_read. + use_spec. + 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; + simplify_invariant incr; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner); + destruct r_state; + destruct_tl_h2d; tlsimpl; logical_simplify; subst; + ssplit; intros; auto. + + destruct_one_match. + (* case 2: no valid response + If the inflight queue is not empty, the device must be sending a + response, hence this case is not possible. *) + 2: unfold device.last_d2h, counter_device in *; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner); + simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; + inversion_rel_spec; try inversion_rel_base; logical_simplify; subst; + try destruct r_tl; logical_simplify; subst; + discriminate. + + (* case 1: valid response *) + destruct r. + + (* [r:=VALUE] *) + inversion_rel_spec; + try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). + + destruct Hex_read; subst. + logical_simplify; subst. + exists IDLE. ssplit. + * eexists. split; [|eassumption]. + cbn. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + simplify_invariant incr; + logical_simplify; tlsimpl; subst. + apply No_inflight, IDLE_related. + * cbn. ssplit; try reflexivity. + clear Hinv'. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); simplify_invariant incr. - simplify_invariant Incr.inner. - simplify_invariant (tlul_adapter_reg (reg_count:=2)). - cbn in sL''; destruct sL'' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - clear HrunU. - pose (n_:=n). destruct n as [|[|n]]. - 3: unfold device.maxRespDelay, counter_device in HmaxRespDelay; exfalso; lia. - all: cbn [repeat fold_left] in *. - -- destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]. - logical_simplify. - cbn in H5. - destruct (outstanding_h2d r_tl) eqn:Houts. - ++ logical_simplify. rewrite Ed_valid in * |-. discriminate. - ++ cbn in H5. logical_simplify. - destruct_tl_d2h. tlsimpl. subst. - simplify_invariant incr. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - cbn in Hinv'' |- *. - rewrite Houts in Hinv'' |- *. cbn in Hinv''. logical_simplify. - cbn in *. - logical_simplify. subst. - rewrite Z_word_N in * by lia. cbn in *. logical_simplify. subst. - apply IDLE_related. - -- cbn in Hpostc'. - destruct (outstanding_h2d r_tl) eqn:Houts; - destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]; - logical_simplify; - cbn in H5; rewrite Houts in H5; cbn in H5; logical_simplify; subst. - ++ destruct_tl_d2h. tlsimpl. subst. - simplify_invariant incr. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - cbn in Hinv'' |- *. - rewrite Houts in Hinv'' |- *. cbn in Hinv'' |- *. logical_simplify. - rewrite Houts. cbn. - rewrite Z_word_N in * by lia. cbn in *. - destruct H8; subst; apply IDLE_related. - ++ rewrite Ed_valid in * |-. discriminate. - * pose (n_:=n). destruct n as [|[|n]]. - -- cbn [repeat fold_left] in *. - destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]. - logical_simplify. - cbn in H5. - destruct (outstanding_h2d r_tl) eqn:Houts. - ++ logical_simplify. rewrite Ed_valid in * |-. discriminate. - ++ cbn in H5. logical_simplify. - destruct_tl_d2h. tlsimpl. subst. - simplify_invariant incr. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - cbn in sL''; destruct sL'' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - cbn in Hinv''. - rewrite Houts in Hinv''. cbn in Hinv''. logical_simplify. - cbn in *. - logical_simplify. subst. - rewrite Z_word_N in * by lia. cbn in *. logical_simplify. subst. - rewrite H3. apply N_to_word_word_to_N. - -- cbn [repeat fold_left] in *. - cbn in Hpostc'. - destruct (outstanding_h2d r_tl) eqn:Houts; - destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]; - logical_simplify; - cbn in H5; rewrite Houts in H5; cbn in H5; logical_simplify; subst. - ++ destruct_tl_d2h. tlsimpl. subst. - simplify_invariant incr. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - cbn in sL''; destruct sL'' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - cbn in Hinv''. - rewrite Houts in Hinv''. cbn in Hinv''. logical_simplify. - rewrite Z_word_N in * by lia. cbn -[replace] in *. - destruct H8; subst; destruct r_regs; cbn in H3 |- *; - rewrite H3; apply N_to_word_word_to_N. - ++ rewrite Ed_valid in * |-. discriminate. - -- unfold device.maxRespDelay, counter_device in HmaxRespDelay. exfalso. lia. - + (* r=STATUS *) - eapply runUntilResp_big_step in Hprec as [n [inputs [sL' [repr' [d2h [sL'' [HrunU [HmaxRespDelay [Einputs [EsL' [Erepr' [Hpostc' [Ed_valid Hinv'']]]]]]]]]]]]]; subst; auto; [|eassumption]. - inversion H; subst. - * do 3 eexists; ssplit. - -- rewrite HrunU; reflexivity. - -- eexists; split; [|eassumption]; - destruct n as [|[|n]]; - [| |unfold device.maxRespDelay, counter_device in HmaxRespDelay; exfalso; lia]; - cbn [repeat fold_left] in *; - simplify_invariant incr; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - logical_simplify; subst; - cbn; destruct (outstanding_h2d r_tl) eqn:Eouts; - try (cbn; rewrite Eouts; cbn); - apply IDLE_related. - -- cbn. ssplit; try reflexivity. - destruct n as [|[|n]]; - [| |unfold device.maxRespDelay, counter_device in HmaxRespDelay; exfalso; lia]; - cbn [repeat fold_left] in *; simplify_spec incr; - simplify_spec (tlul_adapter_reg (reg_count:=2)). - ++ destruct Hpostc' as [req' [h2d' [regs' [d2h' [io_re' [io_we' [io_address' [io_data' [io_mask' Hpostc']]]]]]]]]; logical_simplify; cbn in H5; - destruct (outstanding_h2d r_tl) eqn:Eouts; - [logical_simplify; rewrite Ed_valid in *; discriminate|]; - cbn in H5; logical_simplify; rewrite H9. - unfold status_value, STATUS_IDLE, N_to_word, word_to_N. - simplify_invariant incr. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - logical_simplify. - replace (N.to_nat ((N.land (Z.to_N (word.unsigned (word.of_Z 16388))) 4 / 4) mod 1073741824)) with 1. - ** ZnWords. - ** ZnWords_pre. rewrite Zmod_small; [|lia]. - rewrite N.mod_small; cbn; lia. - ++ admit. - * admit. - * admit. - * admit. - - (* state_machine_write_to_device_write: *) - admit. + logical_simplify; subst. + destruct_tl_h2d; tlsimpl; subst. + rewrite H19. cbn. rewrite H3. apply N_to_word_word_to_N. + + (* [r:=STATUS] *) + inversion_rel_spec; + try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). + + inversion_rel_base; + cbn in sL |- *; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + simplify_invariant incr; + logical_simplify; subst; logical_simplify; subst; + match goal with + | H: d_data _ = _ |- _ => + rewrite H + end; + cbn; destruct_tl_h2d; tlsimpl; subst; cbn; + change (Pos.to_nat 1) with 1. + (* match goal with *) + (* | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H *) + (* end; *) + (* unfold N_to_word, status_value. *) + * eexists; ssplit; try reflexivity. + -- eexists. + ssplit; [|eassumption]. + apply No_inflight. constructor. + -- assert (Hprev: r_prev_state = RSIdle) by admit. + subst. + match goal with + | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H + end; unfold N_to_word, status_value. + ZnWords. + * destruct ncycles as [|ncycles]; [lia|]. + eexists; ssplit; try reflexivity. + -- eexists. ssplit; [|eassumption]. + apply No_inflight, BUSY2_related. apply lt_S_n. eauto. + -- right. eexists. ssplit; [reflexivity| |reflexivity]. + assert (Hprev: exists d, r_prev_state = RSBusy d) by admit. + logical_simplify; subst. + match goal with + | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H + end; unfold N_to_word, status_value. + ZnWords. + * destruct ncycles as [|ncycles]; [lia|]. + eexists. ssplit; try reflexivity. + -- eexists. ssplit; [|eassumption]. + cbn; rewrite incrN_word_to_bv. + apply No_inflight, BUSY_done_related. + -- right. eexists. ssplit; [reflexivity| |reflexivity]. + assert (Hprev: exists d, r_prev_state = RSBusy d) by admit. + logical_simplify; subst. + match goal with + | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H + end; unfold N_to_word, status_value. + ZnWords. + * eexists; ssplit; try reflexivity. + -- eexists. ssplit; [|eassumption]. + apply No_inflight, DONE_related. + -- left. ssplit; [|reflexivity]. + assert (Hprev: exists d, r_prev_state = RSDone d) by admit. + logical_simplify; subst; logical_simplify; + match goal with + | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H + end; unfold N_to_word, status_value. + ZnWords. + * eexists; ssplit; try reflexivity. + -- eexists. ssplit; [|eassumption]. + apply No_inflight, DONE_related. + -- assert (Hprev: exists d, r_prev_state = RSDone d) by admit. + logical_simplify; subst; logical_simplify. + match goal with + | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H + end; unfold N_to_word, status_value. + ZnWords. + + - (* [state_machine_write_to_device_send_write_or_later] *) + intros ? ? ? ? ? ? ? [sH'' [Hpow2 Hex_write]] [repr [Hrel Hinv]] **. + rewrite Hpow2. clear Hpow2. + use_spec. + 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; + simplify_invariant incr; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + destruct_tl_h2d; tlsimpl; logical_simplify; subst; + ssplit; intros; auto. + + destruct_one_match; [destruct_one_match|]. + (* case 1: device ready, valid response + In our TL implementation [a_ready = negb d_valid], hence this case + is not possible. + case 3: device not ready + If the inflight queue is empty, the device must be ready, hence + this case is not possible. *) + 1,3: exfalso; + unfold device.last_d2h, counter_device in *; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; + inversion_rel_spec; logical_simplify; discriminate. + (* device ready, no valid response: *) + ssplit. + 1: eexists; split; [|eassumption]; []. + all: + unfold device.tl_inflight_ops, device.last_d2h, device.maxRespDelay, + counter_device, counter_related in *; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + cbn in sL'; destruct sL' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + destruct_tl_d2h; destruct_tl_h2d; + simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); + simplify_invariant incr; + logical_simplify; tlsimpl; subst; + cbn in Hinv'; logical_simplify; subst. + + destruct r. + * (* [r:=VALUE] *) + inversion_rel_spec; inversion_rel_base; logical_simplify; subst; try contradiction. + cbn. apply Inflight_write_value; eauto; []. + rewrite Z_word_N by lia. change (Z.to_N 16384) with 16384%N. reflexivity. + * (* [r:=STATUS] *) + inversion_rel_spec; inversion_rel_base; + destruct Hex_write. + + inversion_rel_spec; inversion_rel_base; subst; logical_simplify; subst; lia. + + - (* [state_machine_write_to_device_ack_write_or_later] *) + intros ? ? ? ? ? ? ? [sH'' [Hpow2 Hex_write]] [repr [Hrel Hinv]] **. + rewrite Hpow2 in *. clear Hpow2. + use_spec. + 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; + simplify_invariant incr; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + destruct_tl_h2d; tlsimpl; logical_simplify; subst; + ssplit; intros; auto. + + destruct_one_match. + (* case 2: no valid response + If the inflight queue is not empty, the device must be sending a + response, hence this case is not possible. *) + 2: unfold device.last_d2h, counter_device in *; + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); + simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; + inversion_rel_spec; try inversion_rel_base; logical_simplify; subst; + try destruct r_tl; logical_simplify; subst; + discriminate. + + (* case 1: valid response *) + destruct r. + + (* [r:=VALUE] *) + inversion_rel_spec; + try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). + + destruct Hex_write; subst. + logical_simplify; subst. + eexists. ssplit; [|cbn; split; reflexivity]. + eexists. split; [|eassumption]. + cbn. + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + simplify_invariant incr; + logical_simplify; tlsimpl; subst. + apply No_inflight. + simplify_invariant Incr.inner; destruct s_inner; logical_simplify. + destruct x as [|[|[|]]]; [exfalso; lia|..| exfalso; lia]; + destruct_tl_h2d; tlsimpl; subst; + match goal with + | H: word_to_N v = word_to_N val |- _ => + rewrite <- H + end. + * constructor; lia. + * replace ((word_to_N v + 1) mod 4294967296)%N with + (word_to_N (word.add (word.of_Z 1) v)) by + (unfold word_to_N; ZnWords). + constructor. + + (* [r:=STATUS] *) + inversion_rel_spec; + try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). - (* read_step_unique: *) intros. simpl in *. unfold read_step in *. simp. destruct v; destruct r; try contradiction; simp; try reflexivity. diff --git a/firmware/IncrementWait/Incr.v b/firmware/IncrementWait/Incr.v index d91c57b7f..3d7cd72b4 100644 --- a/firmware/IncrementWait/Incr.v +++ b/firmware/IncrementWait/Incr.v @@ -113,7 +113,7 @@ Section Var. else `replace` registers' `K (sz:=1) 1` `K 1` in (busy', done', registers', tl_d2h') initially - (false, (false, ([0; 1], default (t:=tl_d2h_t)))) + (false, (false, ([0; 1], set_a_ready true (default (t:=tl_d2h_t))))) : denote_type (Bit ** Bit ** Vec (BitVec 32) 2 ** tl_d2h_t) in @@ -257,13 +257,47 @@ Section Spec. | RSBusy (data : N) | RSDone (res : N). - Definition repr := (repr_state * list N * list tl_h2d * inner_repr)%type. + Definition repr := (repr_state * repr_state * list N * TLUL.repr_state * inner_repr)%type. Global Instance incr_invariant : invariant_for incr repr := fun (state : denote_type (state_of incr)) repr => let '((s_busy, (s_done, (s_regs, s_d2h))), (s_tlul, s_inner)) := state in - let '(r_state, r_regs, r_tlul, r_inner) := repr in - tlul_invariant (reg_count:=2) s_tlul r_tlul + let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in + tlul_invariant (reg_count:=2) s_tlul r_tl + /\ match r_tl with + | TLUL.Idle => + d_valid s_d2h = false + /\ d_error s_d2h = false + /\ a_ready s_d2h = true + | TLUL.OutstandingAccessAckData h2d regs => + d_valid s_d2h = true + /\ d_opcode s_d2h = AccessAckData + /\ d_param s_d2h = 0 + /\ d_size s_d2h = (a_size h2d) + /\ d_source s_d2h = (a_source h2d) + /\ d_sink s_d2h = 0 + /\ d_data s_d2h = (List.nth (N.to_nat ((((a_address h2d) / 4) mod (2 ^ 30)))) regs 0%N) + /\ d_user s_d2h = 0 + /\ d_error s_d2h = false + /\ a_ready s_d2h = false + /\ match r_prev_state with + | RSIdle => nth 1 regs 0%N = 1 + | RSBusy data => nth 1 regs 0%N = 2 + | RSDone res => nth 0 regs 0%N = res + /\ nth 1 regs 0%N = 4 + end + (* /\ (exists input, update_repr (r_prev_state, ... ..) = r_state) *) + | TLUL.OutstandingAccessAck h2d => + d_valid s_d2h = true + /\ d_opcode s_d2h = AccessAck + /\ d_param s_d2h = 0 + (* /\ d_size s_d2h = *) + /\ d_source s_d2h = (a_source h2d) + /\ d_sink s_d2h = 0 + /\ d_user s_d2h = 0 + /\ d_error s_d2h = false + /\ a_ready s_d2h = false + end /\ inner_invariant s_inner r_inner /\ match r_state with | RSIdle => s_busy = false /\ s_done = false @@ -280,44 +314,43 @@ Section Spec. /\ s_regs = r_regs /\ length r_regs = 2%nat. - Existing Instance tlul_specification. + Existing Instance tl_specification. Instance incr_specification : specification_for incr repr := - {| reset_repr := (RSIdle, [0; 1], [], IISIdle); + {| reset_repr := (RSIdle, RSIdle, [0; 1], TLUL.Idle, IISIdle); update_repr := fun (input : denote_type (input_of incr)) repr => let '(i_h2d, tt) := input in - let '(r_state, r_regs, r_tlul, r_inner) := repr in + let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in - let r_tlul' := + let r_tl' := let tlul_input := (h2d, (r_regs, tt)) in update_repr (c:=tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul in + tlul_input r_tl in (* compute (some) tlul output *) let '(is_read, is_write, address, write_data) := - match outstanding_h2d (h2d :: r_tlul) with - | None => (false, false, 0, 0) - | Some h2d' => - if a_opcode h2d' =? Get then - match outstanding_h2d r_tlul with - | None => (a_valid h2d, false, a_address h2d, 0) - | _ => (false, false, 0, 0) - end - else if a_opcode h2d' =? PutFullData then - match outstanding_h2d r_tlul with - | None => (false, a_valid h2d, a_address h2d, a_data h2d) + match r_tl' with + | TLUL.Idle => (false, false, 0, 0) + | TLUL.OutstandingAccessAckData _ _ => + match r_tl with + | TLUL.Idle => (a_valid h2d, false, a_address h2d, 0) | _ => (false, false, 0, 0) - end - else (false, false, 0, 0) + end + | TLUL.OutstandingAccessAck _ => + match r_tl with + | TLUL.Idle => (false, a_valid h2d, a_address h2d, a_data h2d) + | _ => (false, false, 0, 0) + end end in let r_inner' := - let inner_input := (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) in + let inner_input := (match r_state with RSIdle => is_write | _ => false end, + (write_data, tt)) in update_repr (c:=inner) inner_input r_inner in let r_state' := @@ -346,12 +379,12 @@ Section Spec. | RSDone _ => replace 1 4 r_regs' end in - (r_state', r_regs', h2d :: r_tlul, r_inner'); + (r_state', r_state, r_regs', r_tl', r_inner'); precondition := fun (input : denote_type (input_of incr)) repr => let '(i_h2d, tt) := input in - let '(r_state, r_regs, r_tlul, r_inner) := repr in + let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in @@ -359,14 +392,15 @@ Section Spec. let prec_tlul := precondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul in + tlul_input r_tl in let prec_inner := forall d2h is_read is_write address write_data write_mask, postcondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul + tlul_input r_tl (d2h, (is_read, (is_write, (address, (write_data, write_mask))))) - -> precondition inner (match r_state with RSIdle => is_write | _ => false end, (write_data, tt)) r_inner in + -> precondition inner (match r_state with RSIdle => is_write | _ => false end, + (write_data, tt)) r_inner in prec_tlul /\ prec_inner; @@ -374,7 +408,7 @@ Section Spec. fun (input : denote_type (input_of incr)) repr (output : denote_type (output_of incr)) => let '(i_h2d, tt) := input in - let '(r_state, r_regs, r_tlul, r_inner) := repr in + let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in @@ -382,7 +416,7 @@ Section Spec. let tlul_input := (h2d, (r_regs, tt)) in exists req, postcondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tlul + tlul_input r_tl (output, req) in postc_tlul; |}. @@ -390,206 +424,169 @@ Section Spec. Lemma incr_invariant_at_reset : invariant_at_reset incr. Proof. simplify_invariant incr. - cbn. ssplit; try reflexivity. - apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2)). + cbn. ssplit; [apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2)) + | reflexivity..]. Qed. Existing Instance tlul_adapter_reg_correctness. Lemma incr_invariant_preserved : invariant_preserved incr. Proof. - intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. + intros (h2d, t) state ((((r_state, r_prev_state), r_regs), r_tl), r_inner). destruct t. cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). destruct_tl_h2d. destruct_tl_d2h. intros repr' ? Hinvar Hprec; subst. simplify_invariant incr. logical_simplify. subst. simplify_spec incr. logical_simplify. subst. (* destruct Hprec as [regs Hprec]. *) - cbv [incr]. stepsimpl. - use_correctness. match goal with - | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => - rename H into Htl_postc + | |- context [step incr ?s ?i] => + remember (step incr s i) as step eqn:Estep; + cbv -[Semantics.step inner tlul_adapter_reg] in Estep; + subst end. + stepsimpl. + use_correctness. + rename H9 into Hpostc_tl. repeat (destruct_pair_let; cbn [fst snd]). ssplit. - eapply tlul_adapter_reg_invariant_preserved. 2: apply H. + reflexivity. + assumption. + - pose (r_tl_:=r_tl); destruct r_tl; logical_simplify; subst. + + clear H5. + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. + pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst; + pose (a_valid_:=a_valid); (destruct a_valid; + [ match goal with + | H: true = true -> _ |- _ => + destruct H; [auto|subst..] + end|]); cbn in *; logical_simplify; subst; + ssplit; auto. + + clear H5. + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. + pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst; + pose (d_ready_:=d_ready); destruct d_ready; cbn in *; logical_simplify; subst; + ssplit; auto. + + clear H5. + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. + pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst; + pose (d_ready_:=d_ready); destruct d_ready; cbn in *; logical_simplify; subst; + ssplit; reflexivity. - eapply inner_invariant_preserved. - 2: apply H0. + 2: eassumption. + simpl in *. destruct r_inner; try reflexivity. - destruct (outstanding_h2d r_tlul) eqn:Houts. - * destruct d_ready; logical_simplify; subst. - -- boolsimpl. destruct r_state; reflexivity. - -- eapply outstanding_prec in H as Hprec_t. 2: apply Houts. - destruct Hprec_t as [Hprec_t|Hprec_t]; - rewrite Hprec_t in *; cbn in Htl_postc |- *; logical_simplify; subst; - boolsimpl; destruct r_state; reflexivity. + destruct r_tl eqn:Houts; logical_simplify; subst. * destruct a_valid eqn:Hvalid; logical_simplify; subst. - -- cbn in Htl_postc. - match goal with + -- match goal with | H: true = true -> _ |- _ => destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; + end; logical_simplify; subst; boolsimpl; destruct r_state; logical_simplify; subst; - reflexivity. + cbn in Hpostc_tl |- *; logical_simplify; subst; reflexivity. -- boolsimpl; destruct r_state; reflexivity. - + match goal with - | H: context [_ -> precondition inner _ r_inner] |- _ => - eapply H - end. - do 8 eexists. ssplit. - 1-2: reflexivity. - apply Htl_postc. + + * destruct d_ready; logical_simplify; subst; + boolsimpl; destruct r_state; reflexivity. + * destruct d_ready; logical_simplify; subst; + boolsimpl; destruct r_state; reflexivity. + + simplify_spec inner. auto. - match goal with | H: context [_ -> precondition inner _ r_inner] |- _ => clear H end. - destruct r_inner; destruct r_state; destruct inner_st; - unfold inner_invariant in H0; logical_simplify; subst; - try discriminate; - try (destruct H4; discriminate). - all: destruct (outstanding_h2d r_tlul) eqn:Houts; - cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. - all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. - all: cbn; try (ssplit; try reflexivity; - destruct x0 as [|? [|]]; try discriminate H3; reflexivity). - all: try (eapply outstanding_prec in H; - try match goal with - | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => - apply H - end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; - logical_simplify; subst; ssplit; - try (left; reflexivity); - try (right; reflexivity); - try reflexivity; - destruct x0 as [|? [|]]; try discriminate H3; reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - logical_simplify; tlsimpl; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; try cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; - try eexists; - try reflexivity; - destruct x0 as [|? [|]]; try discriminate H3; reflexivity). - all: try (destruct a_valid; ssplit; - try (left; reflexivity); - try (right; reflexivity); - try reflexivity; - destruct x0 as [|? [|]]; try discriminate H3; reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; logical_simplify; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; try cbn in Htl_postc; logical_simplify; subst; - boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; - cbn; try (rewrite Haddr); ssplit; - try (left; reflexivity); - try (right; reflexivity); - try reflexivity; - destruct x0 as [|? [|]]; try discriminate H3; reflexivity). - all: try (inversion H5; subst; clear H5; - destruct x as [|[|[|?]]]; cbn; ssplit; - try eexists; - try (left; reflexivity); - try (right; reflexivity); - try reflexivity; - try (destruct x0 as [|? [|]]; try discriminate H3; reflexivity); - exfalso; lia). - all: destruct H5; discriminate. + destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; + logical_simplify; subst. + all: simplify_invariant inner. + all: try discriminate. + all: simplify_spec (tlul_adapter_reg (reg_count:=2)); logical_simplify; tlsimpl; subst. + all: destruct a_valid; [destruct H3; subst|]; cbn in Hpostc_tl; logical_simplify; subst; cbn. + all: eauto. + all: try (destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + ssplit; eauto; + destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). + all: try (destruct count as [|[|[|]]]; [lia|..|lia]; cbn; + ssplit; eauto; + destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). + all: try (destruct H6; discriminate). + all: try (destruct d_ready; logical_simplify; subst; cbn; + ssplit; eauto; + destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). - match goal with | H: context [_ -> precondition inner _ r_inner] |- _ => clear H end. - destruct r_inner; destruct r_state; destruct inner_st; - unfold inner_invariant in H0; logical_simplify; subst; - try discriminate. - all: destruct (outstanding_h2d r_tlul) eqn:Houts; - cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. - all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. - all: try reflexivity. - all: try (destruct H5; discriminate). - all: try (inversion H5; subst; clear H5; - destruct x as [|[|[|?]]]; try reflexivity; exfalso; lia). - all: try (eapply outstanding_prec in H; - try match goal with - | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => - apply H - end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; - logical_simplify; subst; cbn; reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; logical_simplify; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; try cbn in Htl_postc; logical_simplify; subst; reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; logical_simplify; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; try cbn in Htl_postc; logical_simplify; subst; - boolsimpl; destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; - cbn; try (rewrite Haddr); reflexivity). - - all: match goal with - | |- length (match ?v with _ => _ end) = 2%nat => destruct v - end; - match goal with - | |- context [update_repr ?ui ?ur] => - remember (update_repr (c:=inner) ui ur) as up eqn:?H; - replace (update_repr (c:=inner) ui ur) with up; - destruct up - end; - rewrite ! length_replace; assumption. + destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; + logical_simplify; subst. + all: simplify_invariant inner. + all: try discriminate. + all: simplify_spec (tlul_adapter_reg (reg_count:=2)); logical_simplify; tlsimpl; subst. + all: destruct a_valid; [destruct H3; subst|]; cbn in Hpostc_tl; logical_simplify; subst; cbn. + all: eauto. + all: try (destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + ssplit; eauto; + destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). + all: try (destruct count as [|[|[|]]]; [lia|..|lia]; cbn; + ssplit; eauto; + destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). + all: try (destruct H6; discriminate). + all: try (destruct d_ready; logical_simplify; subst; cbn; + ssplit; eauto; + destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). + - repeat destruct_one_match; rewrite ! length_replace; assumption. Qed. Lemma incr_output_correct : output_correct incr. Proof. - intros (h2d, t) state (((r_state, r_regs), r_tlul), r_inner). destruct t. - cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). - destruct_tl_h2d. destruct_tl_d2h. - intros Hinvar Hprec; subst. - simplify_invariant incr. logical_simplify. subst. - simplify_spec incr. logical_simplify. subst. - cbv [incr]. stepsimpl. - use_correctness. - match goal with - | H: (match outstanding_h2d (_::r_tlul) with | _ => _ end) |- _ => - rename H into Htl_postc - end. - repeat (destruct_pair_let; cbn [fst snd]). - tlsimpl. - destruct r_inner; destruct r_state; destruct inner_st; - unfold inner_invariant in H0; logical_simplify; subst; - try discriminate; - try (destruct H5; discriminate). - all: destruct (outstanding_h2d r_tlul) eqn:Houts; - cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. - all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. - all: do 9 eexists. - all: ssplit; try reflexivity; tlsimpl; ssplit; try reflexivity; try assumption. - all: try (eapply outstanding_prec in H; - try match goal with - | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => - apply H - end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; - logical_simplify; subst; ssplit; - try (left; reflexivity); - try (right; reflexivity); - try assumption; - reflexivity). - all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); - tlsimpl; destruct H2; - try match goal with - | H: true = true -> _ |- _ => - destruct H; try reflexivity; subst - end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; - try eexists; try assumption; reflexivity). - Unshelve. all: auto. - Qed. + Admitted. + (* intros (h2d, t) state (((r_state, r_regs), r_tl), r_inner). destruct t. *) + (* cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). *) + (* destruct_tl_h2d. destruct_tl_d2h. *) + (* intros Hinvar Hprec; subst. *) + (* simplify_invariant incr. logical_simplify. subst. *) + (* simplify_spec incr. logical_simplify. subst. *) + (* match goal with *) + (* | |- context [step incr ?s ?i] => *) + (* remember (step incr s i) as step eqn:Estep; *) + (* cbv -[Semantics.step inner tlul_adapter_reg] in Estep; *) + (* subst *) + (* end. *) + (* stepsimpl. *) + (* use_correctness. *) + (* match goal with *) + (* | H: (match outstanding_h2d (_::r_tl) with | _ => _ end) |- _ => *) + (* rename H into Htl_postc *) + (* end. *) + (* repeat (destruct_pair_let; cbn [fst snd]). *) + (* tlsimpl. *) + (* destruct r_inner; destruct r_state; destruct inner_st; *) + (* unfold inner_invariant in H0; logical_simplify; subst; *) + (* try discriminate; *) + (* try (destruct H5; discriminate). *) + (* all: destruct (outstanding_h2d r_tl) eqn:Houts; *) + (* cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. *) + (* all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. *) + (* all: do 9 eexists. *) + (* all: ssplit; try reflexivity; tlsimpl; ssplit; try reflexivity; try assumption. *) + (* all: try (eapply outstanding_prec in H; *) + (* try match goal with *) + (* | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => *) + (* apply H *) + (* end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; *) + (* logical_simplify; subst; ssplit; *) + (* try (left; reflexivity); *) + (* try (right; reflexivity); *) + (* try assumption; *) + (* reflexivity). *) + (* all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); *) + (* tlsimpl; destruct H2; *) + (* try match goal with *) + (* | H: true = true -> _ |- _ => *) + (* destruct H; try reflexivity; subst *) + (* end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; *) + (* try eexists; try assumption; reflexivity). *) + (* Unshelve. all: auto. *) + (* Qed. *) Existing Instances incr_invariant_at_reset incr_invariant_preserved incr_output_correct. diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index eb039049e..9c9b836f3 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -69,7 +69,7 @@ Module device. run1: (* input: TileLink host-2-device *) state -> tl_h2d -> (* output: next state, TileLink device-2-host *) - state * tl_d2h; + state; (* lowest address of the MMIO address range used to communicate with this device *) addr_range_start: Z; @@ -90,10 +90,11 @@ Module device. Definition waitForResp{D: device} := fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := - let '(next, d2h) := device.run1 s (set_d_ready true tl_h2d_default) in - if d_valid d2h then (Some d2h, next) else + let next := device.run1 s (set_d_ready true tl_h2d_default) in + if d_valid (device.last_d2h s) then (Some (device.last_d2h s), next) + else match fuel with - | O => (None, next) + | O => (None, s) | S fuel' => rec fuel' next end. @@ -101,16 +102,18 @@ Module device. It is also assumed that [a_valid h2d = true] and [d_ready h2d = true]. *) Definition runUntilResp{D: device}(h2d: tl_h2d) := fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := - let '(next, d2h) := device.run1 s h2d in + let next := device.run1 s h2d in if a_ready (device.last_d2h s) then - if d_valid d2h then (Some d2h, next) else + if d_valid (device.last_d2h s) then + (Some (device.last_d2h s), next) + else match fuel with - | O => (None, next) + | O => (None, s) | S fuel' => waitForResp fuel' next end else match fuel with - | O => (None, next) + | O => (None, s) | S fuel' => rec fuel' next end. @@ -267,7 +270,7 @@ Section WithParams. end. Definition device_step_without_IO(d: D): D := - let '(next_state, ignored_d2h) := (device.run1 d tl_h2d_default) in next_state. + let next_state := (device.run1 d tl_h2d_default) in next_state. Fixpoint device_steps(n: nat): OState (ExtraRiscvMachine D) unit := match n with diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index bca98e6ae..8ed93d808 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -27,32 +27,33 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte mmioAddrs_match: sameset state_machine.isMMIOAddr device.isMMIOAddr; (* simulation relation between high-level states sH and low-level states sL *) - device_state_related: state_machine.state -> D -> Prop; + device_state_related: state_machine.state -> D -> list tl_h2d -> Prop; (* if an initial high-level state is related to some low-level state, it must be a ready state *) initial_state_is_ready_state: forall sH sL, state_machine.is_initial_state sH -> - device_state_related sH sL -> + device_state_related sH sL [] -> device.is_ready_state sL; (* every initial high-level state is related to every initial low-level state *) initial_states_are_related: forall sH sL, state_machine.is_initial_state sH -> device.is_ready_state sL -> - device_state_related sH sL; + device_state_related sH sL []; (* for every initial low-level state, there exists a related initial high-level state *) initial_state_exists: forall sL, device.is_ready_state sL -> - exists sH, state_machine.is_initial_state sH /\ device_state_related sH sL; + exists sH, state_machine.is_initial_state sH /\ device_state_related sH sL []; (* transitions that are not responding to MMIO cannot change the state as seen by the software: *) nonMMIO_device_step_preserves_state_machine_state: - forall sL1 sL2 sH h2d ignored_resp, + forall sL1 sL2 sH h2d, a_valid h2d = false -> - device_state_related sH sL1 -> - device.run1 sL1 h2d = (sL2, ignored_resp) -> - device_state_related sH sL2; + (* d_ready h2d = false -> *) + device_state_related sH sL1 [] -> + device.run1 sL1 h2d = sL2 -> + device_state_related sH sL2 []; (* for each high-level state sH from which n bytes can be read at register r, if we run the low-level device with the read step's address on the input wires, @@ -63,45 +64,41 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte underspecification-nondeterminism in the high-level state machine) *) (* TODO: replace the length clauses with [In (a_source h2d) (device.tl_inflight_ops sL)] *) - state_machine_read_to_device_read_or_later: forall log2_nbytes r sH sL sL' h2d d2h, + state_machine_read_to_device_send_read_or_later: forall log2_nbytes r sH sL sL' h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> + device_state_related sH sL [] -> a_valid h2d = true -> a_opcode h2d = Get -> a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> d_ready h2d = true -> - List.length (device.tl_inflight_ops sL) = 0%nat -> - device.run1 sL h2d = (sL', d2h) -> + device.run1 sL h2d = sL' -> if a_ready (device.last_d2h sL) then - if d_valid d2h then + if d_valid (device.last_d2h sL) then exists sH', - device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat + device_state_related sH' sL' [] /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL))) sH' else - device_state_related sH sL' /\ - (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ - List.length (device.tl_inflight_ops sL') = 1%nat + device_state_related sH sL' [h2d] /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat else - device_state_related sH sL' /\ - (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ - List.length (device.tl_inflight_ops sL') = 0%nat; + device_state_related sH sL' [] /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat; - state_machine_read_to_device_read_or_later_wait: forall log2_nbytes r sH sL sL' d2h, + state_machine_read_to_device_ack_read_or_later: forall log2_nbytes r sH sL sL' h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> - List.length (device.tl_inflight_ops sL) = 1%nat -> - device.run1 sL (set_d_ready true tl_h2d_default) = (sL', d2h) -> - if d_valid d2h then + (exists sL'' h2d', device.run1 sL'' (set_d_ready true h2d') = sL) -> + device_state_related sH sL [h2d] -> + a_opcode h2d = Get -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + device.run1 sL (set_d_ready true tl_h2d_default) = sL' -> + if d_valid (device.last_d2h sL) then exists sH', - device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat + device_state_related sH' sL' [] /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL))) sH' else - device_state_related sH sL' /\ - (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ - List.length (device.tl_inflight_ops sL') = 1%nat; + device_state_related sH sL' [h2d] /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat; (* for each high-level state sH in which an n-byte write to register r with value v is possible, if we run the low-level device with the write step's address and value on the input wires, @@ -110,46 +107,42 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte we will get an ack response and the device will end up in a state corresponding to a high-level state reached after a high-level write, but not necessarily in the state we used to show that sH accepts writes *) - state_machine_write_to_device_write_or_later: forall log2_nbytes r v sH sL sL' h2d d2h, + state_machine_write_to_device_send_write_or_later: forall log2_nbytes r v sH sL sL' h2d, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> + device_state_related sH sL [] -> a_valid h2d = true -> a_opcode h2d = PutFullData -> a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> d_ready h2d = true -> - List.length (device.tl_inflight_ops sL) = 0%nat -> - device.run1 sL h2d = (sL', d2h) -> + device.run1 sL h2d = sL' -> if a_ready (device.last_d2h sL) then - if d_valid d2h then + if d_valid (device.last_d2h sL) then exists sH', - device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat + device_state_related sH' sL' [] /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' else - device_state_related sH sL' /\ - (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ - List.length (device.tl_inflight_ops sL') = 1%nat + device_state_related sH sL' [h2d] /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat else - device_state_related sH sL' /\ - (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ - List.length (device.tl_inflight_ops sL') = 0%nat; + device_state_related sH sL' [] /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat; - state_machine_write_to_device_write_or_later_wait: forall log2_nbytes r v sH sL sL' d2h, + state_machine_write_to_device_ack_write_or_later: forall log2_nbytes r v sH sL sL' h2d, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> - List.length (device.tl_inflight_ops sL) = 1%nat -> - device.run1 sL (set_d_ready true tl_h2d_default) = (sL', d2h) -> - if d_valid d2h then + device_state_related sH sL [h2d] -> + a_opcode h2d = PutFullData -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + a_data h2d = word_to_N v -> + device.run1 sL (set_d_ready true tl_h2d_default) = sL' -> + if d_valid (device.last_d2h sL) then exists sH', - device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat + device_state_related sH' sL' [] /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH' else - device_state_related sH sL' /\ - (device.maxRespDelay sL' < device.maxRespDelay sL)%nat /\ - List.length (device.tl_inflight_ops sL') = 1%nat; + device_state_related sH sL' [h2d] /\ + (device.maxRespDelay sL' < device.maxRespDelay sL)%nat; (* If two steps starting in the same high-level state agree on what gets appended to the trace, then the resulting high-level states must be equal. @@ -186,15 +179,15 @@ Section WithParams. and the response will match some possible high-level read step's response, but not necessarily the one we used to show that sH accepts reads (to allow underspecification-nondeterminism in the high-level state machine) *) - Lemma state_machine_read_to_device_read_wait: forall log2_nbytes r sH sL, + Lemma state_machine_read_to_device_ack_read: forall log2_nbytes r sH sL h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> - List.length (device.tl_inflight_ops sL) = 1%nat -> + device_state_related sH sL [h2d] -> + a_opcode h2d = Get -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> exists d2h sL' sH', device.waitForResp (device.maxRespDelay sL) sL = (Some d2h, sL') /\ - device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat. + device_state_related sH' sL' [] /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'. Proof. intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. @@ -203,40 +196,45 @@ Section WithParams. revert fuel sH sL H H0 H1 HB. induction B; intros. - exfalso. lia. - - destr fuel; cbn [device.waitForResp]; destruct_one_match; - pose proof (state_machine_read_to_device_read_or_later_wait - _ _ _ _ _ _ H H0 H1 E) as P; - (destruct_one_match; [destruct P as (sH' & R & V & L); eauto 10 | - destruct P as (R & Decl & L)]). + - remember (device.run1 sL (set_d_ready true tl_h2d_default)) as sL' eqn:E. + apply eq_sym in E. + destr fuel; cbn [device.waitForResp]; + pose proof (state_machine_read_to_device_ack_read_or_later + _ _ _ _ _ _ H H0 H1 H2 E) as P; rewrite E in *; + (destruct_one_match; [destruct P as (sH' & R & V); eauto 10 | + destruct P as (R & Decl)]). + exfalso. lia. - + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St & Ln); + + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. - Lemma state_machine_write_to_device_write_wait: forall log2_nbytes r v sH sL, + Lemma state_machine_write_to_device_ack_write: forall log2_nbytes r v sH sL h2d, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> - List.length (device.tl_inflight_ops sL) = 1%nat -> + device_state_related sH sL [h2d] -> + a_opcode h2d = PutFullData -> + a_address h2d = word_to_N (state_machine.reg_addr r) -> + a_data h2d = word_to_N v -> exists d2h sL' sH', device.waitForResp (device.maxRespDelay sL) sL = (Some d2h, sL') /\ - device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat. + device_state_related sH' sL' [] /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH'. Proof. intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. - revert fuel sH sL H H0 H1 HB. + revert fuel sH sL H H0 HB. induction B; intros. - exfalso. lia. - - destr fuel; cbn [device.waitForResp]; destruct_one_match; - pose proof (state_machine_write_to_device_write_or_later_wait - _ _ _ _ _ _ _ H H0 H1 E) as P; - (destruct_one_match; [destruct P as (sH' & R & V & L); eauto 10 | - destruct P as (R & Decl & L)]). + - remember (device.run1 sL (set_d_ready true tl_h2d_default)) as sL' eqn:E. + apply eq_sym in E. + destr fuel; cbn [device.waitForResp]; + pose proof (state_machine_write_to_device_ack_write_or_later + _ _ _ _ _ _ _ H H0 H1 H2 H3 E) as P; rewrite E in *; + (destruct_one_match; [destruct P as (sH' & R & V); eauto 10 | + destruct P as (R & Decl)]). + exfalso. lia. - + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St & Ln); + + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. @@ -246,38 +244,38 @@ Section WithParams. device.waitForResp fuel' s = (Some d2h, s'). Proof. intros ? ?. revert fuel. induction fuel'; intros; inversion H; subst; auto. - cbn [device.waitForResp]. destruct_one_match. - destruct (d_valid t) eqn:Ed_valid; - destruct fuel; cbn [device.waitForResp] in H0; rewrite E, Ed_valid in H0; + cbn [device.waitForResp]. + destruct_one_match; destruct fuel; + cbn [device.waitForResp] in H0; rewrite E in H0; try assumption; try discriminate. eapply IHfuel' with (fuel:=fuel); [lia|auto]. Qed. Lemma state_machine_read_to_device_read: forall log2_nbytes r sH sL h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> + device_state_related sH sL [] -> a_valid h2d = true -> a_opcode h2d = Get -> a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> d_ready h2d = true -> - List.length (device.tl_inflight_ops sL) = 0%nat -> exists d2h sL' sH', device.runUntilResp h2d (device.maxRespDelay sL) sL = (Some d2h, sL') /\ - device_state_related sH' sL' /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat. + device_state_related sH' sL' [] /\ + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'. Proof. intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. - revert fuel sH sL H H0 HB H6. + revert fuel sH sL H H0 HB. induction B; intros. - exfalso. lia. - - destr fuel; cbn [device.runUntilResp]; destruct_one_match; - pose proof (state_machine_read_to_device_read_or_later - _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; - (repeat destruct_one_match; [destruct P as (sH' & R & V & L) | - destruct P as (R & Decr & L) ..]). + - remember (device.run1 sL h2d) as sL' eqn:E. apply eq_sym in E. + destr fuel; cbn [device.runUntilResp]; + pose proof (state_machine_read_to_device_send_read_or_later + _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 E) as P; + (repeat destruct_one_match; [destruct P as (sH' & R & V) | + destruct P as (R & Decr) ..]); + rewrite ? E in *. + (* 0 remaining fuel, device ready, valid response: *) eauto 10. + (* 0 remaining fuel, device ready, no valid response: *) @@ -287,8 +285,8 @@ Section WithParams. + (* some remaining fuel, device ready, valid response: *) eauto 10. + (* some remaining fuel, device ready, no valid response: *) - pose proof (state_machine_read_to_device_read_wait - _ _ _ _ H R L) as (d2h & sL'' & sH'' & W' & R' & V' & L'). + pose proof (state_machine_read_to_device_ack_read + _ _ _ _ _ H R H2 H4) as (d2h & sL'' & sH'' & W' & R' & V'). eapply waitForResp_mono in W'. 1: eauto 10. lia. + (* some remaining fuel, device not ready: *) edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); @@ -302,30 +300,30 @@ Section WithParams. a high-level write, but not necessarily in the state we used to show that sH accepts writes *) Lemma state_machine_write_to_device_write: forall log2_nbytes r v sH sL h2d, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> - device_state_related sH sL -> + device_state_related sH sL [] -> a_valid h2d = true -> a_opcode h2d = PutFullData -> a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> d_ready h2d = true -> - List.length (device.tl_inflight_ops sL) = 0%nat -> exists ignored sL' sH', device.runUntilResp h2d (device.maxRespDelay sL) sL = (Some ignored, sL') /\ - device_state_related sH' sL' /\ - state_machine.write_step (2 ^ log2_nbytes) sH r v sH' /\ - List.length (device.tl_inflight_ops sL') = 0%nat. + device_state_related sH' sL' [] /\ + state_machine.write_step (2 ^ log2_nbytes) sH r v sH'. Proof. intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. - revert fuel sH sL H H0 HB H7. + revert fuel sH sL H H0 HB. induction B; intros. - exfalso. lia. - - destr fuel; cbn [device.runUntilResp]; destruct_one_match; - pose proof (state_machine_write_to_device_write_or_later - _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 H7 E) as P; - (repeat destruct_one_match; [destruct P as (sH' & R & V & L) | - destruct P as (R & Decr & L) ..]). + - remember (device.run1 sL h2d) as sL' eqn:E. apply eq_sym in E. + destr fuel; cbn [device.runUntilResp]; + pose proof (state_machine_write_to_device_send_write_or_later + _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; + (repeat destruct_one_match; [destruct P as (sH' & R & V) | + destruct P as (R & Decr) ..]); + rewrite ? E in *. + (* 0 remaining fuel, device ready, valid response: *) eauto 10. + (* 0 remaining fuel, device ready, no valid response: *) @@ -333,10 +331,10 @@ Section WithParams. + (* 0 remaining fuel, device not ready: *) exfalso. lia. + (* some remaining fuel, device ready, valid response: *) - clear -R V L. eauto 10. + clear -R V. eauto 10. + (* some remaining fuel, device ready, no valid response: *) - pose proof (state_machine_write_to_device_write_wait - _ _ _ _ _ H R L) as (d2h & sL'' & sH'' & W' & R' & V' & L'). + pose proof (state_machine_write_to_device_ack_write + _ _ _ _ _ _ H R H2 H4 H5) as (d2h & sL'' & sH'' & W' & R' & V'). eapply waitForResp_mono in W'. 1: eauto 10. lia. + (* some remaining fuel, device not ready *) edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); @@ -346,7 +344,7 @@ Section WithParams. Inductive related: MetricRiscvMachine -> ExtraRiscvMachine D -> Prop := mkRelated: forall regs pc npc m xAddrs (t: list LogItem) t_ignored mc d s, execution t s -> - device_state_related s d -> + device_state_related s d [] -> map.undef_on m state_machine.isMMIOAddr -> disjoint (of_list xAddrs) state_machine.isMMIOAddr -> related @@ -537,11 +535,11 @@ Section WithParams. 1-4: match goal with | |- context[device.runUntilResp ?p _ _] => edestruct state_machine_read_to_device_read with (h2d := p) - as (v'' & d'' & s'' & RU'' & Rel'' & RS'' & Len''); + as (v'' & d'' & s'' & RU'' & Rel'' & RS''); [do 2 eexists; match goal with | H: state_machine.read_step ?n _ _ _ _ |- _ => change n at 1 with (2 ^ (Nat.log2 n))%nat in H - end; eassumption|eassumption|reflexivity..|admit|] + end; eassumption|eassumption|reflexivity..|] end. 1-4: cbn -[HList.tuple]; tlsimpl; simpl in RU''; rewrite RU''; cbn -[HList.tuple]. 4: { (* 64-bit MMIO is not supported: *) @@ -576,13 +574,13 @@ Section WithParams. 1-3: match goal with | |- context[device.runUntilResp ?p _ _] => edestruct state_machine_write_to_device_write with (h2d := p) - as (ignored & d' & s'' & RU & Rel' & WS' & Len'); + as (ignored & d' & s'' & RU & Rel' & WS'); [eexists; match goal with | H: state_machine.write_step ?n _ _ _ _ |- _ => change n at 1 with (2 ^ (Nat.log2 n))%nat in H end; eassumption |eassumption - |rewrite ? Z_word_N in * by lia; reflexivity..|admit|] + |rewrite ? Z_word_N in * by lia; reflexivity..|] end. 1-3: cbn -[HList.tuple Primitives.invalidateWrittenXAddrs]; tlsimpl; simpl in RU; rewrite RU; @@ -597,7 +595,7 @@ Section WithParams. (* EndCycleNormal *) { unfold Monads.OStateOperations.put. eauto 10 using mkRelated. } - Admitted. + Qed. Lemma stateMachine_free_to_cava{A: Type}: forall (p: free riscv_primitive primitive_result A) (initialH: MetricRiscvMachine) @@ -628,13 +626,8 @@ Section WithParams. unfold device_step_without_IO. eapply mkRelated. + eassumption. - + match goal with - | |- context[let '(_, _) := ?p in _] => destruct p eqn: E - end. - eapply nonMMIO_device_step_preserves_state_machine_state. 2: eassumption. - 1: instantiate (1 := tl_h2d_default); reflexivity. - simpl. - exact E. + + eapply nonMMIO_device_step_preserves_state_machine_state; + [..|reflexivity]; auto. + assumption. + assumption. Qed. From c001155557916eff7c5819de295ff7121a9dbe19 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Fri, 26 Nov 2021 08:09:09 +0000 Subject: [PATCH 13/16] The counter-device proof is complete --- firmware/IncrementWait/CavaIncrementDevice.v | 609 +++++------------- firmware/IncrementWait/Incr.v | 134 ++-- .../RunIncrementWaitSoftwareOnCava.v | 1 + .../InternalMMIOMachine.v | 8 +- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 23 +- .../hmac/end2end/CavaHmacDevice.v | 15 +- 6 files changed, 246 insertions(+), 544 deletions(-) diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index adae7a8c3..974f27e0a 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -51,20 +51,22 @@ Section WithParameters. Global Instance counter_device: device := {| device.state := denote_type (state_of incr); - device.is_ready_state s := exists r_prev_state r_regs r_inner, - incr_invariant s (RSIdle, r_prev_state, r_regs, TLUL.Idle, r_inner); + + device.is_ready_state s := exists r_regs r_tl r_inner, + incr_invariant s (RSIdle, r_regs, r_tl, r_inner); + device.last_d2h '((_, (_, (_, d2h))), _) := d2h; + device.tl_inflight_ops '((_, (_, (_, d2h))), _) := if d_valid d2h then [d_source d2h] else []; + device.run1 s i := fst (Semantics.step incr s (i, tt)); + device.addr_range_start := INCR_BASE_ADDR; device.addr_range_pastend := INCR_END_ADDR; + device.maxRespDelay '((_, (_, (_, d2h))), _) := - if a_ready d2h then 2 - else if d_valid d2h then 1 - else 0; - (* The last [else] is not reachable, because [d_valid] is always the - negation of [a_ready]. *) + if a_ready d2h then 0 else 1; |}. (* conservative upper bound matching the instance given in IncrementWaitToRiscv *) @@ -72,58 +74,25 @@ Section WithParameters. {| ncycles_processing := 15%nat |}. - Inductive counter_related_base: IncrementWaitSemantics.state -> Incr.repr_state -> Incr.inner_state -> Prop := - | IDLE_related: forall r_innr, - counter_related_base IDLE RSIdle r_innr - | BUSY1_related: forall val ncycles, - (1 < ncycles)%nat -> - counter_related_base (BUSY val ncycles) (RSBusy (word_to_N val)) - (IISBusy (word_to_N val) 1) - | BUSY2_related: forall val ncycles, - (0 < ncycles)%nat -> - counter_related_base (BUSY val ncycles) (RSBusy (word_to_N val)) - (IISBusy (word_to_N val) 2) + Inductive counter_related_spec: IncrementWaitSemantics.state -> Incr.repr_state -> Prop := + | IDLE_related: counter_related_spec IDLE RSIdle + | BUSY_related: forall val ncycles count, + (0 < count <= 2)%nat -> + (2 < ncycles + count)%nat -> + counter_related_spec (BUSY val ncycles) (RSBusy (word_to_N val) count) (* the hardware is already done, but the software hasn't polled it yet to find out, so we have to relate a software-BUSY to a hardware-done: *) - | BUSY_done_related: forall val ncycles r_innr, - counter_related_base (BUSY val ncycles) (RSDone (word_to_N (word.add (word.of_Z 1) val))) r_innr - | DONE_related: forall val r_innr, - counter_related_base (DONE val) (RSDone (word_to_N val)) r_innr. - - Inductive counter_related_spec: IncrementWaitSemantics.state -> repr -> - list tl_h2d -> Prop := - | No_inflight: forall sH r_state r_prev_state r_regs r_inner, - counter_related_base sH r_state r_inner -> - counter_related_spec sH (r_state, r_prev_state, r_regs, TLUL.Idle, r_inner) [] - | Inflight_read_status: forall sH r_state r_prev_state r_regs r_tl r_tl_regs r_inner h2d, - counter_related_base sH r_state r_inner -> - r_tl = TLUL.OutstandingAccessAckData (set_a_address 4 h2d) r_tl_regs -> - a_valid h2d = true -> - a_opcode h2d = Get -> - a_address h2d = word_to_N (state_machine.reg_addr STATUS) -> - counter_related_spec sH (r_state, r_prev_state, r_regs, r_tl, r_inner) [h2d] - | Inflight_read_value: forall r_prev_state r_regs r_tl r_tl_regs r_inner val h2d, - r_tl = TLUL.OutstandingAccessAckData (set_a_address 0 h2d) r_tl_regs -> - nth 0 r_tl_regs 0%N = word_to_N val -> - a_valid h2d = true -> - a_opcode h2d = Get -> - a_address h2d = word_to_N (state_machine.reg_addr VALUE) -> - counter_related_spec (DONE val) - (RSIdle, r_prev_state, r_regs, r_tl, r_inner) - [h2d] - | Inflight_write_value: forall r_prev_state r_regs r_tl r_inner val h2d, - r_tl = TLUL.OutstandingAccessAck (set_a_address 0 h2d) -> - a_valid h2d = true -> - a_opcode h2d = PutFullData -> - a_address h2d = word_to_N (state_machine.reg_addr VALUE) -> - a_data h2d = (word_to_N val) -> - counter_related_spec (IDLE) - (RSBusy (word_to_N val), r_prev_state, r_regs, r_tl, r_inner) - [h2d]. + | BUSY_done_related: forall val ncycles, + counter_related_spec (BUSY val ncycles) (RSDone (word_to_N (word.add (word.of_Z 1) val))) + | DONE_related: forall val, + counter_related_spec (DONE val) (RSDone (word_to_N val)). Definition counter_related {invariant : invariant_for incr repr} (sH : IncrementWaitSemantics.state) (sL : denote_type (state_of incr)) (inflight_h2ds : list tl_h2d) : Prop := - exists repr, counter_related_spec sH repr inflight_h2ds /\ invariant sL repr. + exists r_state r_regs r_tl r_inner, + inflight_h2ds = [] /\ + counter_related_spec sH r_state /\ + invariant sL (r_state, r_regs, r_tl, r_inner). (* This should be in bedrock2.ZnWords. It is use by ZnWords, which is used in the two following Lemmas. *) @@ -137,96 +106,63 @@ Section WithParameters. (0 <= x < 2 ^ 32)%Z -> word_to_N (word.of_Z x) = Z.to_N x. Proof. intros. unfold word_to_N. ZnWords. Qed. - Set Printing Depth 100000. - - Ltac destruct_pair_let_hyp := - match goal with - | H: context [ match ?p with - | pair _ _ => _ - end ] |- _ => - destruct p as [?p0 ?p1] eqn:?H0 - end. - - Ltac destruct_pair_equal_hyp := - match goal with - | H: context [ (?l0, ?l1) = (?r0, ?r1) ] |- _ => - eapply pair_equal_spec in H; destruct H as [?H0 ?H1] - end. - Lemma N_to_word_word_to_N: forall v, N_to_word (word_to_N v) = v. Proof. intros. unfold N_to_word, word_to_N. ZnWords. Qed. -(* TODO move to coqutil *) -Ltac contradictory H := - lazymatch type of H with - | ?x <> ?x => exfalso; apply (H eq_refl) - | False => case H - end. - -Require Import coqutil.Tactics.autoforward. - -Ltac fwd_step ::= - match goal with - | H: ?T |- _ => is_destructible_and T; destr_and H - | H: exists y, _ |- _ => let yf := fresh y in destruct H as [yf H] - | H: ?x = ?x |- _ => clear H - | H: True |- _ => clear H - | H: ?LHS = ?RHS |- _ => - let h1 := head_of_app LHS in is_constructor h1; - let h2 := head_of_app RHS in is_constructor h2; - (* if not eq, H is a contradiction, but we don't want to change the number - of open goals in this tactic *) - constr_eq h1 h2; - (* we don't use `inversion H` or `injection H` because they unfold definitions *) - inv_rec LHS RHS; - clear H - | E: ?x = ?RHS |- context[match ?x with _ => _ end] => - let h := head_of_app RHS in is_constructor h; rewrite E in * - | H: context[match ?x with _ => _ end], E: ?x = ?RHS |- _ => - let h := head_of_app RHS in is_constructor h; rewrite E in * - | H: context[match ?x with _ => _ end] |- _ => - (* note: recursive invocation of fwd_step for contradictory cases *) - destr x; try solve [repeat fwd_step; contradictory H]; [] - | H: _ |- _ => autoforward with typeclass_instances in H - | |- _ => progress subst - | |- _ => progress fwd_rewrites - end. - - Axiom TODO: False. - Ltac use_spec := match goal with | Hrun: device.run1 ?sL ?input = ?sL', Hinv: incr_invariant ?sL ?repr |- _ => assert (Hprec: precondition incr (input, tt) repr); - [| - (* pose proof (output_correct_pf (c:=incr) (input, tt) sL repr Hinv Hprec) as Hpostc. *) - remember (update_repr (c:=incr) (input, tt) repr) as repr' eqn:Erepr'; - pose proof (invariant_preserved_pf (c:=incr) (input, tt) sL repr repr' Erepr' Hinv Hprec) as Hinv'; - unfold device.run1, counter_device in Hrun; - match type of Hrun with - | fst ?step = _ => - remember step as res eqn:Hstep; - destruct res as (?sL'' & ?d2h); - cbn in Hrun; subst sL''; clear Hstep - end; - cbn [fst] in Hinv'] + [ simplify_spec (incr (var:=var)); simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec (Incr.inner (var:=var)); + simplify_invariant (incr (var:=var)); + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); + destruct_tl_h2d; tlsimpl; logical_simplify; subst; + ssplit; intros; try discriminate; auto + + | remember (update_repr (c:=incr) (input, tt) repr) as repr' eqn:Erepr'; + (* pose proof (output_correct_pf (c:=incr) (input, tt) sL repr Hinv Hprec) as Hpostc. *) + pose proof (invariant_preserved_pf (c:=incr) (input, tt) sL repr repr' Erepr' Hinv Hprec) as Hinv'; + unfold device.run1, counter_device in Hrun; + match type of Hrun with + | fst ?step = _ => + remember step as res eqn:Hstep; + destruct res as (?sL'' & ?d2h); + cbn in Hrun; subst sL''; clear Hstep + end; + cbn [fst] in Hinv'; + destruct repr' as (((?r_state, ?r_regs), ?r_tl), ?r_inner)] end. Ltac inversion_rel_spec := match goal with - | H: counter_related_spec _ _ _ |- _ => inversion H; subst - end. - Ltac inversion_rel_base := - match goal with - | H: counter_related_base _ _ _ |- _ => inversion H; subst + | H: counter_related_spec _ _ |- _ => inversion H; subst end. - (* Lemma output_last_d2h : forall s h2d s' d2h, *) - (* (s', d2h) = Semantics.step incr s (h2d, tt) -> *) - (* device.last_d2h s' = d2h. *) - (* Proof. *) + Ltac simplify_tl_repr := + unfold device.maxRespDelay, device.last_d2h, counter_device in *; + repeat match goal with + | sL: device.state |- _ => + cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)) + end; + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; logical_simplify; subst; + simplify_invariant (incr (var:=var)); + match goal with + | H: _ = update_repr _ (_, _, ?r_tl, _) |- _ => + destruct r_tl; logical_simplify; tlsimpl; subst; + (* logical_simplify; subst; *) + cbn in H; rewrite ? Z_word_N in H by lia; cbn in H + end; + logical_simplify; subst; + cbn; rewrite ? Z_word_N by lia; cbn; + change (Pos.to_nat 1) with 1; + repeat match goal with + | H: length ?regs = 2 |- _ => + destruct regs as [|? [|? [|]]]; cbn in H; try discriminate H; clear H; + cbn [nth] in *; subst + end; + try discriminate. Global Instance cava_counter_satisfies_state_machine: device_implements_state_machine counter_device increment_wait_state_machine. @@ -235,323 +171,136 @@ Ltac fwd_step ::= - (* mmioAddrs_match: *) reflexivity. - (* initial_state_is_ready_state: *) - intros ? ? ? Hrel. - cbn in *. subst. destruct Hrel as [?repr [?Hrel ?Hinv]]. - inversion_rel_spec. inversion_rel_base. - repeat eexists. eapply Hinv. + intros. + unfold device.is_ready_state, counter_device, counter_related in *; + logical_simplify. + cbn in *; subst. + inversion_rel_spec; repeat eexists; eassumption. - (* initial_states_are_related: *) - intros ? ? ? Hready. - cbn in *. destruct Hready as (?r_prev_state & ?r_regs & ?r_inner & ?Hinv). subst. - unfold counter_related. eexists. split; [|apply Hinv]. - apply No_inflight, IDLE_related. + intros. + cbn in *; logical_simplify; subst. + unfold counter_related; repeat eexists; [|eassumption]. + apply IDLE_related. - (* initial_state_exists: *) - intros ? Hready. - cbn in *. destruct Hready as (?r_prev_state & ?r_regs & ?r_inner & ?Hinv). - eexists. split; [reflexivity|]. - unfold counter_related. eexists. split; [|apply Hinv]. - apply No_inflight, IDLE_related. + intros. + cbn in *; logical_simplify; subst. + unfold counter_related; repeat eexists; [|eassumption]. + apply IDLE_related. - (* nonMMIO_device_step_preserves_state_machine_state: *) - intros ? ? ? ? Ha_valid [repr [Hrel Hinv]] **. - use_spec. - { destruct_tl_h2d. destruct_tl_d2h. tlsimpl. - cbn in sL1; destruct sL1 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)). - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner). - simplify_invariant incr. logical_simplify. - subst. cbn. ssplit; intros; [auto|discriminate|auto]. - } - exists repr'; split; [|auto]. - inversion_rel_spec; inversion_rel_base; - destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst; - cbn in sL1; destruct sL1 as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - simplify_invariant incr; logical_simplify; subst; cbn -[replace]; - apply No_inflight; try (constructor; lia); []. - replace ((word_to_N val + 1) mod 4294967296)%N with - (word_to_N (word.add (word.of_Z 1) val)) by - (unfold word_to_N; ZnWords); - apply BUSY_done_related. + intros. + logical_simplify. + unfold counter_related in *; logical_simplify. + use_spec. clear Hprec. + repeat eexists; [|eassumption]. + inversion_rel_spec; simplify_tl_repr; + destruct d_ready; logical_simplify; subst; try constructor; + (destruct count as [|[|[|]]]; [exfalso; lia|..|exfalso; lia]); + rewrite ? incrN_word_to_bv; constructor; lia. - (* [state_machine_read_to_device_send_read_or_later] *) - intros ? ? ? ? ? ? [v [sH'' Hex_read]] [repr [Hrel Hinv]] **. - cbn in Hex_read. logical_simplify. - rewrite H5. clear H5. - use_spec. - 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; - simplify_invariant incr; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - destruct_tl_h2d; tlsimpl; logical_simplify; subst; - ssplit; intros; auto. + intros ? ? ? ? ? ? [v [sH'' [Hpow2 Hex_read]]] **. + rewrite Hpow2. clear Hpow2. + unfold counter_related in *. cbn in Hex_read. logical_simplify. + use_spec. clear Hprec. destruct_one_match; [destruct_one_match|]. - (* case 1: device ready, valid response - In our TL implementation [a_ready = negb d_valid], hence this case - is not possible. - case 3: device not ready - If the inflight queue is empty, the device must be ready, hence - this case is not possible. *) - 1,3: exfalso; - unfold device.last_d2h, counter_device in *; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; - inversion_rel_spec; logical_simplify; discriminate. - (* device ready, no valid response: *) - ssplit. - 1: eexists; split; [|eassumption]; []. - all: - unfold device.tl_inflight_ops, device.last_d2h, device.maxRespDelay, - counter_device, counter_related in *; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - cbn in sL'; destruct sL' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - destruct_tl_d2h; destruct_tl_h2d; - simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); - simplify_invariant incr; - logical_simplify; tlsimpl; subst; - cbn in Hinv'; logical_simplify; subst. - + destruct r. - * (* [r:=VALUE] *) - inversion_rel_spec; inversion_rel_base; destruct H6; subst. - cbn; replace (N.land (word_to_N (word.of_Z 16384)) 4) with 0%N - by (rewrite Z_word_N by lia; reflexivity); - cbn; eapply Inflight_read_value; [eauto| |reflexivity..]. - logical_simplify. assumption. - * (* [r:=STATUS] *) - inversion_rel_spec; inversion_rel_base; subst; logical_simplify; subst; cbn. - eapply Inflight_read_status; try (constructor; lia). - all: replace (N.land (word_to_N (word.of_Z 16388)) 4) with 4%N - by (rewrite Z_word_N by lia; reflexivity); eauto. - all: cbn; replace ((word_to_N val + 1) mod 4294967296)%N with - (word_to_N (word.add (word.of_Z 1) val)) by - (unfold word_to_N; ZnWords); constructor. - - + inversion_rel_spec; inversion_rel_base; subst; logical_simplify; subst; lia. + { (* case 1: device ready, valid response *) + destruct r. + - (* [r:=VALUE] *) + inversion_rel_spec; destruct Hex_read; subst. + eexists; split; [|cbn; ssplit; try reflexivity]. + + repeat eexists; [|eassumption]. + simplify_tl_repr; constructor. + + simplify_tl_repr. + apply N_to_word_word_to_N. + - (* [r:=STATUS] *) + inversion_rel_spec. + + eexists; split; [repeat eexists; [|eassumption]|cbn; ssplit; try reflexivity]; + simplify_tl_repr. + * constructor. + * unfold N_to_word, status_value; ZnWords. + + + destruct ncycles as [|]; [exfalso; lia|]. + eexists; split; [repeat eexists; [|eassumption]|cbn; ssplit; try reflexivity]; + simplify_tl_repr. + * destruct count as [|[|[|]]]; [exfalso; lia|..|exfalso; lia]. + -- apply BUSY_related with (ncycles:=ncycles); lia. + -- rewrite incrN_word_to_bv; apply BUSY_done_related. + * right. eexists; ssplit; try reflexivity. + unfold N_to_word, status_value; ZnWords. + + + eexists; split; [repeat eexists; [|eassumption]|cbn; ssplit; try reflexivity]; + simplify_tl_repr. + * apply DONE_related. + * left. split; [|reflexivity]. + unfold N_to_word, status_value; ZnWords. + + + eexists; split; [repeat eexists; [|eassumption]|cbn; ssplit; try reflexivity]; + simplify_tl_repr. + * apply DONE_related. + * unfold N_to_word, status_value; ZnWords. + } + + { (* case 2: device ready, no valid response *) + exfalso; simplify_tl_repr. + } + + { (* case 3: device not ready *) + ssplit. + - repeat eexists; [|eassumption]. + inversion_rel_spec; simplify_tl_repr; + rewrite ? incrN_word_to_bv; try (constructor; lia). + all: destruct count as [|[|[|]]]; [exfalso; lia + |apply BUSY_related with (ncycles:=ncycles); lia + |apply BUSY_done_related + |exfalso; lia]. + - simplify_tl_repr; lia. + } - (* [state_machine_read_to_device_ack_read_or_later] *) - intros ? ? ? ? ? ? [v [sH'' Hex_read]] [repr [Hrel Hinv]] **. - (* assert (Hex_rel: exists sL'' h2d', device.run1 sL'' (set_d_ready true h2d') = sL /\ *) - (* counter_related sH sL'' []). *) - (* { admit. } *) - (* logical_simplify. destruct H0 as [repr'' [Hrel'' Hinv'']]. *) - (* use_spec. 1: admit. *) - (* rename Hprec into Hprec''. rename repr' into repr'''. rename Erepr' into Erepr''. rename Hinv' into Hinv'''. *) - cbn in Hex_read. logical_simplify. - rewrite H2. clear H2. rename H3 into Hex_read. - use_spec. - 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; - simplify_invariant incr; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner); - destruct r_state; - destruct_tl_h2d; tlsimpl; logical_simplify; subst; - ssplit; intros; auto. - - destruct_one_match. - (* case 2: no valid response - If the inflight queue is not empty, the device must be sending a - response, hence this case is not possible. *) - 2: unfold device.last_d2h, counter_device in *; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as (((?r_state, ?r_regs), ?r_tl), ?r_inner); - simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; - inversion_rel_spec; try inversion_rel_base; logical_simplify; subst; - try destruct r_tl; logical_simplify; subst; - discriminate. - - (* case 1: valid response *) - destruct r. - + (* [r:=VALUE] *) - inversion_rel_spec; - try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). - - destruct Hex_read; subst. - logical_simplify; subst. - exists IDLE. ssplit. - * eexists. split; [|eassumption]. - cbn. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - simplify_invariant incr; - logical_simplify; tlsimpl; subst. - apply No_inflight, IDLE_related. - * cbn. ssplit; try reflexivity. - clear Hinv'. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - simplify_invariant incr. - logical_simplify; subst. - destruct_tl_h2d; tlsimpl; subst. - rewrite H19. cbn. rewrite H3. apply N_to_word_word_to_N. - + (* [r:=STATUS] *) - inversion_rel_spec; - try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). - - inversion_rel_base; - cbn in sL |- *; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - simplify_invariant incr; - logical_simplify; subst; logical_simplify; subst; - match goal with - | H: d_data _ = _ |- _ => - rewrite H - end; - cbn; destruct_tl_h2d; tlsimpl; subst; cbn; - change (Pos.to_nat 1) with 1. - (* match goal with *) - (* | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H *) - (* end; *) - (* unfold N_to_word, status_value. *) - * eexists; ssplit; try reflexivity. - -- eexists. - ssplit; [|eassumption]. - apply No_inflight. constructor. - -- assert (Hprev: r_prev_state = RSIdle) by admit. - subst. - match goal with - | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H - end; unfold N_to_word, status_value. - ZnWords. - * destruct ncycles as [|ncycles]; [lia|]. - eexists; ssplit; try reflexivity. - -- eexists. ssplit; [|eassumption]. - apply No_inflight, BUSY2_related. apply lt_S_n. eauto. - -- right. eexists. ssplit; [reflexivity| |reflexivity]. - assert (Hprev: exists d, r_prev_state = RSBusy d) by admit. - logical_simplify; subst. - match goal with - | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H - end; unfold N_to_word, status_value. - ZnWords. - * destruct ncycles as [|ncycles]; [lia|]. - eexists. ssplit; try reflexivity. - -- eexists. ssplit; [|eassumption]. - cbn; rewrite incrN_word_to_bv. - apply No_inflight, BUSY_done_related. - -- right. eexists. ssplit; [reflexivity| |reflexivity]. - assert (Hprev: exists d, r_prev_state = RSBusy d) by admit. - logical_simplify; subst. - match goal with - | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H - end; unfold N_to_word, status_value. - ZnWords. - * eexists; ssplit; try reflexivity. - -- eexists. ssplit; [|eassumption]. - apply No_inflight, DONE_related. - -- left. ssplit; [|reflexivity]. - assert (Hprev: exists d, r_prev_state = RSDone d) by admit. - logical_simplify; subst; logical_simplify; - match goal with - | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H - end; unfold N_to_word, status_value. - ZnWords. - * eexists; ssplit; try reflexivity. - -- eexists. ssplit; [|eassumption]. - apply No_inflight, DONE_related. - -- assert (Hprev: exists d, r_prev_state = RSDone d) by admit. - logical_simplify; subst; logical_simplify. - match goal with - | H: nth 1 r_tl_regs 0%N = _ |- _ => rewrite H - end; unfold N_to_word, status_value. - ZnWords. + intros. + unfold counter_related in *; logical_simplify. + discriminate. - (* [state_machine_write_to_device_send_write_or_later] *) - intros ? ? ? ? ? ? ? [sH'' [Hpow2 Hex_write]] [repr [Hrel Hinv]] **. + intros ? ? ? ? ? ? ? [sH'' [Hpow2 Hex_write]] **. rewrite Hpow2. clear Hpow2. - use_spec. - 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; - simplify_invariant incr; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - destruct_tl_h2d; tlsimpl; logical_simplify; subst; - ssplit; intros; auto. - + unfold counter_related in *. logical_simplify. + use_spec. clear Hprec. destruct_one_match; [destruct_one_match|]. - (* case 1: device ready, valid response - In our TL implementation [a_ready = negb d_valid], hence this case - is not possible. - case 3: device not ready - If the inflight queue is empty, the device must be ready, hence - this case is not possible. *) - 1,3: exfalso; - unfold device.last_d2h, counter_device in *; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; - inversion_rel_spec; logical_simplify; discriminate. - (* device ready, no valid response: *) - ssplit. - 1: eexists; split; [|eassumption]; []. - all: - unfold device.tl_inflight_ops, device.last_d2h, device.maxRespDelay, - counter_device, counter_related in *; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - cbn in sL'; destruct sL' as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - destruct_tl_d2h; destruct_tl_h2d; - simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); - simplify_invariant incr; - logical_simplify; tlsimpl; subst; - cbn in Hinv'; logical_simplify; subst. - + destruct r. - * (* [r:=VALUE] *) - inversion_rel_spec; inversion_rel_base; logical_simplify; subst; try contradiction. - cbn. apply Inflight_write_value; eauto; []. - rewrite Z_word_N by lia. change (Z.to_N 16384) with 16384%N. reflexivity. - * (* [r:=STATUS] *) - inversion_rel_spec; inversion_rel_base; + + { (* case 1: device ready, valid response *) + destruct r. + + (* [r:=VALUE] *) + inversion_rel_spec; destruct Hex_write; subst. + eexists; split; [|cbn; ssplit; try reflexivity]. + repeat eexists; [|eassumption]. + simplify_tl_repr; constructor; lia. + + (* [r:=STATUS] *) destruct Hex_write. - + inversion_rel_spec; inversion_rel_base; subst; logical_simplify; subst; lia. + } + + { (* case 2: device ready, no valid response *) + exfalso; simplify_tl_repr. + } + + { (* case 3: device not ready *) + ssplit. + - repeat eexists; [|eassumption]. + inversion_rel_spec; simplify_tl_repr; + rewrite ? incrN_word_to_bv; try (constructor; lia). + all: destruct count as [|[|[|]]]; [exfalso; lia + |apply BUSY_related with (ncycles:=ncycles); lia + |apply BUSY_done_related + |exfalso; lia]. + - simplify_tl_repr; lia. + } - (* [state_machine_write_to_device_ack_write_or_later] *) - intros ? ? ? ? ? ? ? [sH'' [Hpow2 Hex_write]] [repr [Hrel Hinv]] **. - rewrite Hpow2 in *. clear Hpow2. - use_spec. - 1: simplify_spec incr; simplify_spec (tlul_adapter_reg (reg_count:=2)); simplify_spec Incr.inner; - simplify_invariant incr; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - destruct_tl_h2d; tlsimpl; logical_simplify; subst; - ssplit; intros; auto. - - destruct_one_match. - (* case 2: no valid response - If the inflight queue is not empty, the device must be sending a - response, hence this case is not possible. *) - 2: unfold device.last_d2h, counter_device in *; - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - destruct repr as ((((?r_state, ?r_prev_state), ?r_regs), ?r_tl), ?r_inner); - simplify_invariant incr; subst; logical_simplify; destruct_tl_d2h; tlsimpl; subst; - inversion_rel_spec; try inversion_rel_base; logical_simplify; subst; - try destruct r_tl; logical_simplify; subst; - discriminate. - - (* case 1: valid response *) - destruct r. - + (* [r:=VALUE] *) - inversion_rel_spec; - try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). - - destruct Hex_write; subst. - logical_simplify; subst. - eexists. ssplit; [|cbn; split; reflexivity]. - eexists. split; [|eassumption]. - cbn. - cbn in sL; destruct sL as ((?busy, (?done, (?regs, ?d2h))), (?s_tl, ?s_inner)); - simplify_invariant incr; - logical_simplify; tlsimpl; subst. - apply No_inflight. - simplify_invariant Incr.inner; destruct s_inner; logical_simplify. - destruct x as [|[|[|]]]; [exfalso; lia|..| exfalso; lia]; - destruct_tl_h2d; tlsimpl; subst; - match goal with - | H: word_to_N v = word_to_N val |- _ => - rewrite <- H - end. - * constructor; lia. - * replace ((word_to_N v + 1) mod 4294967296)%N with - (word_to_N (word.add (word.of_Z 1) v)) by - (unfold word_to_N; ZnWords). - constructor. - + (* [r:=STATUS] *) - inversion_rel_spec; - try (exfalso; destruct_tl_h2d; tlsimpl; subst; unfold word_to_N in *; cbn in *; ZnWords). + intros. + unfold counter_related in *; logical_simplify. + discriminate. + - (* read_step_unique: *) intros. simpl in *. unfold read_step in *. simp. destruct v; destruct r; try contradiction; simp; try reflexivity. diff --git a/firmware/IncrementWait/Incr.v b/firmware/IncrementWait/Incr.v index 3d7cd72b4..96ee0f394 100644 --- a/firmware/IncrementWait/Incr.v +++ b/firmware/IncrementWait/Incr.v @@ -128,7 +128,6 @@ Definition sim {s i o} (c : Circuit s i o) (input : list (denote_type i)) (acc ++ [(s, i, o)], s')) input ([], reset_state c)). -(* Print sample_trace. *) Example sample_trace := Eval compute in @@ -160,6 +159,7 @@ Example sample_trace := ; (nop, tt) ; (read_reg 4, tt) (* status *) ]%N. +(* Print sample_trace. *) Section Spec. Local Open Scope N. @@ -225,7 +225,7 @@ Section Spec. cbv [inner inner_spec_step]. stepsimpl. repeat (destruct_pair_let; cbn [fst snd]). destruct repr as [|? iiscount|?]; logical_simplify; subst. - - destruct valid; cbn; try ssplit; lia. + - destruct valid; cbn; ssplit; lia. - destruct iiscount as [|[|[|iiscount]]]; cbn; ssplit; lia. - reflexivity. Qed. @@ -241,8 +241,8 @@ Section Spec. cbv [inner inner_spec_step]. stepsimpl. repeat (destruct_pair_let; cbn [fst snd]). destruct repr as [|? iiscount|?]; logical_simplify; subst. - - destruct valid; eexists; cbn; try ssplit; reflexivity. - - destruct iiscount as [|[|[|iiscount]]]; try lia; try eexists; reflexivity. + - destruct valid; eexists; cbn; ssplit; reflexivity. + - destruct iiscount as [|[|[|iiscount]]]; try lia; eexists; reflexivity. - eexists. reflexivity. Qed. @@ -254,15 +254,15 @@ Section Spec. Variant repr_state := | RSIdle - | RSBusy (data : N) + | RSBusy (data : N) (count: nat) | RSDone (res : N). - Definition repr := (repr_state * repr_state * list N * TLUL.repr_state * inner_repr)%type. + Definition repr := (repr_state * list N * TLUL.repr_state * inner_repr)%type. Global Instance incr_invariant : invariant_for incr repr := fun (state : denote_type (state_of incr)) repr => let '((s_busy, (s_done, (s_regs, s_d2h))), (s_tlul, s_inner)) := state in - let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in + let '(r_state, r_regs, r_tl, r_inner) := repr in tlul_invariant (reg_count:=2) s_tlul r_tl /\ match r_tl with | TLUL.Idle => @@ -280,13 +280,6 @@ Section Spec. /\ d_user s_d2h = 0 /\ d_error s_d2h = false /\ a_ready s_d2h = false - /\ match r_prev_state with - | RSIdle => nth 1 regs 0%N = 1 - | RSBusy data => nth 1 regs 0%N = 2 - | RSDone res => nth 0 regs 0%N = res - /\ nth 1 regs 0%N = 4 - end - (* /\ (exists input, update_repr (r_prev_state, ... ..) = r_state) *) | TLUL.OutstandingAccessAck h2d => d_valid s_d2h = true /\ d_opcode s_d2h = AccessAck @@ -303,9 +296,9 @@ Section Spec. | RSIdle => s_busy = false /\ s_done = false /\ r_inner = IISIdle /\ nth 1 r_regs 0%N = 1 - | RSBusy data => s_busy = true /\ s_done = false - /\ (exists c, r_inner = IISBusy data c) - /\ nth 1 r_regs 0%N = 2 + | RSBusy data count => s_busy = true /\ s_done = false + /\ r_inner = IISBusy data count + /\ nth 1 r_regs 0%N = 2 | RSDone res => s_busy = false /\ s_done = true /\ (r_inner = IISDone res \/ r_inner = IISIdle) /\ nth 0 r_regs 0%N = res @@ -318,12 +311,12 @@ Section Spec. Instance incr_specification : specification_for incr repr := - {| reset_repr := (RSIdle, RSIdle, [0; 1], TLUL.Idle, IISIdle); + {| reset_repr := (RSIdle, [0; 1], TLUL.Idle, IISIdle); update_repr := fun (input : denote_type (input_of incr)) repr => let '(i_h2d, tt) := input in - let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in + let '(r_state, r_regs, r_tl, r_inner) := repr in let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in @@ -360,7 +353,7 @@ Section Spec. else RSIdle | _ => match r_inner' with - | IISBusy data _ => RSBusy data + | IISBusy data count => RSBusy data count | IISDone res => RSDone res | _ => r_state end @@ -375,16 +368,16 @@ Section Spec. let r_regs' := match r_state' with | RSIdle => replace 1 1 r_regs' - | RSBusy _ => replace 1 2 r_regs' + | RSBusy _ _ => replace 1 2 r_regs' | RSDone _ => replace 1 4 r_regs' end in - (r_state', r_state, r_regs', r_tl', r_inner'); + (r_state', r_regs', r_tl', r_inner'); precondition := fun (input : denote_type (input_of incr)) repr => let '(i_h2d, tt) := input in - let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in + let '(r_state, r_regs, r_tl, r_inner) := repr in let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in @@ -408,31 +401,31 @@ Section Spec. fun (input : denote_type (input_of incr)) repr (output : denote_type (output_of incr)) => let '(i_h2d, tt) := input in - let '(r_state, r_prev_state, r_regs, r_tl, r_inner) := repr in - + let '(r_state, r_regs, r_tl, r_inner) := repr in let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in - let postc_tlul := - let tlul_input := (h2d, (r_regs, tt)) in - exists req, - postcondition (tlul_adapter_reg (reg_count:=2)) - tlul_input r_tl - (output, req) in - postc_tlul; + (* let postc_tlul := *) + (* let tlul_input := (h2d, (r_regs, tt)) in *) + (* exists req, *) + (* postcondition (tlul_adapter_reg (reg_count:=2)) *) + (* tlul_input r_tl *) + (* (output, req) in *) + (* postc_tlul; *) + True; |}. Lemma incr_invariant_at_reset : invariant_at_reset incr. Proof. simplify_invariant incr. cbn. ssplit; [apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2)) - | reflexivity..]. + |reflexivity..]. Qed. Existing Instance tlul_adapter_reg_correctness. Lemma incr_invariant_preserved : invariant_preserved incr. Proof. - intros (h2d, t) state ((((r_state, r_prev_state), r_regs), r_tl), r_inner). destruct t. + intros (h2d, t) state (((r_state, r_regs), r_tl), r_inner). destruct t. cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). destruct_tl_h2d. destruct_tl_d2h. intros repr' ? Hinvar Hprec; subst. @@ -447,6 +440,7 @@ Section Spec. end. stepsimpl. use_correctness. + clear H5. rename H9 into Hpostc_tl. repeat (destruct_pair_let; cbn [fst snd]). ssplit. @@ -455,8 +449,7 @@ Section Spec. + reflexivity. + assumption. - pose (r_tl_:=r_tl); destruct r_tl; logical_simplify; subst. - + clear H5. - destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. + + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst; pose (a_valid_:=a_valid); (destruct a_valid; [ match goal with @@ -464,13 +457,11 @@ Section Spec. destruct H; [auto|subst..] end|]); cbn in *; logical_simplify; subst; ssplit; auto. - + clear H5. - destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. + + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst; pose (d_ready_:=d_ready); destruct d_ready; cbn in *; logical_simplify; subst; ssplit; auto. - + clear H5. - destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. + + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst. pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst; pose (d_ready_:=d_ready); destruct d_ready; cbn in *; logical_simplify; subst; ssplit; reflexivity. @@ -493,10 +484,7 @@ Section Spec. * destruct d_ready; logical_simplify; subst; boolsimpl; destruct r_state; reflexivity. + simplify_spec inner. auto. - - match goal with - | H: context [_ -> precondition inner _ r_inner] |- _ => clear H - end. - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; + - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; logical_simplify; subst. all: simplify_invariant inner. all: try discriminate. @@ -513,10 +501,7 @@ Section Spec. all: try (destruct d_ready; logical_simplify; subst; cbn; ssplit; eauto; destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). - - match goal with - | H: context [_ -> precondition inner _ r_inner] |- _ => clear H - end. - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; + - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; logical_simplify; subst. all: simplify_invariant inner. all: try discriminate. @@ -538,55 +523,10 @@ Section Spec. Lemma incr_output_correct : output_correct incr. Proof. - Admitted. - (* intros (h2d, t) state (((r_state, r_regs), r_tl), r_inner). destruct t. *) - (* cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)). *) - (* destruct_tl_h2d. destruct_tl_d2h. *) - (* intros Hinvar Hprec; subst. *) - (* simplify_invariant incr. logical_simplify. subst. *) - (* simplify_spec incr. logical_simplify. subst. *) - (* match goal with *) - (* | |- context [step incr ?s ?i] => *) - (* remember (step incr s i) as step eqn:Estep; *) - (* cbv -[Semantics.step inner tlul_adapter_reg] in Estep; *) - (* subst *) - (* end. *) - (* stepsimpl. *) - (* use_correctness. *) - (* match goal with *) - (* | H: (match outstanding_h2d (_::r_tl) with | _ => _ end) |- _ => *) - (* rename H into Htl_postc *) - (* end. *) - (* repeat (destruct_pair_let; cbn [fst snd]). *) - (* tlsimpl. *) - (* destruct r_inner; destruct r_state; destruct inner_st; *) - (* unfold inner_invariant in H0; logical_simplify; subst; *) - (* try discriminate; *) - (* try (destruct H5; discriminate). *) - (* all: destruct (outstanding_h2d r_tl) eqn:Houts; *) - (* cbn [outstanding_h2d] in Htl_postc |- *; rewrite Houts in Htl_postc |- *. *) - (* all: tlsimpl; destruct d_ready; logical_simplify; subst; boolsimpl. *) - (* all: do 9 eexists. *) - (* all: ssplit; try reflexivity; tlsimpl; ssplit; try reflexivity; try assumption. *) - (* all: try (eapply outstanding_prec in H; *) - (* try match goal with *) - (* | H: outstanding_h2d _ = Some _ |- outstanding_h2d _ = Some _ => *) - (* apply H *) - (* end; destruct H; rewrite H in Htl_postc |- *; cbn in Htl_postc |- *; *) - (* logical_simplify; subst; ssplit; *) - (* try (left; reflexivity); *) - (* try (right; reflexivity); *) - (* try assumption; *) - (* reflexivity). *) - (* all: try (destruct a_valid; simplify_spec (tlul_adapter_reg (reg_count:=2)); *) - (* tlsimpl; destruct H2; *) - (* try match goal with *) - (* | H: true = true -> _ |- _ => *) - (* destruct H; try reflexivity; subst *) - (* end; cbn in Htl_postc; logical_simplify; subst; cbn; ssplit; *) - (* try eexists; try assumption; reflexivity). *) - (* Unshelve. all: auto. *) - (* Qed. *) + intros ? **. + simplify_spec incr. destruct input. destruct d0. destruct r as [[[? ?] ?] ?]. + apply I. + Qed. Existing Instances incr_invariant_at_reset incr_invariant_preserved incr_output_correct. diff --git a/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v b/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v index 16e312797..e6397e2ff 100644 --- a/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v +++ b/firmware/IncrementWait/RunIncrementWaitSoftwareOnCava.v @@ -4,6 +4,7 @@ Require Import coqutil.Datatypes.List. Require Import coqutil.Word.Interface coqutil.Map.Interface. Require Import coqutil.Map.OfListWord. Require Import Bedrock2Experiments.RiscvMachineWithCavaDevice.InternalMMIOMachine. +Require Import Bedrock2Experiments.IncrementWait.Incr. Require Import Bedrock2Experiments.IncrementWait.IncrementWaitToRiscV. Require Import Bedrock2Experiments.IncrementWait.CavaIncrementDevice. Require Import riscv.Spec.Decode. diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index 9c9b836f3..442acb2a6 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -91,7 +91,7 @@ Module device. Definition waitForResp{D: device} := fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := let next := device.run1 s (set_d_ready true tl_h2d_default) in - if d_valid (device.last_d2h s) then (Some (device.last_d2h s), next) + if d_valid (device.last_d2h next) then (Some (device.last_d2h next), next) else match fuel with | O => (None, s) @@ -104,8 +104,8 @@ Module device. fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := let next := device.run1 s h2d in if a_ready (device.last_d2h s) then - if d_valid (device.last_d2h s) then - (Some (device.last_d2h s), next) + if d_valid (device.last_d2h next) then + (Some (device.last_d2h next), next) else match fuel with | O => (None, s) @@ -270,7 +270,7 @@ Section WithParams. end. Definition device_step_without_IO(d: D): D := - let next_state := (device.run1 d tl_h2d_default) in next_state. + let next_state := device.run1 d (set_d_ready true tl_h2d_default) in next_state. Fixpoint device_steps(n: nat): OState (ExtraRiscvMachine D) unit := match n with diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index 8ed93d808..1d1f3e323 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -74,10 +74,10 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte d_ready h2d = true -> device.run1 sL h2d = sL' -> if a_ready (device.last_d2h sL) then - if d_valid (device.last_d2h sL) then + if d_valid (device.last_d2h sL') then exists sH', device_state_related sH' sL' [] /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL))) sH' + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL'))) sH' else device_state_related sH sL' [h2d] /\ (device.maxRespDelay sL' < device.maxRespDelay sL)%nat @@ -87,15 +87,14 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte state_machine_read_to_device_ack_read_or_later: forall log2_nbytes r sH sL sL' h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> - (exists sL'' h2d', device.run1 sL'' (set_d_ready true h2d') = sL) -> device_state_related sH sL [h2d] -> a_opcode h2d = Get -> a_address h2d = word_to_N (state_machine.reg_addr r) -> device.run1 sL (set_d_ready true tl_h2d_default) = sL' -> - if d_valid (device.last_d2h sL) then + if d_valid (device.last_d2h sL') then exists sH', device_state_related sH' sL' [] /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL))) sH' + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL'))) sH' else device_state_related sH sL' [h2d] /\ (device.maxRespDelay sL' < device.maxRespDelay sL)%nat; @@ -118,7 +117,7 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte d_ready h2d = true -> device.run1 sL h2d = sL' -> if a_ready (device.last_d2h sL) then - if d_valid (device.last_d2h sL) then + if d_valid (device.last_d2h sL') then exists sH', device_state_related sH' sL' [] /\ state_machine.write_step (2 ^ log2_nbytes) sH r v sH' @@ -136,7 +135,7 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> device.run1 sL (set_d_ready true tl_h2d_default) = sL' -> - if d_valid (device.last_d2h sL) then + if d_valid (device.last_d2h sL') then exists sH', device_state_related sH' sL' [] /\ state_machine.write_step (2 ^ log2_nbytes) sH r v sH' @@ -273,8 +272,9 @@ Section WithParams. destr fuel; cbn [device.runUntilResp]; pose proof (state_machine_read_to_device_send_read_or_later _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 E) as P; - (repeat destruct_one_match; [destruct P as (sH' & R & V) | - destruct P as (R & Decr) ..]); + (repeat destruct_one_match; subst; rewrite ? E1 in P; + [destruct P as (sH' & R & V) | + destruct P as (R & Decr) ..]); rewrite ? E in *. + (* 0 remaining fuel, device ready, valid response: *) eauto 10. @@ -321,8 +321,9 @@ Section WithParams. destr fuel; cbn [device.runUntilResp]; pose proof (state_machine_write_to_device_send_write_or_later _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5 H6 E) as P; - (repeat destruct_one_match; [destruct P as (sH' & R & V) | - destruct P as (R & Decr) ..]); + (repeat destruct_one_match; subst; rewrite ? E1 in P; + [destruct P as (sH' & R & V) | + destruct P as (R & Decr) ..]); rewrite ? E in *. + (* 0 remaining fuel, device ready, valid response: *) eauto 10. diff --git a/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v b/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v index 3cd431157..b30de8b29 100644 --- a/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v +++ b/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v @@ -1,3 +1,4 @@ +Require Import Coq.Lists.List. Require Import Coq.ZArith.ZArith. Open Scope Z_scope. Require Import riscv.Utility.Utility. Require Import coqutil.Map.Interface coqutil.Map.Properties. @@ -16,6 +17,7 @@ Require Import Cava.TLUL. Require Import Cava.Types. Require Import Cava.Util.BitArithmetic. +Import ListNotations. Section WithParameters. Instance var : tvar := denote_type. @@ -28,12 +30,21 @@ Section WithParameters. Global Instance hmac_device: device := {| device.state := denote_type (state_of hmac_top); device.is_ready_state s := True; (* FIXME *) - device.run1 s i := Semantics.step hmac_top s (i, tt); + + device.last_d2h '((_, (d2h, _)), _) := d2h; + + device.tl_inflight_ops '((_, (d2h, _)), _) := + if d_valid d2h then [d_source d2h] else []; + + device.run1 s i := fst (Semantics.step hmac_top s (i, tt)); + device.addr_range_start := TOP_EARLGREY_HMAC_BASE_ADDR; device.addr_range_pastend := TOP_EARLGREY_HMAC_BASE_ADDR + HMAC_MSG_FIFO_REG_OFFSET + HMAC_MSG_FIFO_SIZE_BYTES; - device.maxRespDelay := 1; (* FIXME *) + + device.maxRespDelay '((_, (d2h, _)), _) := + if a_ready d2h then 0%nat else 1%nat; |}. Global Instance hmac_timing: timing := { max_negative_done_polls := 16; From 587e37debafc09a17ef0c8ce3c9af04bdbcd3e1a Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 1 Dec 2021 09:49:58 +0000 Subject: [PATCH 14/16] Remove device.tl_inflight_ops --- firmware/IncrementWait/CavaIncrementDevice.v | 3 -- .../InternalMMIOMachine.v | 6 --- .../RiscvMachineWithCavaDevice/MMIOToCava.v | 43 ++++++++++++------- .../hmac/end2end/CavaHmacDevice.v | 3 -- 4 files changed, 28 insertions(+), 27 deletions(-) diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index 974f27e0a..8e0a4317f 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -57,9 +57,6 @@ Section WithParameters. device.last_d2h '((_, (_, (_, d2h))), _) := d2h; - device.tl_inflight_ops '((_, (_, (_, d2h))), _) := - if d_valid d2h then [d_source d2h] else []; - device.run1 s i := fst (Semantics.step incr s (i, tt)); device.addr_range_start := INCR_BASE_ADDR; diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index 442acb2a6..d93ae8659 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -59,12 +59,6 @@ Module device. [forall s h2d d2h s', run1 s h2d = (s', d2h) -> last_d2h s' = d2h] *) last_d2h: state -> tl_d2h; - (* indicates an inflight operation: the device received a request on channel - A, but a response on channel D hasn't been exchanged yet *) - (* TODO: probably need to add to [device_implements_state_machine] somthing like - [forall s, is_ready_state s -> tl_inflight_ops s = []] *) - tl_inflight_ops: state -> list N; - (* run one simulation step, will be instantiated with Cava.Semantics.Combinational.step *) run1: (* input: TileLink host-2-device *) state -> tl_h2d -> diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index 1d1f3e323..540d12019 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -56,14 +56,19 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte device_state_related sH sL2 []; (* for each high-level state sH from which n bytes can be read at register r, - if we run the low-level device with the read step's address on the input wires, - it either tells us to try again later (but by decreasing device.maxRespDelay, - it promises that it won't keep telling us to try again later forever), or - we will get a response matching some possible high-level read step's response, - but not necessarily the one we used to show that sH accepts reads (to allow - underspecification-nondeterminism in the high-level state machine) *) - - (* TODO: replace the length clauses with [In (a_source h2d) (device.tl_inflight_ops sL)] *) + if we run the low-level device with the read step's address in the h2d + packet, it either tells us it's not ready to receive a request, or it's + ready, but the response is not valid yet, or it's ready, and the response + is valid, matching some possible high-level read step's response, but not + necessarily the one we used to show that sH accepts reads (to allow + underspecification-nondeterminism in the high-level state machine). In the + cases were we don't get a response, we have to try again later (either + sending the message again if the device was not ready, or wait for the + response), and by decreasing device.maxRespDelay, the device promises that + it won't keep telling us to try again later forever. In the case where the + device was ready but its response is not valid yet, the new state has an + inflight message, and the waiting for the response is handled by + state_machine_read_to_device_ack_read_or_later. *) state_machine_read_to_device_send_read_or_later: forall log2_nbytes r sH sL sL' h2d, (exists v sH', state_machine.read_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL [] -> @@ -99,13 +104,21 @@ Class device_implements_state_machine{word: word.word 32}{mem: map.map word Byte device_state_related sH sL' [h2d] /\ (device.maxRespDelay sL' < device.maxRespDelay sL)%nat; - (* for each high-level state sH in which an n-byte write to register r with value v is possible, - if we run the low-level device with the write step's address and value on the input wires, - it either tells us to try again later (but by decreasing device.maxRespDelay, - it promises that it won't keep telling us to try again later forever), or - we will get an ack response and the device will end up in a state corresponding to a - high-level state reached after a high-level write, but not necessarily in the state - we used to show that sH accepts writes *) + (* for each high-level state sH in which an n-byte write to register r with + value v is possible, if we run the low-level device with the write step's + address and value in the h2d packet, it either tells us it's not ready to + receive a request, or it's ready, but the response is not valid yet, or + it's ready, and the response is valid, and the device will end up in a + state corresponding to a high-level state reached after a high-level write, + but not necessarily in the state we used to show that sH accepts writes (to + allow underspecification-nondeterminism in the high-level state machine). + In the cases were we don't get a response, we have to try again later + (either sending the message again if the device was not ready, or wait for + the response), and by decreasing device.maxRespDelay, the device promises + that it won't keep telling us to try again later forever. In the case where + the device was ready but its response is not valid yet, the new state has + an inflight message, and the waiting for the response is handled by + state_machine_write_to_device_ack_write_or_later *) state_machine_write_to_device_send_write_or_later: forall log2_nbytes r v sH sL sL' h2d, (exists sH', state_machine.write_step (2 ^ log2_nbytes) sH r v sH') -> device_state_related sH sL [] -> diff --git a/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v b/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v index b30de8b29..0c2a7331c 100644 --- a/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v +++ b/silveroak-opentitan/hmac/end2end/CavaHmacDevice.v @@ -33,9 +33,6 @@ Section WithParameters. device.last_d2h '((_, (d2h, _)), _) := d2h; - device.tl_inflight_ops '((_, (d2h, _)), _) := - if d_valid d2h then [d_source d2h] else []; - device.run1 s i := fst (Semantics.step hmac_top s (i, tt)); device.addr_range_start := TOP_EARLGREY_HMAC_BASE_ADDR; From 74a76f6508f5815c529c7b7e331ba65770f942ad Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 2 Dec 2021 09:54:37 +0000 Subject: [PATCH 15/16] Change runUntilResp to return just the new state The d2h can be retrieved by calling last_d2h. --- .../InternalMMIOMachine.v | 28 +++++++------ .../RiscvMachineWithCavaDevice/MMIOToCava.v | 42 +++++++++---------- 2 files changed, 36 insertions(+), 34 deletions(-) diff --git a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v index d93ae8659..4d57a2d7e 100644 --- a/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v +++ b/firmware/RiscvMachineWithCavaDevice/InternalMMIOMachine.v @@ -83,31 +83,34 @@ Module device. software keeps polling until the MMIO read returns a "done" response *) Definition waitForResp{D: device} := - fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := + fix rec(fuel: nat)(s: device.state): option device.state := let next := device.run1 s (set_d_ready true tl_h2d_default) in - if d_valid (device.last_d2h next) then (Some (device.last_d2h next), next) + if d_valid (device.last_d2h next) then + Some next else match fuel with - | O => (None, s) + | O => None | S fuel' => rec fuel' next end. (* returning None means out of fuel and must not happen if fuel >= device.maxRespDelay. - It is also assumed that [a_valid h2d = true] and [d_ready h2d = true]. *) + It is also assumed that [a_valid h2d = true] and [d_ready h2d = true]. + When the result is [Some res], retrieve the response d2h by calling + [device.last_d2h res]. *) Definition runUntilResp{D: device}(h2d: tl_h2d) := - fix rec(fuel: nat)(s: device.state): option tl_d2h * device.state := + fix rec(fuel: nat)(s: device.state): option device.state := let next := device.run1 s h2d in if a_ready (device.last_d2h s) then if d_valid (device.last_d2h next) then - (Some (device.last_d2h next), next) + Some next else match fuel with - | O => (None, s) + | O => None | S fuel' => waitForResp fuel' next end else match fuel with - | O => (None, s) + | O => None | S fuel' => rec fuel' next end. @@ -173,12 +176,11 @@ Section WithParams. Definition runUntilResp(h2d: tl_h2d): OState (ExtraRiscvMachine D) word := mach <- get; - let (respo, new_device_state) := - device.runUntilResp h2d (device.maxRespDelay mach.(getExtraState)) - mach.(getExtraState) in + new_device_state <- fail_if_None + (device.runUntilResp h2d (device.maxRespDelay mach.(getExtraState)) + mach.(getExtraState)); put (withExtraState new_device_state mach);; - resp <- fail_if_None respo; - Return (N_to_word (d_data resp)). + Return (N_to_word (d_data (device.last_d2h new_device_state))). Definition mmioLoad(log2_nbytes: nat)(addr: word) : OState (ExtraRiscvMachine D) (HList.tuple byte (2 ^ log2_nbytes)) := diff --git a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v index 540d12019..289ee4df7 100644 --- a/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v +++ b/firmware/RiscvMachineWithCavaDevice/MMIOToCava.v @@ -196,10 +196,10 @@ Section WithParams. device_state_related sH sL [h2d] -> a_opcode h2d = Get -> a_address h2d = word_to_N (state_machine.reg_addr r) -> - exists d2h sL' sH', - device.waitForResp (device.maxRespDelay sL) sL = (Some d2h, sL') /\ + exists sL' sH', + device.waitForResp (device.maxRespDelay sL) sL = Some sL' /\ device_state_related sH' sL' [] /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'. + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL'))) sH'. Proof. intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. @@ -216,7 +216,7 @@ Section WithParams. (destruct_one_match; [destruct P as (sH' & R & V); eauto 10 | destruct P as (R & Decl)]). + exfalso. lia. - + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); + + edestruct IHB as (sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. @@ -226,8 +226,8 @@ Section WithParams. a_opcode h2d = PutFullData -> a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> - exists d2h sL' sH', - device.waitForResp (device.maxRespDelay sL) sL = (Some d2h, sL') /\ + exists sL' sH', + device.waitForResp (device.maxRespDelay sL) sL = Some sL' /\ device_state_related sH' sL' [] /\ state_machine.write_step (2 ^ log2_nbytes) sH r v sH'. Proof. @@ -246,14 +246,14 @@ Section WithParams. (destruct_one_match; [destruct P as (sH' & R & V); eauto 10 | destruct P as (R & Decl)]). + exfalso. lia. - + edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); + + edestruct IHB as (sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. - Lemma waitForResp_mono : forall (fuel fuel' : nat) s d2h s', + Lemma waitForResp_mono : forall (fuel fuel' : nat) s s', (fuel <= fuel')%nat -> - device.waitForResp fuel s = (Some d2h, s') -> - device.waitForResp fuel' s = (Some d2h, s'). + device.waitForResp fuel s = Some s' -> + device.waitForResp fuel' s = Some s'. Proof. intros ? ?. revert fuel. induction fuel'; intros; inversion H; subst; auto. cbn [device.waitForResp]. @@ -271,10 +271,10 @@ Section WithParams. a_size h2d = N.of_nat log2_nbytes -> a_address h2d = word_to_N (state_machine.reg_addr r) -> d_ready h2d = true -> - exists d2h sL' sH', - device.runUntilResp h2d (device.maxRespDelay sL) sL = (Some d2h, sL') /\ + exists sL' sH', + device.runUntilResp h2d (device.maxRespDelay sL) sL = Some sL' /\ device_state_related sH' sL' [] /\ - state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data d2h)) sH'. + state_machine.read_step (2 ^ log2_nbytes) sH r (N_to_word (d_data (device.last_d2h sL'))) sH'. Proof. intros. remember (device.maxRespDelay sL) as fuel. remember (S fuel) as B. assert (device.maxRespDelay sL <= fuel < B)%nat as HB by lia. clear HeqB Heqfuel. @@ -299,10 +299,10 @@ Section WithParams. eauto 10. + (* some remaining fuel, device ready, no valid response: *) pose proof (state_machine_read_to_device_ack_read - _ _ _ _ _ H R H2 H4) as (d2h & sL'' & sH'' & W' & R' & V'). + _ _ _ _ _ H R H2 H4) as (sL'' & sH'' & W' & R' & V'). eapply waitForResp_mono in W'. 1: eauto 10. lia. + (* some remaining fuel, device not ready: *) - edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); + edestruct IHB as (sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. @@ -320,8 +320,8 @@ Section WithParams. a_address h2d = word_to_N (state_machine.reg_addr r) -> a_data h2d = word_to_N v -> d_ready h2d = true -> - exists ignored sL' sH', - device.runUntilResp h2d (device.maxRespDelay sL) sL = (Some ignored, sL') /\ + exists sL' sH', + device.runUntilResp h2d (device.maxRespDelay sL) sL = Some sL' /\ device_state_related sH' sL' [] /\ state_machine.write_step (2 ^ log2_nbytes) sH r v sH'. Proof. @@ -348,10 +348,10 @@ Section WithParams. clear -R V. eauto 10. + (* some remaining fuel, device ready, no valid response: *) pose proof (state_machine_write_to_device_ack_write - _ _ _ _ _ _ H R H2 H4 H5) as (d2h & sL'' & sH'' & W' & R' & V'). + _ _ _ _ _ _ H R H2 H4 H5) as (sL'' & sH'' & W' & R' & V'). eapply waitForResp_mono in W'. 1: eauto 10. lia. + (* some remaining fuel, device not ready *) - edestruct IHB as (d2h & sL'' & sH'' & Run & Rel & St); + edestruct IHB as (sL'' & sH'' & Run & Rel & St); try eassumption. 2: eauto 10. lia. Qed. @@ -549,7 +549,7 @@ Section WithParams. 1-4: match goal with | |- context[device.runUntilResp ?p _ _] => edestruct state_machine_read_to_device_read with (h2d := p) - as (v'' & d'' & s'' & RU'' & Rel'' & RS''); + as (d'' & s'' & RU'' & Rel'' & RS''); [do 2 eexists; match goal with | H: state_machine.read_step ?n _ _ _ _ |- _ => change n at 1 with (2 ^ (Nat.log2 n))%nat in H @@ -588,7 +588,7 @@ Section WithParams. 1-3: match goal with | |- context[device.runUntilResp ?p _ _] => edestruct state_machine_write_to_device_write with (h2d := p) - as (ignored & d' & s'' & RU & Rel' & WS'); + as (d' & s'' & RU & Rel' & WS'); [eexists; match goal with | H: state_machine.write_step ?n _ _ _ _ |- _ => change n at 1 with (2 ^ (Nat.log2 n))%nat in H From 72ca5040fdddeff3302ec63dff1a38801111b781 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Mon, 6 Dec 2021 10:34:39 +0000 Subject: [PATCH 16/16] Use the same repr for incr and inner --- firmware/IncrementWait/CavaIncrementDevice.v | 10 +-- firmware/IncrementWait/Incr.v | 87 +++++++++----------- 2 files changed, 45 insertions(+), 52 deletions(-) diff --git a/firmware/IncrementWait/CavaIncrementDevice.v b/firmware/IncrementWait/CavaIncrementDevice.v index 8e0a4317f..aa029cc17 100644 --- a/firmware/IncrementWait/CavaIncrementDevice.v +++ b/firmware/IncrementWait/CavaIncrementDevice.v @@ -53,7 +53,7 @@ Section WithParameters. device.state := denote_type (state_of incr); device.is_ready_state s := exists r_regs r_tl r_inner, - incr_invariant s (RSIdle, r_regs, r_tl, r_inner); + incr_invariant s (ReprIdle, r_regs, r_tl, r_inner); device.last_d2h '((_, (_, (_, d2h))), _) := d2h; @@ -72,17 +72,17 @@ Section WithParameters. Inductive counter_related_spec: IncrementWaitSemantics.state -> Incr.repr_state -> Prop := - | IDLE_related: counter_related_spec IDLE RSIdle + | IDLE_related: counter_related_spec IDLE ReprIdle | BUSY_related: forall val ncycles count, (0 < count <= 2)%nat -> (2 < ncycles + count)%nat -> - counter_related_spec (BUSY val ncycles) (RSBusy (word_to_N val) count) + counter_related_spec (BUSY val ncycles) (ReprBusy (word_to_N val) count) (* the hardware is already done, but the software hasn't polled it yet to find out, so we have to relate a software-BUSY to a hardware-done: *) | BUSY_done_related: forall val ncycles, - counter_related_spec (BUSY val ncycles) (RSDone (word_to_N (word.add (word.of_Z 1) val))) + counter_related_spec (BUSY val ncycles) (ReprDone (word_to_N (word.add (word.of_Z 1) val))) | DONE_related: forall val, - counter_related_spec (DONE val) (RSDone (word_to_N val)). + counter_related_spec (DONE val) (ReprDone (word_to_N val)). Definition counter_related {invariant : invariant_for incr repr} (sH : IncrementWaitSemantics.state) (sL : denote_type (state_of incr)) (inflight_h2ds : list tl_h2d) : Prop := diff --git a/firmware/IncrementWait/Incr.v b/firmware/IncrementWait/Incr.v index 96ee0f394..0945d1e3e 100644 --- a/firmware/IncrementWait/Incr.v +++ b/firmware/IncrementWait/Incr.v @@ -164,34 +164,34 @@ Example sample_trace := Section Spec. Local Open Scope N. - Variant inner_state := - | IISIdle - | IISBusy (data : N) (count : nat) - | IISDone (res : N). + Variant repr_state := + | ReprIdle + | ReprBusy (data : N) (count : nat) + | ReprDone (res : N). - Notation inner_repr := inner_state. + Notation inner_repr := repr_state. Global Instance inner_invariant : invariant_for inner inner_repr := fun (state : denote_type (state_of inner)) repr => let '(istate, value) := state in match repr with - | IISIdle => istate = 0 - | IISBusy data c => (0 < c <= 2)%nat /\ istate = N.of_nat c /\ value = data - | IISDone res => istate = 3 /\ value = res + | ReprIdle => istate = 0 + | ReprBusy data c => (0 < c <= 2)%nat /\ istate = N.of_nat c /\ value = data + | ReprDone res => istate = 3 /\ value = res end. Definition inner_spec_step (input : denote_type (input_of inner)) repr := let '(valid, (data, tt)) := input in match repr with - | IISIdle => if valid then IISBusy data 1 else IISIdle - | IISBusy data 2 => IISDone ((data + 1) mod 2^32) - | IISBusy data c => IISBusy data (c + 1) - | IISDone _ => IISIdle + | ReprIdle => if valid then ReprBusy data 1 else ReprIdle + | ReprBusy data 2 => ReprDone ((data + 1) mod 2^32) + | ReprBusy data c => ReprBusy data (c + 1) + | ReprDone _ => ReprIdle end. Instance inner_specification : specification_for inner inner_repr := - {| reset_repr := IISIdle; + {| reset_repr := ReprIdle; update_repr := fun (input : denote_type (input_of inner)) repr => @@ -205,7 +205,7 @@ Section Spec. (output : denote_type (output_of inner)) => let repr' := inner_spec_step input repr in match repr' with - | IISDone res => output = (true, res) + | ReprDone res => output = (true, res) | _ => exists res, output = (false, res) end; |}. @@ -251,12 +251,6 @@ Section Spec. Global Instance inner_correctness : correctness_for inner. Proof. constructor; typeclasses eauto. Defined. - - Variant repr_state := - | RSIdle - | RSBusy (data : N) (count: nat) - | RSDone (res : N). - Definition repr := (repr_state * list N * TLUL.repr_state * inner_repr)%type. Global Instance incr_invariant : invariant_for incr repr := @@ -293,16 +287,16 @@ Section Spec. end /\ inner_invariant s_inner r_inner /\ match r_state with - | RSIdle => s_busy = false /\ s_done = false - /\ r_inner = IISIdle - /\ nth 1 r_regs 0%N = 1 - | RSBusy data count => s_busy = true /\ s_done = false - /\ r_inner = IISBusy data count - /\ nth 1 r_regs 0%N = 2 - | RSDone res => s_busy = false /\ s_done = true - /\ (r_inner = IISDone res \/ r_inner = IISIdle) - /\ nth 0 r_regs 0%N = res - /\ nth 1 r_regs 0%N = 4 + | ReprIdle => s_busy = false /\ s_done = false + /\ r_inner = ReprIdle + /\ nth 1 r_regs 0%N = 1 + | ReprBusy data count => s_busy = true /\ s_done = false + /\ r_inner = ReprBusy data count + /\ nth 1 r_regs 0%N = 2 + | ReprDone res => s_busy = false /\ s_done = true + /\ (r_inner = ReprDone res \/ r_inner = ReprIdle) + /\ nth 0 r_regs 0%N = res + /\ nth 1 r_regs 0%N = 4 end /\ s_regs = r_regs /\ length r_regs = 2%nat. @@ -311,7 +305,7 @@ Section Spec. Instance incr_specification : specification_for incr repr := - {| reset_repr := (RSIdle, [0; 1], TLUL.Idle, IISIdle); + {| reset_repr := (ReprIdle, [0; 1], TLUL.Idle, ReprIdle); update_repr := fun (input : denote_type (input_of incr)) repr => @@ -342,34 +336,34 @@ Section Spec. end in let r_inner' := - let inner_input := (match r_state with RSIdle => is_write | _ => false end, + let inner_input := (match r_state with ReprIdle => is_write | _ => false end, (write_data, tt)) in update_repr (c:=inner) inner_input r_inner in let r_state' := match r_state with - | RSDone _ => - if negb (is_read && (address =? 0)) then r_state - else RSIdle + | ReprDone _ => + if (is_read && (address =? 0))%bool then ReprIdle + else r_state | _ => match r_inner' with - | IISBusy data count => RSBusy data count - | IISDone res => RSDone res + | ReprBusy data count => ReprBusy data count + | ReprDone res => ReprDone res | _ => r_state end end in let r_regs' := match r_inner' with - | IISDone res => replace 0 res r_regs + | ReprDone res => replace 0 res r_regs | _ => r_regs end in let r_regs' := match r_state' with - | RSIdle => replace 1 1 r_regs' - | RSBusy _ _ => replace 1 2 r_regs' - | RSDone _ => replace 1 4 r_regs' + | ReprIdle => replace 1 1 r_regs' + | ReprBusy _ _ => replace 1 2 r_regs' + | ReprDone _ => replace 1 4 r_regs' end in (r_state', r_regs', r_tl', r_inner'); @@ -392,7 +386,7 @@ Section Spec. postcondition (tlul_adapter_reg (reg_count:=2)) tlul_input r_tl (d2h, (is_read, (is_write, (address, (write_data, write_mask))))) - -> precondition inner (match r_state with RSIdle => is_write | _ => false end, + -> precondition inner (match r_state with ReprIdle => is_write | _ => false end, (write_data, tt)) r_inner in prec_tlul /\ prec_inner; @@ -485,13 +479,12 @@ Section Spec. boolsimpl; destruct r_state; reflexivity. + simplify_spec inner. auto. - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st; - logical_simplify; subst. - all: simplify_invariant inner. - all: try discriminate. + logical_simplify; subst; simplify_invariant inner; try discriminate. all: simplify_spec (tlul_adapter_reg (reg_count:=2)); logical_simplify; tlsimpl; subst. all: destruct a_valid; [destruct H3; subst|]; cbn in Hpostc_tl; logical_simplify; subst; cbn. all: eauto. - all: try (destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + all: destruct_tl_d2h; tlsimpl; subst. + all: try (destruct (N.land a_address 4 =? 0) eqn:Haddr; ssplit; eauto; destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). all: try (destruct count as [|[|[|]]]; [lia|..|lia]; cbn; @@ -508,7 +501,7 @@ Section Spec. all: simplify_spec (tlul_adapter_reg (reg_count:=2)); logical_simplify; tlsimpl; subst. all: destruct a_valid; [destruct H3; subst|]; cbn in Hpostc_tl; logical_simplify; subst; cbn. all: eauto. - all: try (destruct (negb (N.land a_address 4 =? 0)) eqn:Haddr; + all: try (destruct (N.land a_address 4 =? 0) eqn:Haddr; ssplit; eauto; destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity). all: try (destruct count as [|[|[|]]]; [lia|..|lia]; cbn;