Set Bullet Behavior "Strict Subproofs".
(*Clight Machine *)
(*Asm Machine*)
(** *One thread simulation*)
Module ThreadedSimulation (CC_correct: CompCert_correctness).
Existing Instance OrdinalPool.OrdinalThreadPool.
Existing Instance HybridMachineSig.HybridCoarseMachine.DilMem.
Section ThreadedSimulation.
(** *C Semantics*)
Context (C_program: Clight.program).
Definition Clight_g : Clight.genv := Clight.globalenv C_program.
Definition CSem : Semantics := ClightSemanticsForMachines.ClightSem Clight_g.
Definition Cself_simulation := clight_self_simulation Clight_g.
Definition Clight_code_inject := self_simulation.code_inject _ _ Cself_simulation.
Definition Clight_match := self_simulation.match_self Clight_code_inject.
(** *Asm Semantics*)
(*Import the Asm Hybrid Machine*)
Context (Asm_program: Asm.program).
Definition Asm_g := (@the_ge Asm_program).
Context (Asm_genv_safe: Asm_core.safe_genv (@the_ge Asm_program)).
Definition Aself_simulation := Asm_self_simulation Asm_g.
Definition Asm_code_inject := self_simulation.code_inject _ _ Aself_simulation.
Definition Asm_match := self_simulation.match_self Asm_code_inject.
(** *AsHybrid Semantics and Machine*)
Definition AsmSem : Semantics := @X86Sem Asm_program Asm_genv_safe.
(** The hybrid semantics*)
Instance HybridSem h : Semantics := CoreSem_Sum h CSem AsmSem.
Existing Instance dryResources.
Notation TP h := (threadPool.OrdinalPool.OrdinalThreadPool(Sem:=HybridSem h)).
Existing Instance DryHybridMachineSig.
Definition HybMachine h:=
HybridMachineSig.HybridCoarseMachine.HybridCoarseMachine
(ThreadPool:= TP h).
Definition HybConcSem h:=
HybridMachineSig.ConcurMachineSemantics(HybridMachine:=HybMachine h).
Notation ThreadPool n :=
(ThreadPool.t(Sem:= HybridSem n)).
(** *Extracting index and match relation from CompCert*)
Context (compiled:
CC_correct.CompCert_compiler C_program = Some Asm_program).
Definition compiler_sim:= CC_correct.simpl_clight_semantic_preservation _ _ compiled.
Definition compiler_index: Type:= Injindex compiler_sim.
Definition compiler_match (i:compiler_index) (j:meminj)
(c1:  Smallstep.state (Smallstep.part_sem (Clight.semantics2 C_program)))
(m1: mem)
(c2: Smallstep.state (Asm.part_semantics Asm_g))
(m2: mem): Prop
:= Injmatch_states compiler_sim i j
(Smallstep.set_mem c1 m1)
(Smallstep.set_mem c2 m2).
(* Compiler match that holds under interference of other threads. *)
Inductive compiler_match_padded:
compiler_index -> meminj -> Smallstep.state (Smallstep.part_sem (Clight.semantics2 C_program)) ->
mem -> Smallstep.state (Asm.part_semantics Asm_g) -> mem -> Prop
:=
| BuildCompilerMatch: forall cd j1 j2 j3 j s1 m1 s2 m2 s3 m3 s4 m4,
Clight_match j1 s1 m1 s2 m2 ->
compiler_match cd j2 s2 m2 s3 m3 ->
Asm_match j3 s3 m3 s4 m4 ->
compose_meminj (compose_meminj j1 j2) j3 = j ->
compiler_match_padded cd j s1 m1 s4 m4.
Section CompileOneThread.
Context (hb: nat).
Definition SemTop: Semantics:= (HybridSem (Some hb)).
Definition SemBot: Semantics:= (HybridSem (Some (S hb))).
Inductive match_state2match_thread
{sem1 sem2: Semantics}
(SState: @semC sem1 -> state_sum (@semC CSem) (@semC AsmSem))
(TState: @semC sem2 -> state_sum (@semC CSem) (@semC AsmSem))
(match_state : meminj -> @semC sem1 -> mem -> @semC sem2 -> mem -> Prop) :
meminj ->
@ctl (@semC SemTop) -> mem ->
@ctl (@semC SemBot) -> mem -> Prop  :=
| CThread_Running: forall j code1 m1 code2 m2,
match_state j code1 m1 code2 m2 ->
match_state2match_thread SState TState match_state j (Krun (SState code1)) m1
(Krun (TState code2)) m2
| CThread_Blocked: forall j code1 m1 code2 m2,
match_state j code1 m1 code2 m2 ->
match_state2match_thread SState TState match_state j (Kblocked (SState code1)) m1
(Kblocked (TState code2)) m2
| CThread_Resume: forall j code1 m1 code2 m2 v v',
match_state2match_thread SState TState match_state j (Kresume (SState code1) v) m1
(Kresume (TState code2) v') m2
| CThread_Init: forall j m1 m2 v1 v1' v2 v2',
Val.inject j v1 v2 ->
Val.inject j v1' v2' ->
match_state2match_thread SState TState match_state j (Kinit v1 v1') m1
(Kinit v1 v1') m2.
Definition SST := SState (@semC CSem) (@semC AsmSem).
Definition TST := TState (@semC CSem) (@semC AsmSem).
Definition match_thread_source:
meminj -> @ctl (@semC SemTop) -> mem -> @ctl (@semC SemBot) -> mem -> Prop:=
match_state2match_thread SST SST
Clight_match.
Definition match_thread_target:
meminj -> @ctl (@semC SemTop) -> mem -> @ctl (@semC SemBot) -> mem -> Prop:=
match_state2match_thread TST TST
Asm_match.
Definition match_thread_compiled cd:
meminj -> @ctl (@semC SemTop) -> mem -> @ctl (@semC SemBot) -> mem -> Prop:=
match_state2match_thread SST TST
(compiler_match_padded cd).
(* NOTE: Old version*)
(* Inductive match_thread_compiled: compiler_index -> meminj -> @ctl (@semC SemTop) -> mem -> @ctl (@semC SemBot) -> mem -> Prop  := | CThread_Running': forall cd j code1 m1 code2 m2, compiler_match cd j (Smallstep.set_mem code1 m1) (Smallstep.set_mem code2 m2) -> match_thread_compiled cd j (Krun (SState _ _ code1)) m1 (Krun (TState _ _ code2)) m2 | CThread_Blocked': forall cd j code1 m1 code2 m2, compiler_match cd j (Smallstep.set_mem code1 m1) (Smallstep.set_mem code2 m2) -> match_thread_compiled  cd j (Kblocked (SState _ _ code1)) m1 (Kblocked (TState _ _ code2)) m2 | CThread_Resume': forall cd j code1 m1 code2 m2 v v', (*Do I need to keep this two? Probanly not*)
(*semantics.at_external (CoreSem Sems) genvS code1 m1 = Some (f,ls1) -> semantics.at_external (CoreSem Semt) genvT code2 m2 = Some (f',ls2) -> Val.inject_list j ls1 ls2 -> semantics.after_external (CoreSem Sems) genvS None code1 = Some code1' -> semantics.after_external (CoreSem Semt) genvT None code2 = Some code2' -> *)
compiler_match cd j (Smallstep.set_mem code1 m1) (Smallstep.set_mem code2 m2) ->
match_thread_compiled cd j (Kresume (SState _ _ code1) v) m1
(Kresume (TState _ _ code2) v') m2
| CThread_Init': forall cd j m1 m2 v1 v1' v2 v2',
Val.inject j v1 v2 ->
Val.inject j v1' v2' ->
match_thread_compiled cd j (Kinit v1 v1') m1
(Kinit v2 v2') m2. *)
Definition merge_func {A} (f1 f2:Z -> option A):
(BinNums.Z -> option A):=
fun ofs =>
match f1 ofs with
None => f2 ofs
| _ => f1 ofs
end.
(* PTree.map: forall A B : Type, (positive -> A -> B) -> PTree.t A -> PTree.t B *)
Fixpoint build_function_for_a_block
(mu:meminj) {A} (b: positive) (ls: list (positive * (Z -> option A))):
Z -> option A:=
match ls with
| nil => (fun _ => None)
| (b0, fb)::ls' =>
match mu b0 with
| Some (b1, delt) =>
if PMap.elt_eq b b1 then
merge_func (fun p => (fb (p - delt)%Z)) (build_function_for_a_block mu b ls')
else  (build_function_for_a_block mu b ls')
| None => (build_function_for_a_block mu b ls')
end
end.
Definition tree_map_inject_over_tree {A B} (t:PTree.t (Z -> option B))(mu:meminj) (map:PTree.t (Z -> option A)):
PTree.t (Z -> option A):=
PTree.map (fun b _ => build_function_for_a_block mu b (PTree.elements map)) t.
Definition tree_map_inject_over_mem {A} m mu map:
PTree.t (Z -> option A) :=
tree_map_inject_over_tree (snd (getMaxPerm m)) mu map.
(* apply an injections to the elements of a tree. *)
Fixpoint apply_injection_elements
{A}
(mu:meminj) (ls: list (positive * (Z -> option A)))
: list (positive * (Z -> option A)) :=
match ls with
nil => nil
| cons (b, ofs_f) ls' =>
match (mu b) with
| None => apply_injection_elements mu ls'
| Some (b',d) =>
cons
(b', fun ofs => ofs_f (ofs-d)%Z)
(apply_injection_elements mu ls')
end
end.
Fixpoint extract_function_for_block
{A} (b: positive) (ls: list (positive * (Z -> option A)))
: Z -> option A :=
match ls with
nil => fun _ => None
| cons (b', ofs_f') ls' =>
if (Pos.eq_dec b b') then
merge_func ofs_f' (extract_function_for_block b ls')
else (extract_function_for_block b ls')
end.
Fixpoint map_from_list
{A:Type}
(mu:meminj) (ls: list (positive * (Z -> option A))):
PTree.t (Z -> option A) :=
match ls with
nil => @PTree.empty (BinNums.Z -> option A)
| cons (b, ofs_f) ls =>
let t:= map_from_list mu ls in
match mu b with
None => t
| Some (b',d) =>
match PTree.get b' t with
None => PTree.set b' (fun ofs => ofs_f (ofs-d)%Z) t
| Some f_old =>
PTree.set b' (merge_func (fun ofs => ofs_f (ofs-d)%Z) f_old) t
end
end
end.
Definition tree_map_inject {A}(mu:meminj) (map:PTree.t (Z -> option A)):
PTree.t (Z -> option A):=
map_from_list mu (PTree.elements map).
Definition virtueThread_inject m (mu:meminj) (virtue:delta_map * delta_map):
delta_map * delta_map:=
let (m1,m2):= virtue in
(tree_map_inject_over_mem m mu m1, tree_map_inject_over_mem m mu m2).
(* Second construct the virtueLP: the permissions transfered to the Lock pool *)
Definition access_map_inject m (mu:meminj) (map:access_map):
access_map:=
(fst map, tree_map_inject_over_mem m mu (snd map)).
Definition virtueLP_inject m (mu:meminj) (virtue:access_map * access_map):
access_map * access_map:=
(access_map_inject m mu (fst virtue), access_map_inject m mu (snd virtue)).
Record concur_match (ocd: option compiler_index)
(j:meminj) (cstate1: ThreadPool (Some hb)) (m1: Mem.mem) (cstate2: ThreadPool(Some (S hb))) (m2: mem):=
{ same_length: num_threads cstate1 = num_threads cstate2
; memcompat1: mem_compatible cstate1 m1
; memcompat2: mem_compatible cstate2 m2
; INJ: Mem.inject j m1 m2
; INJ_threads:
forall i (cnti1: containsThread cstate1 i) (cnti2: containsThread cstate2 i),
Mem.inject j
(restrPermMap (proj1 (memcompat1 i cnti1)))
(restrPermMap (proj1 (memcompat2 i cnti2)))
; INJ_locks:
forall i (cnti1: containsThread cstate1 i) (cnti2: containsThread cstate2 i),
Mem.inject j
(restrPermMap (proj2 (memcompat1 i cnti1)))
(restrPermMap (proj2 (memcompat2 i cnti2)))
; INJ_lock_content:
forall b b' delt rmap,
j b = Some (b', delt) ->
forall ofs, lockRes cstate1 (b, intval ofs) = Some rmap ->
lockRes cstate2 (b', intval (add ofs (repr delt))) =
Some (virtueLP_inject m2 j rmap)
; taret_invariant: invariant cstate2
; mtch_source:
forall (i:nat),
(i > hb)%nat ->
forall (cnti1: containsThread cstate1 i)
(cnti2: containsThread cstate2 i),
match_thread_source j
(getThreadC cnti1)
(restrPermMap (proj1 (memcompat1 i cnti1)))
(getThreadC cnti2)
(restrPermMap (proj1 (memcompat2 i cnti2)))
; mtch_target:
forall (i:nat),
(i < hb)%nat ->
forall (cnti1: containsThread cstate1 i)
(cnti2: containsThread cstate2 i),
match_thread_target  j
(getThreadC cnti1)
(restrPermMap (proj1(memcompat1 i cnti1)))
(getThreadC cnti2)
(restrPermMap (proj1(memcompat2 i cnti2)))
; mtch_compiled:
forall (i:nat),
(i = hb)%nat ->
forall (cnti1: containsThread cstate1 i)
(cnti2: containsThread cstate2 i),
exists cd, ocd = Some cd /\
match_thread_compiled cd j
(getThreadC cnti1)
(restrPermMap (proj1 (memcompat1 i cnti1)))
(getThreadC cnti2)
(restrPermMap (proj1 (memcompat2 i cnti2))) }.
Arguments memcompat1 {ocd j cstate1 m1 cstate2 m2}.
Arguments memcompat2 {ocd j cstate1 m1 cstate2 m2}.
Ltac forget_memcompat1:=
match goal with
| [ H: context[memcompat1 ?CM] |- _ ] =>
let HH:= fresh "HH" in
let Hcmpt:= fresh "Hcmpt" in
remember (memcompat1 CM) as Hcmpt eqn:HH; clear HH
| [ |-  context[memcompat1 ?CM] ] =>
let HH:= fresh "HH" in
let Hcmpt:= fresh "Hcmpt" in
remember (memcompat1 CM) as Hcmpt eqn:HH; clear HH
end.
Ltac forget_memcompat2:=
match goal with
| [ H: context[memcompat2 ?CM] |- _ ] =>
let HH:= fresh "HH" in
let Hcmpt:= fresh "Hcmpt" in
remember (memcompat2 CM) as Hcmpt eqn:HH; clear HH
| [  |- context[memcompat2 ?CM] ] =>
let HH:= fresh "HH" in
let Hcmpt:= fresh "Hcmpt" in
remember (memcompat2 CM) as Hcmpt eqn:HH; clear HH
end.
Ltac consolidate_mem_compatible:=
repeat match goal with
| [ H1: mem_compatible ?st ?m,
H2: mem_compatible ?st ?m |- _ ] =>
replace H2 with H1 in * by ( apply Axioms.proof_irr); clear H2
end.
Ltac clean_cmpt:=
try forget_memcompat1;
try forget_memcompat2;
consolidate_mem_compatible.
Ltac clean_cmpt':=
match goal with
| [ CMatch: concur_match _ _ _ _ _ _,
Hcmpt:mem_compatible ?st ?m |- _ ] =>
repeat(
match goal with
| [   |- context[Hcmpt] ] =>
replace Hcmpt with (memcompat1 CMatch)
by apply Axioms.proof_irr
| [ HH:context[Hcmpt]  |- _ ] =>
replace Hcmpt with (memcompat1 CMatch) in HH
by apply Axioms.proof_irr
end)
end.

Lemma concur_match_perm_restrict:
forall cd j st1 m1 st2 m2,
concur_match cd j st1 m1 st2 m2 ->
forall perms1 perms2 (permMapLt1: permMapLt perms1 (getMaxPerm m1))
(permMapLt2: permMapLt perms2 (getMaxPerm m2)),
concur_match cd j st1 (restrPermMap permMapLt1) st2 (restrPermMap permMapLt2).