End MemObsEq.
Module CoreInjections.
Section CoreInjections.
Context {Sem : Semantics}.
Class CoreInj :=
{ (** Pointers in the core are well-defined *)
core_wd : memren -> semC -> Prop;
(** Pointers in the global env are well-defined *)
ge_wd : memren -> semG -> Prop;
ge_wd_incr: forall f f' (g : semG),
ge_wd f g ->
ren_domain_incr f f' ->
ge_wd f' g;
ge_wd_domain : forall f f' m (g : semG),
ge_wd f g ->
domain_memren f m ->
domain_memren f' m ->
ge_wd f' g;
core_wd_incr : forall f f' c,
core_wd f c ->
ren_domain_incr f f' ->
core_wd f' c;
core_wd_domain : forall f f' m c,
core_wd f c ->
domain_memren f m ->
domain_memren f' m ->
core_wd f' c;
at_external_wd:
forall m (f : memren) c
(ef : external_function)
(args : seq val),
valid_mem m ->
domain_memren f m ->
core_wd f c ->
at_external semSem c m = Some (ef, args) ->
valid_val_list f args;
after_external_wd:
forall m (c c' : semC) (f : memren) (ef : external_function)
(args : seq val) (ov : option val)
(Hat_external: at_external semSem c m = Some (ef, args))
(Hcore_wd: core_wd f c)
(Hvalid_list: valid_val_list f args)
(Hafter_external: after_external semSem ov c m = Some c')
(Hov: match ov with
| Some v => valid_val f v
| None => True
end),
core_wd f c';
(*LENB: modified to account for the fact that a stack block is allocated. Cf the similarly modified core_inj_init later in this file initial_core_wd: forall the_ge m (f : memren) (vf arg : val) (c_new : C) om h, valid_mem m -> domain_memren f m -> initial_core SEM h the_ge m vf [:: arg] = Some (c_new, om) -> valid_val f arg -> ge_wd f the_ge -> core_wd f c_new.*)
initial_core_wd :
forall m m' (f fg : memren) (vf : val) args (c_new:semC) h,
valid_mem m ->
domain_memren f m ->
initial_core semSem h m c_new m' vf args ->
valid_val_list f args ->
ge_wd fg the_ge ->
ren_domain_incr fg f ->
valid_mem m' /\
(exists f', ren_domain_incr f f' /\ domain_memren f' m') /\
forall f', domain_memren f' m' ->
core_wd f' c_new;
(** Renamings on cores *)
core_inj: memren -> semC -> semC -> Prop;
core_inj_ext:
forall m m' c c' (f fg : memren)
(Hfg: (forall b1 b2, fg b1 = Some b2 -> b1 = b2))
(Hge_wd: ge_wd fg the_ge)
(Hincr: ren_incr fg f),
valid_mem m ->
(* domain_memren f m -> *)
core_inj f c c' ->
mem_obs_eq f m m' ->
match at_external semSem c m with
| Some (ef, vs) =>
match at_external semSem c' m' with
| Some (ef', vs') =>
ef = ef' /\ val_obs_list f vs vs'
| None => False
end
| None =>
match at_external semSem c' m' with
| Some _ => False
| None => True
end
end;
(* This is not quite right.  Instead of letting ov1 freely float Some/None, it should be determined by the return type of the signature for the external function *)
(* Nick: There was no signature back when I wrote this, but it doesn't matter, this only specifies that they will have similar return values, not what the return value is *)
core_inj_after_ext:
forall c cc c' (ov1 : option val) m m'
(f fg : memren)
(Hfg: (forall b1 b2, fg b1 = Some b2 -> b1 = b2))
(Hge_wd: ge_wd fg the_ge)
(Hincr: ren_incr fg f),
core_inj f c c' ->
mem_obs_eq f m m' ->
match ov1 with
| Some v1 => valid_val f v1
| None => True
end ->
after_external semSem ov1 c m = Some cc ->
exists (ov2 : option val) (cc' : semC),
after_external semSem ov2 c' m' = Some cc' /\
core_inj f cc cc' /\
match ov1 with
| Some v1 =>
match ov2 with
| Some v2 => val_obs f v1 v2
| None => False
end
| None => match ov2 with
| Some _ => False
| None => True
end
end;
core_inj_halted:
forall c c' f (Hinj: core_inj f c c') v,
halted semSem c v <-> halted semSem c' v;
core_inj_init:
forall m1 m1' m2 vf vf' arg arg' c_new f fg h
(Hge_wd: ge_wd fg the_ge)
(Hfg: (forall b1 b2, fg b1 = Some b2 -> b1 = b2))
(Hincr: ren_incr fg f)
(Harg: val_obs_list f arg arg')
(Hvf: val_obs f vf vf')
(Hmem: mem_obs_eq f m1 m1')
(Hinit: initial_core semSem h m1 c_new m2 vf arg),
(* (Hf: forall b b', f b = Some b' -> Mem.valid_block m b), *)
exists c_new' m2' f',
initial_core semSem h m1' c_new' m2' vf' arg'
/\ core_inj f' c_new c_new'
/\ mem_obs_eq f' m2 m2'
/\ ren_incr f f'
/\ ren_separated f f' m1 m1'
/\ ((exists p, ((Mem.nextblock m2 = Mem.nextblock m1 + p)%positive /\
(Mem.nextblock m2' = Mem.nextblock m1' + p)%positive)))
/\ (forall b,
Mem.valid_block m2' b ->
~ Mem.valid_block m1' b ->
let bz := ((Zpos b) - ((Zpos (Mem.nextblock m1')) -
(Zpos (Mem.nextblock m1))))%Z in
f' (Z.to_pos bz) = Some b /\
f (Z.to_pos bz) = None)
/\ (Mem.nextblock m1 = Mem.nextblock m1' ->
(forall b1 b2, f b1 = Some b2 -> b1 = b2) ->
forall b1 b2, f' b1 = Some b2 -> b1 = b2)
/\ (forall b2, (~exists b1, f' b1 = Some b2) ->
forall ofs, permission_at m1' b2 ofs Cur = permission_at m2' b2 ofs Cur);
core_inj_id: forall c f,
core_wd f c ->
(forall b1 b2, f b1 = Some b2 -> b1 = b2) ->
core_inj f c c;
core_inj_trans:
forall c c' c'' (f f' f'' : memren)
(Hcore_inj: core_inj f c c'')
(Hcore_inj': core_inj f' c c')
(Hf: forall b b' b'',
f b = Some b'' ->
f' b = Some b' ->
f'' b' = Some b''),
core_inj f'' c' c'';
corestep_obs_eq:
forall cc cf cc' mc mf mc' f fg
(Hobs_eq: mem_obs_eq f mc mf)
(Hcode_eq: core_inj f cc cf)
(Hfg: (forall b1 b2, fg b1 = Some b2 -> b1 = b2))
(Hge_wd: ge_wd fg the_ge)
(Hincr: ren_incr fg f)
(Hstep: corestep semSem cc mc cc' mc'),
exists cf' mf' f',
corestep semSem cf mf cf' mf'
/\ core_inj f' cc' cf'
/\ mem_obs_eq f' mc' mf'
/\ ren_incr f f'
/\ ren_separated f f' mc mf
/\ ((exists p, ((Mem.nextblock mc' = Mem.nextblock mc + p)%positive /\
(Mem.nextblock mf' = Mem.nextblock mf + p)%positive))
\/ ((Mem.nextblock mc' = Mem.nextblock mc) /\
(Mem.nextblock mf' = Mem.nextblock mf)))
/\ (forall b,
Mem.valid_block mf' b ->
~ Mem.valid_block mf b ->
let bz := ((Zpos b) - ((Zpos (Mem.nextblock mf)) -
(Zpos (Mem.nextblock mc))))%Z in
f' (Z.to_pos bz) = Some b /\
f (Z.to_pos bz) = None)
/\ (Mem.nextblock mc = Mem.nextblock mf ->
(forall b1 b2, f b1 = Some b2 -> b1 = b2) ->
forall b1 b2, f' b1 = Some b2 -> b1 = b2)
/\ (forall b2, (~exists b1, f' b1 = Some b2) ->
forall ofs, permission_at mf b2 ofs Cur = permission_at mf' b2 ofs Cur);
(* Starting from a wd state, we get a new valid memory and the fact that there exists some renaming whose domain is the same as the new memory and additionally that the new core is well defined with respect to all renamings with the same domain.  Note that we cannot say anything about the codomain, i.e. that f' is an extension of f.*)
corestep_wd:
forall c m c' m' f fg
(Hwd: core_wd f c)
(Hmem_wd: valid_mem m)
(Hge_wd: ge_wd fg the_ge)
(Hincr: ren_domain_incr fg f)
(Hdomain: domain_memren f m)
(Hcorestep: corestep semSem c m c' m'),
valid_mem m' /\
(exists f', ren_domain_incr f f' /\ domain_memren f' m') /\
forall f', domain_memren f' m' ->
core_wd f' c'
}.
End CoreInjections.
End CoreInjections.
Module ThreadPoolInjections.
Section ThreadPoolInjections.
Existing Instance dryResources.
Context {asmSem : Semantics}
{tpool : ThreadPool.ThreadPool}
{CI: CoreInj}.
(** Renamings on Thread Pools *)
(*not clear what should happen with vf. Normally it should be in the genv and hence should be mapped to itself, but let's not expose this here, this seems to have changed.*)
Definition ctl_inj f cc cf : Prop :=
match cc, cf with
| Kinit vf arg, Kinit vf' arg' =>
val_obs f vf vf' /\ val_obs f arg arg'
| Krun c, Krun c' => core_inj f c c'
| Kblocked c, Kblocked c' => core_inj f c c'
| Kresume c arg, Kresume c' arg' => core_inj f c c' /\ val_obs f arg arg'
| _, _  => False
end.
(*Again we do not require that the first argument to Kinit is valid as we never map it, although maybe we should, seems to have changed as well..*)
Definition ctl_wd f t : Prop :=
match t with
| Krun c => core_wd f c
| Kblocked c => core_wd f c
| Kresume c v => core_wd f c /\ valid_val f v
| Kinit vf v => valid_val f vf /\ valid_val f v
end.

(* Specifications: *)
Lemma ctl_wd_incr : forall f f' c,
ctl_wd f c ->
ren_domain_incr f f' ->
ctl_wd f' c.
Lemma ctl_inj_trans:
forall c c' c'' (f f' f'' : memren)
(Hcore_inj: ctl_inj f c c'')
(Hcore_inj': ctl_inj f' c c')
(Hf: forall b b' b'',
f b = Some b'' ->
f' b = Some b' ->
f'' b' = Some b''),
ctl_inj f'' c' c''.