(** * Transforming a semantics into a single-event, equivalent semantics *)
Definition well_behaved_traces (L: semantics) : Prop :=
forall s t s', Step L s t s' ->
match t with nil => True | ev :: t' => output_trace t' end.
Section ATOMIC.
Variable L: semantics.
Hypothesis Lwb: well_behaved_traces L.
Inductive atomic_step : (trace * state L) -> trace -> (trace * state L) -> Prop :=
| atomic_step_silent: forall s s',
Step L s E0 s' ->
atomic_step (E0, s) E0 (E0, s')
| atomic_step_start: forall s ev t s',
Step L s (ev :: t) s' ->
atomic_step (E0, s) (ev :: nil) (t, s')
| atomic_step_continue: forall ev t s,
output_trace (ev :: t) ->
atomic_step (ev :: t, s) (ev :: nil) (t, s).
Definition part_atomic : part_semantics := {|
state := (trace * state L)%type;
get_mem := fun s => get_mem (snd s) ;
set_mem := fun s m => (fst s, set_mem (snd s) m);
genvtype := genvtype L;
step := atomic_step;
start_stack := fun m0 s f args => start_stack L m0 (snd s) f args /\ fst s = E0;
at_external := fun s => at_external _ (snd s) ;
after_external := fun ret s m => option_map (fun x => (fst s, x)) (after_external _ ret (snd s) m);
final_state := fun s r => final_state L (snd s) r /\ fst s = E0;
globalenv := globalenv L;
symbolenv := symbolenv L
|}.
Definition atomic : semantics := {|
part_sem := part_atomic;
main_block := main_block L;
init_mem := init_mem L;
|}.
End ATOMIC.
(** A forward simulation from a semantics [L1] to a single-event semantics [L2] can be "factored" into a forward simulation from [atomic L1] to [L2]. *)
Section FACTOR_FORWARD_SIMULATION.
Variable L1: semantics.
Variable L2: semantics.
Context index order match_states (sim: fsim_properties L1 L2 index order match_states).
Hypothesis L2single: single_events L2.
Inductive ffs_match: index -> (trace * state L1) -> state L2 -> Prop :=
| ffs_match_at: forall i s1 s2,
match_states i s1 s2 ->
ffs_match i (E0, s1) s2
| ffs_match_buffer: forall i ev t s1 s2 s2',
Star L2 s2 (ev :: t) s2' -> match_states i s1 s2' ->
ffs_match i (ev :: t, s1) s2.

Lemma star_non_E0_split':
forall s2 t s2', Star L2 s2 t s2' ->
match t with
| nil => True
| ev :: t' => exists s2x, Plus L2 s2 (ev :: nil) s2x /\ Star L2 s2x t' s2'
end.