Library Apps.TickGenerator
Require Import Coq.Program.Basics Coq.NArith.NArith Coq.Lists.List.
Require Import FunctionApp TrustedTickBox.
Set Implicit Arguments.
Local Open Scope list_scope.
Local Open Scope program_scope.
Section tickG.
Context (world : Type).
Inductive tickGInput :=
| TGWakeUp
| TGClocksGot (nanoseconds : N)
| TGWantWakeupIn (ticks : N).
Definition nanos_per_tick := 1%N.
Open Scope N_scope.
Inductive GatewayPreState :=
| Init
| WaitingToWake
| WaitingToSleep.
Record GatewayState :=
{ systemTime : option N;
nextWakeUpTime : option N;
waitingOn : GatewayPreState }.
Definition set_waitingOn (st : GatewayState) (v : GatewayPreState) : GatewayState
:= {| systemTime := st.(systemTime);
nextWakeUpTime := st.(nextWakeUpTime);
waitingOn := v |}.
Inductive tickGWarningOutput :=
| TGDebugStateTransition (from to : GatewayState) (ev : tickGInput).
Inductive tickGEventOutput :=
| TGGetNanosecs
| TGTick (_ : N)
| TGSystemSleep (nanoseconds : N).
Definition tickGOutput := (tickGWarningOutput + tickGEventOutput)%type.
Require Import FunctionApp TrustedTickBox.
Set Implicit Arguments.
Local Open Scope list_scope.
Local Open Scope program_scope.
Section tickG.
Context (world : Type).
Inductive tickGInput :=
| TGWakeUp
| TGClocksGot (nanoseconds : N)
| TGWantWakeupIn (ticks : N).
Definition nanos_per_tick := 1%N.
Open Scope N_scope.
Inductive GatewayPreState :=
| Init
| WaitingToWake
| WaitingToSleep.
Record GatewayState :=
{ systemTime : option N;
nextWakeUpTime : option N;
waitingOn : GatewayPreState }.
Definition set_waitingOn (st : GatewayState) (v : GatewayPreState) : GatewayState
:= {| systemTime := st.(systemTime);
nextWakeUpTime := st.(nextWakeUpTime);
waitingOn := v |}.
Inductive tickGWarningOutput :=
| TGDebugStateTransition (from to : GatewayState) (ev : tickGInput).
Inductive tickGEventOutput :=
| TGGetNanosecs
| TGTick (_ : N)
| TGSystemSleep (nanoseconds : N).
Definition tickGOutput := (tickGWarningOutput + tickGEventOutput)%type.
In practice, computations can take around 0.3 milliseconds. So
if we are asked to sleep for less than 5 milliseconds, then we
should instead sleep for 1 nanosecond, so we don't have to wait
for a getClockMonotonic callback.
Definition tickStarvationBoundary := 500000%N.
Definition tickGLoopPreBody' (st : GatewayState) : tickGInput → (list tickGOutput) × GatewayState :=
fun i ⇒
match i, st.(waitingOn) with
| TGWakeUp, _ ⇒
(inr TGGetNanosecs :: nil, set_waitingOn st WaitingToWake)
| TGClocksGot new, Init ⇒
(nil, {| systemTime := Some new ; nextWakeUpTime := st.(nextWakeUpTime) ; waitingOn := Init |})
| TGClocksGot new, WaitingToWake ⇒
let actions :=
match st.(systemTime) with
| Some prev ⇒
let ticks := (new - prev) / nanos_per_tick in
inr (TGTick ticks) :: nil
| None ⇒ nil
end in
(actions, {| systemTime := Some new ; nextWakeUpTime := None ; waitingOn := Init |})
| TGClocksGot new, WaitingToSleep ⇒
match st.(systemTime), st.(nextWakeUpTime) with
| Some prev, Some nanos
⇒ let diff := new - prev in
let new_nanos := nanos - diff in
if new_nanos =? 0
then (inr (TGTick (diff / nanos_per_tick)) :: nil,
{| systemTime := Some new ; nextWakeUpTime := None ; waitingOn := Init |})
else (inr (TGSystemSleep new_nanos) :: nil,
{| systemTime := Some new ; nextWakeUpTime := Some new_nanos ; waitingOn := Init |})
| Some prev, None
⇒ (inr (TGSystemSleep 0) :: nil, {| systemTime := Some new ; nextWakeUpTime := Some 0 ; waitingOn := Init |})
| None, _
⇒ (inr (TGSystemSleep 0) :: nil, {| systemTime := Some new ; nextWakeUpTime := Some 0 ; waitingOn := Init |})
end
| TGWantWakeupIn ticks, _
⇒ let nanos := ticks × nanos_per_tick in
if nanos <? tickStarvationBoundary
then (inr (TGSystemSleep 1) :: nil, st)
else match st.(nextWakeUpTime) with
| None
⇒ (inr TGGetNanosecs :: nil,
{| systemTime := st.(systemTime) ; nextWakeUpTime := Some nanos ; waitingOn := WaitingToSleep |})
| Some nextWake
⇒ if nanos <? nextWake
then (inr TGGetNanosecs :: nil,
{| systemTime := st.(systemTime) ; nextWakeUpTime := Some nanos ; waitingOn := WaitingToSleep |})
else (nil, st)
end
end.
Definition tickGLoopPreBody
(st : GatewayState)
: tickGInput → (list tickGOutput) × GatewayState
:= fun i ⇒
let (a, st') := tickGLoopPreBody' st i in
((inl (TGDebugStateTransition st st' i))::a, st').
Context (handle : tickGOutput → action world).
Definition tickGLoopBody {T}
(loop : GatewayState → T)
(st : GatewayState)
: tickGInput → action world × T
:= fun i ⇒ let outputs := fst (tickGLoopPreBody st i) in
let st' := snd (tickGLoopPreBody st i) in
(fold_left compose (map handle outputs) id,
loop st').
CoFixpoint tickGLoop (st : GatewayState) :=
Step (tickGLoopBody tickGLoop st).
Definition tickGInitState : GatewayState := {| systemTime := None ; nextWakeUpTime := None ; waitingOn := Init |}.
Definition tickG := tickGLoop tickGInitState.
End tickG.