Commit 383206b7 authored by Hai Dang's avatar Hai Dang

Merge branch 'retag_sem'

parents 1a11cc73 4865b710
......@@ -182,82 +182,59 @@ Definition unsafe_action
Section blah.
Context {A: Type}.
Equations visit_freeze_sensitive'
(h: mem) (l: loc) (f: A loc nat bool option A)
(l: loc) (f: A loc nat bool option A)
(a: A) (last cur_dist: nat) (T: type) : option (A * (nat * nat)) :=
visit_freeze_sensitive' h l f a last cur_dist (FixedSize n) :=
visit_freeze_sensitive' l f a last cur_dist (FixedSize n) :=
(* consider frozen, simply extend the distant by n *)
Some (a, (last, cur_dist + n)%nat) ;
visit_freeze_sensitive' h l f a last cur_dist (Reference _ _) :=
visit_freeze_sensitive' l f a last cur_dist (Reference _ _) :=
(* consider frozen, extend the distant by 1 *)
Some (a, (last, S cur_dist)) ;
visit_freeze_sensitive' h l f a last cur_dist (Unsafe T) :=
visit_freeze_sensitive' l f a last cur_dist (Unsafe T) :=
(* reach an UnsafeCell, apply the action `f` and return new `last` and
`cur_dist` *)
unsafe_action f a l last cur_dist (tsize T) ;
visit_freeze_sensitive' h l f a last cur_dist (Union Ts) :=
visit_freeze_sensitive' l f a last cur_dist (Union Ts) :=
(* If it's a union, look at the type to see if there is UnsafeCell *)
if is_freeze (Union Ts)
(* No UnsafeCell, consider the whole block frozen and simply extend the
distant. *)
then Some (a, (last, cur_dist + (tsize (Union Ts)))%nat)
(* There can be UnsafeCell, consider the whole block unfrozen and perform
`f a _ _ false` on the whole block. `unsafe_action` will return the
offsets for the following visit. *)
(* There can be UnsafeCell, consider the whole block of [Union Ts]
unfrozen and perform `f a _ _ false` on the whole block.
`unsafe_action` will return the offsets for the following visit. *)
else unsafe_action f a l last cur_dist (tsize (Union Ts)) ;
visit_freeze_sensitive' h l f a last cur_dist (Product Ts) :=
visit_freeze_sensitive' l f a last cur_dist (Product Ts) :=
(* Try a shortcut *)
if is_freeze (Product Ts)
(* No UnsafeCell, consider the whole block frozen and simply extend the
distant. *)
then Some (a, (last, cur_dist + (tsize (Product Ts)))%nat)
(* This implements left-to-right search on the type, which guarantees
(* Perform a left-to-right search on [Product Ts], which guarantees
that the offsets are increasing. *)
else visit_LR a last cur_dist Ts
where visit_LR (a: A) (last cur_dist: nat) (Ts: list type)
: option (A * (nat * nat)) :=
{ visit_LR a last cur_dist [] := Some (a, (last, cur_dist)) ;
visit_LR a last cur_dist (T' :: Ts') :=
alc visit_freeze_sensitive' h l f a last cur_dist T' ;
alc visit_freeze_sensitive' l f a last cur_dist T' ;
visit_LR alc.1 alc.2.1 alc.2.2 Ts' } ;
visit_freeze_sensitive' h l f a last cur_dist (Sum Ts) :=
visit_freeze_sensitive' l f a last cur_dist (Sum Ts) :=
(* Try a shortcut *)
if is_freeze (Sum Ts)
(* No UnsafeCell, consider the whole block frozen and simply extend the
distant. *)
then Some (a, (last, cur_dist + (tsize (Sum Ts)))%nat)
else
match h !! (l + (last + cur_dist)) with
(* This looks up the current state to see which discriminant currently
is active (which is an integer) and redirect the visit for the type
of that discriminant. Note that this consitutes a read-access, and
should adhere to the access checks. But we are skipping them here.
FIXME *)
| Some (ScInt i) =>
if decide (O i)
then (* the discriminant is well-defined, visit with the
corresponding type *)
alc visit_lookup Ts (Z.to_nat i) ;
(* Anything in the padding is considered frozen and will be
applied with the action by the following visit.
`should_offset` presents the offset that the visit SHOULD
arrive at after the visit. If there are padding bytes left,
they will be added to the cur_dist. *)
let should_offset := (last + cur_dist + tsize (Sum Ts))%nat in
Some (alc.1, (alc.2.1, (should_offset - alc.2.1)%nat))
else None
| _ => None
end
where visit_lookup (Ts: list type) (i: nat) : option (A * (nat * nat)) :=
{ visit_lookup [] _ := None ;
visit_lookup (T :: _) O :=
visit_freeze_sensitive' h l f a last (S cur_dist) T ;
visit_lookup (T :: Ts) (S i) := visit_lookup Ts i }
(* There can be UnsafeCell, consider the whole block of [Sum Ts] unfrozen
and perform `f a _ _ false` on the whole block. `unsafe_action` will
return the offsets for the following visit. *)
else unsafe_action f a l last cur_dist (tsize (Sum Ts))
.
End blah.
Definition visit_freeze_sensitive {A: Type}
h (l: loc) (T: type) (f: A loc nat bool option A) (a: A) : option A :=
match visit_freeze_sensitive' h l f a O O T with
(l: loc) (T: type) (f: A loc nat bool option A) (a: A) : option A :=
match visit_freeze_sensitive' l f a O O T with
| Some (a', (last', cur_dist')) =>
(* the last block is frozen *)
f a' (l + last') cur_dist' true
......@@ -310,13 +287,13 @@ Definition reborrowN α cids l n old_tag new_tag pm prot :=
(* This implements EvalContextPrivExt::reborrow *)
(* TODO?: alloc.check_bounds(this, ptr, size)?; *)
Definition reborrow h α cids l (old_tag: tag) T (kind: ref_kind)
Definition reborrow α cids l (old_tag: tag) T (kind: ref_kind)
(new_tag: tag) (protector: option call_id) :=
match kind with
| SharedRef | RawRef false =>
(* for shared refs and const raw pointer, treat Unsafe as SharedReadWrite
and Freeze as SharedReadOnly *)
visit_freeze_sensitive h l T
visit_freeze_sensitive l T
(λ α' l' sz frozen,
(* If is in Unsafe, use SharedReadWrite, otherwise SharedReadOnly *)
let perm := if frozen then SharedReadOnly else SharedReadWrite in
......@@ -331,11 +308,12 @@ Definition reborrow h α cids l (old_tag: tag) T (kind: ref_kind)
(* Retag one pointer *)
(* This implements EvalContextPrivExt::retag_reference *)
Definition retag_ref h α cids (nxtp: ptr_id) l (old_tag: tag) T
Definition retag_ref α cids (nxtp: ptr_id) l (old_tag: tag) T
(kind: ref_kind) (protector: option call_id)
: option (tag * stacks * ptr_id) :=
match tsize T with
| O => (* Nothing to do for zero-sized types *)
(* TODO: this can be handled by reborrow *)
Some (old_tag, α, nxtp)
| _ =>
let new_tag := match kind with
......@@ -343,65 +321,37 @@ Definition retag_ref h α cids (nxtp: ptr_id) l (old_tag: tag) T
| _ => Tagged nxtp
end in
(* reborrow old_tag with new_tag *)
α' reborrow h α cids l old_tag T kind new_tag protector;
α' reborrow α cids l old_tag T kind new_tag protector;
Some (new_tag, α', S nxtp)
end.
Definition adding_protector (kind: retag_kind) (c: call_id) : option call_id :=
match kind with FnEntry => Some c | _ => None end.
(* This implements EvalContextExt::retag *)
(* This *partly* implements EvalContextExt::retag *)
(* Assumption: ct cids *)
Equations retag
(h: mem) α (nxtp: ptr_id) (cids: call_id_stack) (ct: call_id) (x: loc) (kind: retag_kind) T :
option (mem * stacks * ptr_id) :=
retag h α nxtp cids ct x kind (FixedSize _) := Some (h, α, nxtp) ;
retag h α nxtp cids ct x kind (Union _) := Some (h, α, nxtp) ;
retag h α nxtp cids ct x kind (Unsafe T) := retag h α nxtp cids ct x kind T ;
retag h α nxtp cids ct x kind (Reference pk Tr) with h !! x :=
{ | Some (ScPtr l otag) :=
let qualify : option (ref_kind * option call_id) :=
match pk, kind with
(* Mutable reference *)
| RefPtr Mutable, _ =>
Some (UniqueRef (is_two_phase kind), adding_protector kind ct)
(* Immutable reference *)
| RefPtr Immutable, _ => Some (SharedRef, adding_protector kind ct)
(* If is both raw ptr and Raw retagging, no protector *)
| RawPtr mut, RawRt => Some (RawRef (bool_decide (mut = Mutable)), None)
(* Box pointer, no protector *)
| BoxPtr, _ => Some (UniqueRef false, None)
(* Ignore Raw pointer otherwise *)
| RawPtr _, _ => None
end in
match qualify with
| Some (rkind, protector) =>
bac retag_ref h α cids nxtp l otag Tr rkind protector ;
Some (<[x := ScPtr l bac.1.1]>h, bac.1.2, bac.2)
| None => Some (h, α, nxtp)
end ;
| _ := None } ;
retag h α nxtp cids ct x kind (Product Ts) := visit_LR h α nxtp x Ts
(* left-to-right visit to retag *)
where visit_LR h α (nxtp: ptr_id) (x: loc) (Ts: list type)
: option (mem * stacks * ptr_id) :=
{ visit_LR h α nxtp x [] := Some (h, α, nxtp) ;
visit_LR h α nxtp x (T :: Ts) :=
hac retag h α nxtp cids ct x kind T ;
visit_LR hac.1.1 hac.1.2 hac.2 (x + (tsize T)) Ts } ;
retag h α nxtp cids ct x kind (Sum Ts) with h !! x :=
{ | Some (ScInt i) :=
if decide (O i < length Ts)
then (* the discriminant is well-defined, visit with the
corresponding type *)
visit_lookup Ts (Z.to_nat i)
else None
where visit_lookup (Ts: list type) (i: nat) : option (mem * stacks * ptr_id) :=
{ visit_lookup [] i := None ;
visit_lookup (T :: Ts) O := retag h α nxtp cids ct (x + 1) kind T ;
visit_lookup (T :: Ts) (S i) := visit_lookup Ts i } ;
| _ := None }
.
Definition retag α (nxtp: ptr_id) (cids: call_id_stack) (ct: call_id)
(l: loc) (otag: tag) (kind: retag_kind) pk Tr :
option (tag * stacks * ptr_id) :=
let qualify : option (ref_kind * option call_id) :=
match pk, kind with
(* Mutable reference *)
| RefPtr Mutable, _ =>
Some (UniqueRef (is_two_phase kind), adding_protector kind ct)
(* Immutable reference *)
| RefPtr Immutable, _ => Some (SharedRef, adding_protector kind ct)
(* If is both raw ptr and Raw retagging, no protector *)
| RawPtr mut, RawRt => Some (RawRef (bool_decide (mut = Mutable)), None)
(* Box pointer, no protector *)
| BoxPtr, _ => Some (UniqueRef false, None)
(* Ignore Raw pointer otherwise *)
| RawPtr _, _ => None
end in
match qualify with
| Some (rkind, protector) => retag_ref α cids nxtp l otag Tr rkind protector
| None => Some (otag, α, nxtp)
end
.
Definition tag_included (tg: tag) (nxtp: ptr_id) : Prop :=
match tg with
......@@ -415,39 +365,39 @@ Infix "<<t" := tag_values_included (at level 60, no associativity).
(** Instrumented step for the stacked borrows *)
(* This ignores CAS for now. *)
Inductive bor_step h α (cids: call_id_stack) (nxtp: ptr_id) (nxtc: call_id):
event mem stacks call_id_stack ptr_id call_id Prop :=
Inductive bor_step α (cids: call_id_stack) (nxtp: ptr_id) (nxtc: call_id):
event stacks call_id_stack ptr_id call_id Prop :=
(* | SysCallIS id :
bor_step h α β nxtp (SysCallEvt id) h α β nxtp *)
(* This implements EvalContextExt::new_allocation. *)
| AllocIS x T :
(* Tagged nxtp is the first borrow of the variable x,
used when accessing x directly (not through another pointer) *)
bor_step h α cids nxtp nxtc
(AllocEvt x (Tagged nxtp) T) h
bor_step α cids nxtp nxtc
(AllocEvt x (Tagged nxtp) T)
(init_stacks α x (tsize T) (Tagged nxtp)) cids (S nxtp) nxtc
(* This implements AllocationExtra::memory_read. *)
| CopyIS α' l lbor T vl
(ACC: memory_read α cids l lbor (tsize T) = Some α')
(* This comes from wellformedness, but for convenience we require it here *)
(BOR: vl <<t nxtp):
bor_step h α cids nxtp nxtc (CopyEvt l lbor T vl) h α' cids nxtp nxtc
bor_step α cids nxtp nxtc (CopyEvt l lbor T vl) α' cids nxtp nxtc
(* This implements AllocationExtra::memory_written. *)
| WriteIS α' l lbor T vl
(ACC: memory_written α cids l lbor (tsize T) = Some α')
(* This comes from wellformedness, but for convenience we require it here *)
(BOR: vl <<t nxtp) :
bor_step h α cids nxtp nxtc (WriteEvt l lbor T vl) h α' cids nxtp nxtc
bor_step α cids nxtp nxtc (WriteEvt l lbor T vl) α' cids nxtp nxtc
(* This implements AllocationExtra::memory_deallocated. *)
| DeallocIS α' l lbor T
(ACC: memory_deallocated α cids l lbor (tsize T) = Some α') :
bor_step h α cids nxtp nxtc (DeallocEvt l lbor T) h α' cids nxtp nxtc
bor_step α cids nxtp nxtc (DeallocEvt l lbor T) α' cids nxtp nxtc
| InitCallIS :
bor_step h α cids nxtp nxtc (InitCallEvt nxtc) h α (nxtc :: cids) nxtp (S nxtc)
bor_step α cids nxtp nxtc (InitCallEvt nxtc) α (nxtc :: cids) nxtp (S nxtc)
| EndCallIS c cids' v
(TOP: cids = c :: cids') :
bor_step h α cids nxtp nxtc (EndCallEvt c v) h α cids' nxtp nxtc
| RetagIS h' α' nxtp' x T kind c cids'
bor_step α cids nxtp nxtc (EndCallEvt c v) α cids' nxtp nxtc
| RetagIS α' nxtp' l otag ntag T kind pkind c cids'
(TOP: cids = c :: cids')
(RETAG: retag h α nxtp cids c x kind T = Some (h', α', nxtp')) :
bor_step h α cids nxtp nxtc (RetagEvt x T kind) h' α' cids nxtp' nxtc.
(RETAG: retag α nxtp cids c l otag kind pkind T = Some (ntag, α', nxtp')) :
bor_step α cids nxtp nxtc (RetagEvt l otag ntag pkind T kind) α' cids nxtp' nxtc.
......@@ -32,7 +32,7 @@ Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
| Deref e T => Deref (subst x es e) T
| Ref e => Ref (subst x es e)
(* | Field e path => Field (subst x es e) path *)
| Retag e kind => Retag (subst x es e) kind
| Retag e pkind T kind => Retag (subst x es e) pkind T kind
| Let x1 e1 e2 =>
Let x1 (subst x es e1)
(if bool_decide (BNamed x x1) then subst x es e2 else e2)
......@@ -107,7 +107,7 @@ Inductive ectx_item :=
| DerefCtx (T: type)
| RefCtx
(* | FieldCtx (path : list nat) *)
| RetagCtx (kind: retag_kind)
| RetagCtx (pkind: pointer_kind) (T: type) (kind: retag_kind)
| LetCtx (x: binder) (e2: expr)
| CaseCtx (el : list expr).
......@@ -137,7 +137,7 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
| DerefCtx T => Deref e T
| RefCtx => Ref e
(* | FieldCtx path => Field e path *)
| RetagCtx kind => Retag e kind
| RetagCtx pk T kind => Retag e pk T kind
| LetCtx x e2 => Let x e e2
| CaseCtx el => Case e el
end.
......@@ -342,11 +342,11 @@ Inductive mem_expr_step (h: mem) : expr → event → mem → expr → Prop :=
h (Free (Place l lbor T))
(DeallocEvt l lbor T)
(free_mem l (tsize T) h) #[]
| RetagBS x xbor T kind :
| RetagBS l otag ntag pkind T kind :
mem_expr_step
h (Retag (Place x xbor T) kind)
(RetagEvt x T kind)
h #[]
h (Retag #[ScPtr l otag] pkind T kind)
(RetagEvt l otag ntag pkind T kind)
h #[ScPtr l ntag]
(* | ForkBS e h:
expr_step (Fork e) h SilentEvt (Lit LitPoison) h [e] *)
(* observable behavior *)
......
......@@ -70,25 +70,6 @@ Lemma of_result_list_expr (vl: list value) :
(of_result <$> (ValR <$> vl)) = Val <$> vl.
Proof. induction vl as [|v vl IH]; [done|]. by rewrite 3!fmap_cons IH. Qed.
(* Lemma subst_is_closed X x es e :
is_closed X es is_closed (x::X) e is_closed X (subst x es e).
Proof.
revert e X. fix FIX 1; destruct e=>X //=; repeat (case_bool_decide=>//=);
try naive_solver; rewrite ?andb_True; intros.
- set_solver.
- split; first naive_solver. induction el; naive_solver.
- (* eauto using is_closed_weaken with set_solver. *)
- eapply is_closed_weaken; first done.
destruct (decide (BNamed x = f)), (decide (BNamed x xl)); set_solver.
- induction el; naive_solver.
- split; first naive_solver. induction el; naive_solver.
Qed.
Lemma subst'_is_closed X b es e :
is_closed X es is_closed (b:b:X) e is_closed X (subst' b es e).
Proof. destruct b; first done. apply subst_is_closed. Qed.
*)
(** Equality and other typeclass stuff *)
Instance bin_op_eq_dec : EqDecision bin_op.
......@@ -161,7 +142,8 @@ Fixpoint expr_beq (e : expr) (e' : expr) : bool :=
bool_decide (l = l') && bool_decide (bor = bor') && bool_decide (T = T')
| Deref e T, Deref e' T' =>
bool_decide (T = T') && expr_beq e e'
| Retag e kind, Retag e' kind' =>
| Retag e pk T kind, Retag e' pk' T' kind' =>
bool_decide (pk = pk') && bool_decide (T = T') &&
bool_decide (kind = kind') && expr_beq e e'
| Copy e, Copy e' | Ref e, Ref e' | InitCall e, InitCall e'
(* | AtomRead e, AtomRead e' *) | EndCall e, EndCall e' => expr_beq e e'
......@@ -228,8 +210,11 @@ Proof.
| Deref e T => GenNode 13 [GenLeaf $ inl $ inr $ inr $ inr T; go e]
| Ref e => GenNode 14 [go e]
(* | Field e path => GenNode 15 [GenLeaf $ inr $ inl $ inl (* $ inl *) path; go e] *)
| Retag e kind => GenNode 15 [GenLeaf $ inr $ inl (* $ inr $ inr *) kind; go e]
| Let x e1 e2 => GenNode 16 [GenLeaf $ inr $ inr x; go e1; go e2]
| Retag e pk T kind =>
GenNode 15 [GenLeaf $ inr $ inl $ inl pk;
GenLeaf $ inr $ inl $ inr T;
GenLeaf $ inr $ inr $ inl kind; go e]
| Let x e1 e2 => GenNode 16 [GenLeaf$ inr $ inr $ inr x; go e1; go e2]
| Case e el => GenNode 17 (go e :: (go <$> el))
(* | Fork e => GenNode 23 [go e]
| SysCall id => GenNode 24 [GenLeaf $ inr $ inr id] *)
......@@ -256,9 +241,11 @@ Proof.
| GenNode 13 [GenLeaf (inl (inr (inr (inr T)))); e] => Deref (go e) T
| GenNode 14 [e] => Ref (go e)
(* | GenNode 15 [GenLeaf (inr (inl (inl (* (inl *) path(* ) *)))); e] => Field (go e) path *)
| GenNode 15 [GenLeaf (inr (inl (* (inr (inr *) kind (* ) ) *))); e] =>
Retag (go e) kind
| GenNode 16 [GenLeaf (inr (inr x)); e1; e2] => Let x (go e1) (go e2)
| GenNode 15 [GenLeaf (inr (inl (inl pk)));
GenLeaf (inr (inl (inr T)));
GenLeaf (inr (inr (inl kind))); e] =>
Retag (go e) pk T kind
| GenNode 16 [GenLeaf (inr (inr (inr x))); e1; e2] => Let x (go e1) (go e2)
| GenNode 17 (e :: el) => Case (go e) (go <$> el)
(* | GenNode 23 [e] => Fork (go e)
| GenNode 24 [GenLeaf (inr (inr id))] => SysCall id *)
......@@ -346,10 +333,10 @@ Inductive head_step :
| HeadPureS σ e e' ev
(ExprStep: pure_expr_step fns σ.(shp) e ev e')
: head_step e σ [ev] e' σ []
| HeadImpureS σ e e' ev h0 h' α' cids' nxtp' nxtc'
(ExprStep : mem_expr_step σ.(shp) e ev h0 e')
(InstrStep: bor_step h0 σ.(sst) σ.(scs) σ.(snp) σ.(snc)
ev h' α' cids' nxtp' nxtc')
| HeadImpureS σ e e' ev h' α' cids' nxtp' nxtc'
(ExprStep : mem_expr_step σ.(shp) e ev h' e')
(InstrStep: bor_step σ.(sst) σ.(scs) σ.(snp) σ.(snc)
ev α' cids' nxtp' nxtc')
: head_step e σ [ev] e' (mkState h' α' cids' nxtp' nxtc') [].
Lemma result_head_stuck e1 σ1 κ e2 σ2 efs :
......@@ -400,4 +387,13 @@ Qed.
(* Allocate a place of type [T] and initialize it with a value [v] *)
Definition new_place T (v: expr) : expr :=
let: "x" := Alloc T in "x" <- v ;; "x".
let: "x" := Alloc T in "x" <- v ;; "x".
(* Retag a place [p] that is a pointer of kind [pk] to a region of type [T],
with retag [kind] *)
Definition retag_place
(p: expr) (pk: pointer_kind) (T: type) (kind: retag_kind) : expr :=
let: "p" := p in
(* read the current pointer stored in the place [p] *)
(* retag and update [p] with the pointer with new tag *)
"p" <- Retag (Copy "p") pk T kind.
......@@ -177,8 +177,9 @@ Inductive expr :=
(* | CAS (e0 e1 e2 : expr) *) (* CAS the value `e2` for `e1` to the place `e0` *)
(* | AtomWrite (e1 e2: expr) *)
(* | AtomRead (e: expr) *)
(* retag *)
| Retag (e : expr) (kind: retag_kind) (* Retag the place `e` with retag kind `kind`. *)
(* retag *) (* Retag the memory pointed to by `e` of type (Reference pk T) with
retag kind `kind`. *)
| Retag (e : expr) (pk: pointer_kind) (T: type) (kind: retag_kind)
(* let binding *)
| Let (x : binder) (e1 e2: expr)
(* case *)
......@@ -209,7 +210,7 @@ Arguments Free _%E.
(* Arguments CAS _%E _%E _%E. *)
(* Arguments AtomWrite _%E _%E. *)
(* Arguments AtomRead _%E. *)
Arguments Retag _%E _.
Arguments Retag _%E _ _ _.
Arguments Let _%binder _%E _%E.
Arguments Case _%E _%E.
(* Arguments Fork _%E. *)
......@@ -225,7 +226,7 @@ Fixpoint is_closed (X : list string) (e : expr) : bool :=
| Let x e1 e2 => is_closed X e1 && is_closed (x :b: X) e2
| Case e el | Call e el (* | App e el *)
=> is_closed X e && forallb (is_closed X) el
| Copy e | Retag e _ | Deref e _ | Ref e (* | Field e _ *)
| Copy e | Retag e _ _ _ | Deref e _ | Ref e (* | Field e _ *)
| Free e | InitCall e | EndCall e (* | AtomRead e | Fork e *)
=> is_closed X e
(* | CAS e0 e1 e2 => is_closed X e0 && is_closed X e1 && is_closed X e2 *)
......@@ -305,7 +306,7 @@ Inductive event :=
| NewCallEvt (fid: fn_id)
| InitCallEvt (c: call_id)
| EndCallEvt (c: call_id) (v: value)
| RetagEvt (x: loc) (T: type) (kind: retag_kind)
| RetagEvt (l: loc) (otag ntag: tag) (pk: pointer_kind) (T: type) (kind: retag_kind)
(* | SysCallEvt (id: nat) *)
| SilentEvt
.
......@@ -21,7 +21,7 @@ Ltac inv_head_step :=
inversion H ; subst; clear H
| H : pure_expr_step _ _ _ _ _ |- _ =>
inversion H ; subst; clear H
| H : bor_step _ _ _ _ _ _ _ _ _ _ _ |- _ =>
| H : bor_step _ _ _ _ _ _ _ _ _ |- _ =>
inversion H ; subst; clear H
end.
......@@ -853,9 +853,10 @@ Qed.
(** Retag *)
Lemma fill_retag_decompose K e kind e':
fill K e = Retag e' kind
K = [] e = Retag e' kind ( K', K = K' ++ [RetagCtx kind] fill K' e = e').
Lemma fill_retag_decompose K e pkind T kind e':
fill K e = Retag e' pkind T kind
K = [] e = Retag e' pkind T kind
( K', K = K' ++ [RetagCtx pkind T kind] fill K' e = e').
Proof.
revert e e'.
induction K as [|Ki K IH]; [by left|]. simpl.
......@@ -866,20 +867,22 @@ Proof.
- subst K. by exists (Ki :: K0).
Qed.
Lemma tstep_retag_inv x tg T pk rk e' σ σ'
(STEP: (Retag (Place x tg (Reference pk T)) rk, σ) ~{fns}~> (e', σ')) :
c cids h' α' nxtp',
Lemma tstep_retag_inv (ptr: result) T pk rk e' σ σ'
(STEP: (Retag ptr pk T rk, σ) ~{fns}~> (e', σ')) :
l otg c cids ntg α' nxtp',
ptr = ValR [ScPtr l otg]
σ.(scs) = c :: cids
retag σ.(shp) σ.(sst) σ.(snp) σ.(scs) c x rk (Reference pk T)
= Some (h', α', nxtp')
e' = #[]%V
σ' = mkState h' α' σ.(scs) nxtp' σ.(snc).
retag σ.(sst) σ.(snp) σ.(scs) c l otg rk pk T = Some (ntg, α', nxtp')
e' = #[ScPtr l ntg]%V
σ' = mkState σ.(shp) α' σ.(scs) nxtp' σ.(snc).
Proof.
inv_tstep. symmetry in Eq.
destruct (fill_retag_decompose _ _ _ _ Eq) as [[]|[K' [? Eq']]]; subst.
- clear Eq. simpl in HS. inv_head_step. naive_solver.
destruct (fill_retag_decompose _ _ _ _ _ _ Eq) as [[]|[K' [? Eq']]]; subst.
- clear Eq. simpl in HS. inv_head_step.
have Eq1 := to_of_result ptr. rewrite -H0 /to_result in Eq1. simplify_eq.
naive_solver.
- exfalso. apply val_head_stuck in HS. destruct (fill_val K' e1') as [? Eq1'].
+ rewrite /= Eq'. by eexists.
+ rewrite /= Eq' to_of_result. by eexists.
+ by rewrite Eq1' in HS.
Qed.
......
This diff is collapsed.
This diff is collapsed.
......@@ -17,7 +17,7 @@ Lemma expr_ind (P : expr → Prop):
( e1 e2, P e1 P e2 P (Write e1 e2))
( ty, P (Alloc ty))
( e, P e P (Free e))
( e k, P e P (Retag e k))
( e pk T rk, P e P (Retag e pk T rk))
( b e1 e2, P e1 P e2 P (Let b e1 e2))
( e el, P e Forall P el P (Case e el))
e, P e.
......@@ -26,6 +26,8 @@ Proof.
(* Find head symbol, then find lemma for that symbol.
We have to be this smart because we can't use the unguarded [REC]! *)
match goal with
| |- P (?head _ _ _ _) =>
match goal with H : context[head] |- _ => apply H; try done end
| |- P (?head _ _ _) =>
match goal with H : context[head] |- _ => apply H; try done end
| |- P (?head _ _) =>
......@@ -60,7 +62,7 @@ Fixpoint subst_map (xs : gmap string result) (e : expr) : expr :=
| Free e => Free (subst_map xs e)
| Deref e T => Deref (subst_map xs e) T
| Ref e => Ref (subst_map xs e)
| Retag e kind => Retag (subst_map xs e) kind
| Retag e pk T kind => Retag (subst_map xs e) pk T kind
| Let x1 e1 e2 =>
Let x1
(subst_map xs e1)
......
......@@ -8,7 +8,7 @@ Set Default Proof Using "Type".
Definition ex1_unopt : function :=
fun: ["i"],
let: "x" := new_place (&mut int) "i" in (* put argument into place *)
Retag "x" Default ;;
retag_place "x" (RefPtr Mutable) int Default ;;
Call #[ScFnPtr "f"] [] ;;
*{int} "x" <- #[42] ;;
Call #[ScFnPtr "g"] [] ;;
......@@ -20,7 +20,7 @@ Definition ex1_unopt : function :=
Definition ex1_opt : function :=
fun: ["i"],
let: "x" := new_place (&mut int) "i" in
Retag "x" Default ;;
retag_place "x" (RefPtr Mutable) int Default ;;
Call #[ScFnPtr "f"] [] ;;
*{int} "x" <- #[42] ;;
let: "v" := Copy *{int} "x" in
......@@ -42,11 +42,20 @@ Proof.
intros sarg ->.
sim_apply sim_simple_let=>/=.