diff --git a/Makefile b/Makefile
index fc4502b3ca79ec8f6b0182e403f7a1141d683b5f..26b7643a4521e872bb827e5663c8f6569240b9ad 100644
--- a/Makefile
+++ b/Makefile
@@ -22,6 +22,8 @@ builddep-opamfiles: builddep/refinedrust-builddep.opam
define BUILDDEP_OPAM_BODY
opam-version: "2.0"
name: "refinedrust-builddep"
+maintainer: "Lennard Gäher"
+author: "Lennard Gäher"
synopsis: "---"
description: """
---
diff --git a/README.md b/README.md
index 3e143a4715e5a0e83bad401f4c567e87143ac621..e29690a88b40a4cf8a3403d9be09ad65934e611f 100644
--- a/README.md
+++ b/README.md
@@ -41,7 +41,7 @@ opam repo add iris-dev https://gitlab.mpi-sws.org/iris/opam.git
```
2. Install the necessary dependencies:
```
-opam pin add coq 8.15.2
+opam pin add coq 8.17.0
opam pin add coq-lambda-rust.dev git-rts@gitlab.mpi-sws.org:lgaeher/lambda-rust.git#rr
make builddep
```
@@ -58,7 +58,7 @@ dune build
4. Run `./refinedrust build` in `rr_frontend` to build the frontend.
-## Usage
+## Frontend usage
To use RefinedRust's frontend to generate the Coq input for RefinedRust's type system, switch to the `rr-frontend` directory.
Then, assuming you want to translate `path-to-file.rs`, run:
```
@@ -75,7 +75,6 @@ To then compile the generated Coq code, switch to `output/section2` and run `dun
In order to interactively look at the generated code using a Coq plugin like Coqtail, VSCoq, or Proof General for the editor of your choice, you need to add a line pointing to the directory of the generated code in the `_CoqProject` file.
See the existing includes for inspiration.
-
## Frontend Configuration
Configuration options can be set in the `RefinedRust.toml` file.
These include:
@@ -89,6 +88,7 @@ These include:
| `run_check` | Boolean | Automatically call the Coq type checker on the generated files |
+
## License
We currently re-use code from the following projects:
- rustc: https://github.com/rust-lang/rust (under the MIT license)
diff --git a/coq-lithium.opam b/coq-lithium.opam
index 093e27418df14ea3c6175d3959a38740ac600994..6d787f7f2773abc186ceb902cb2d782faa222791 100644
--- a/coq-lithium.opam
+++ b/coq-lithium.opam
@@ -15,8 +15,9 @@ bug-reports: "https://gitlab.mpi-sws.org/iris/refinedc/issues"
dev-repo: "git+https://gitlab.mpi-sws.org/iris/refinedc.git"
depends: [
- "coq" { (= "8.15.2" ) }
- "coq-iris" { (= "dev.2022-08-09.4.abefed6c") | (= "dev") }
+ "coq" { (= "8.17.0" ) }
+ "coq-iris" { (= "dev.2023-06-14.0.f0e415b6") | (= "dev") }
+ "coq-stdpp-unstable"
"dune" {>= "3.0.3"}
"coq-record-update" {= "0.3.0"}
]
diff --git a/refinedrust.opam b/refinedrust.opam
index 9a831740bd2bf19f265b1b17f3d466eb7b5bc4bd..59b6fe52b905db67e071dd2f760cc66e35fe7155 100644
--- a/refinedrust.opam
+++ b/refinedrust.opam
@@ -1,6 +1,8 @@
opam-version: "2.0"
name: "refinedrust"
synopsis: "RefinedRust verification framework"
+maintainer: "Lennard Gäher"
+author: "Lennard Gäher"
description: """
RefinedRust is a prototype framework for verifying safe and unsafe Rust code.
"""
diff --git a/rr_frontend/analysis/src/abstract_interpretation/fixpoint_engine.rs b/rr_frontend/analysis/src/abstract_interpretation/fixpoint_engine.rs
index 73c9cf032a0ef85d6037e14ea01159ab0754e424..0723210b3d0fd0f85101d53cecd2c0d2006700f4 100644
--- a/rr_frontend/analysis/src/abstract_interpretation/fixpoint_engine.rs
+++ b/rr_frontend/analysis/src/abstract_interpretation/fixpoint_engine.rs
@@ -64,10 +64,10 @@ pub trait FixpointEngine<'mir, 'tcx: 'mir> {
let mut p_state = PointwiseState::new(mir);
// use https://crates.io/crates/linked_hash_set for set preserving insertion order?
let mut work_set: BTreeSet<mir::BasicBlock> =
- BTreeSet::from_iter(mir.basic_blocks().indices());
+ BTreeSet::from_iter(mir.basic_blocks.indices());
let mut counters: FxHashMap<mir::BasicBlock, u32> =
- FxHashMap::with_capacity_and_hasher(mir.basic_blocks().len(), Default::default());
+ FxHashMap::with_capacity_and_hasher(mir.basic_blocks.len(), Default::default());
//'block_loop:
// extract the bb with the minimal index -> hopefully better performance
diff --git a/rr_frontend/analysis/src/bin/analysis-driver.rs b/rr_frontend/analysis/src/bin/analysis-driver.rs
index c39171215fe5c1375468e9c9741c342dc02d0c99..e9d6e31354a06b5f01a7635afd9a12fe9fce0eb6 100644
--- a/rr_frontend/analysis/src/bin/analysis-driver.rs
+++ b/rr_frontend/analysis/src/bin/analysis-driver.rs
@@ -13,18 +13,20 @@ use analysis::{
};
use rr_rustc_interface::{
ast::ast,
- borrowck::BodyWithBorrowckFacts,
+ borrowck::consumers::{self, BodyWithBorrowckFacts},
+ data_structures::fx::FxHashMap,
driver::Compilation,
+ errors,
hir::def_id::{DefId, LocalDefId},
interface::{interface, Config, Queries},
middle::{
+ query::{queries::mir_borrowck::ProvidedValue, ExternProviders, Providers},
ty,
- ty::query::{query_values::mir_borrowck, ExternProviders, Providers},
},
polonius_engine::{Algorithm, Output},
- session::{Attribute, Session},
+ session::{self, Attribute, EarlyErrorHandler, Session},
};
-use std::{cell::RefCell, collections::HashMap, rc::Rc};
+use std::{cell::RefCell, rc::Rc};
struct OurCompilerCalls {
args: Vec<String>,
@@ -51,7 +53,7 @@ fn get_attribute<'tcx>(
get_attributes(tcx, def_id)
.iter()
.find(|attr| match &attr.kind {
- ast::AttrKind::Normal(
+ ast::AttrKind::Normal(normal_attr) => match &normal_attr.item {
ast::AttrItem {
path:
ast::Path {
@@ -59,15 +61,15 @@ fn get_attribute<'tcx>(
segments,
tokens: _,
},
- args: ast::MacArgs::Empty,
+ args: ast::AttrArgs::Empty,
tokens: _,
- },
- _,
- ) => {
- segments.len() == 2
- && segments[0].ident.as_str() == segment1
- && segments[1].ident.as_str() == segment2
- }
+ } => {
+ segments.len() == 2
+ && segments[0].ident.as_str() == segment1
+ && segments[1].ident.as_str() == segment2
+ }
+ _ => false,
+ },
_ => false,
})
}
@@ -83,8 +85,8 @@ mod mir_storage {
// because we cast it back to `'tcx` before using.
thread_local! {
static MIR_BODIES:
- RefCell<HashMap<LocalDefId, BodyWithBorrowckFacts<'static>>> =
- RefCell::new(HashMap::new());
+ RefCell<FxHashMap<LocalDefId, BodyWithBorrowckFacts<'static>>> =
+ RefCell::new(FxHashMap::default());
}
pub unsafe fn store_mir_body<'tcx>(
@@ -115,10 +117,11 @@ mod mir_storage {
}
#[allow(clippy::needless_lifetimes)]
-fn mir_borrowck<'tcx>(tcx: ty::TyCtxt<'tcx>, def_id: LocalDefId) -> mir_borrowck<'tcx> {
- let body_with_facts = rr_rustc_interface::borrowck::consumers::get_body_with_borrowck_facts(
+fn mir_borrowck<'tcx>(tcx: ty::TyCtxt<'tcx>, def_id: LocalDefId) -> ProvidedValue<'tcx> {
+ let body_with_facts = consumers::get_body_with_borrowck_facts(
tcx,
- ty::WithOptConstParam::unknown(def_id),
+ def_id,
+ consumers::ConsumerOptions::PoloniusOutputFacts,
);
// SAFETY: This is safe because we are feeding in the same `tcx` that is
// going to be used as a witness when pulling out the data.
@@ -144,6 +147,7 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
fn after_analysis<'tcx>(
&mut self,
+ _error_handler: &EarlyErrorHandler,
compiler: &interface::Compiler,
queries: &'tcx Queries<'tcx>,
) -> Compilation {
@@ -160,11 +164,11 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
println!(
"Analyzing file {} using {}...",
- compiler.input().source_name().prefer_local(),
+ compiler.session().io.input.source_name().prefer_local(),
abstract_domain
);
- queries.global_ctxt().unwrap().peek_mut().enter(|tcx| {
+ queries.global_ctxt().unwrap().enter(|tcx| {
// collect all functions with attribute #[analyzer::run]
let mut local_def_ids: Vec<_> = tcx
.mir_keys(())
@@ -189,12 +193,17 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
// that was used to store the data.
let mut body_with_facts =
unsafe { self::mir_storage::retrieve_mir_body(tcx, local_def_id) };
- body_with_facts.output_facts = Rc::new(Output::compute(
- &body_with_facts.input_facts,
+ body_with_facts.output_facts = Some(Rc::new(Output::compute(
+ body_with_facts.input_facts.as_ref().unwrap(),
Algorithm::Naive,
true,
- ));
- assert!(!body_with_facts.input_facts.cfg_edge.is_empty());
+ )));
+ assert!(!body_with_facts
+ .input_facts
+ .as_ref()
+ .unwrap()
+ .cfg_edge
+ .is_empty());
let body = &body_with_facts.body;
match abstract_domain {
@@ -265,7 +274,7 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
Err(e) => eprintln!("{}", e.to_pretty_str(body)),
}
}
- _ => panic!("Unknown domain argument: {}", abstract_domain),
+ _ => panic!("Unknown domain argument: {abstract_domain}"),
}
}
});
@@ -281,7 +290,10 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
/// --analysis=ReachingDefsState or --analysis=DefinitelyInitializedAnalysis
fn main() {
env_logger::init();
- rr_rustc_interface::driver::init_rustc_env_logger();
+ let error_handler = EarlyErrorHandler::new(session::config::ErrorOutputType::HumanReadable(
+ errors::emitter::HumanReadableErrorType::Default(errors::emitter::ColorConfig::Auto),
+ ));
+ rr_rustc_interface::driver::init_rustc_env_logger(&error_handler);
let mut compiler_args = Vec::new();
let mut callback_args = Vec::new();
for arg in std::env::args() {
diff --git a/rr_frontend/analysis/src/bin/gen-accessibility-driver.rs b/rr_frontend/analysis/src/bin/gen-accessibility-driver.rs
index 163026f69e88de37d9b53be50cadbb118b3d80fb..8610c51ae6c6f5a333c65226cf7551772b7b3a8c 100644
--- a/rr_frontend/analysis/src/bin/gen-accessibility-driver.rs
+++ b/rr_frontend/analysis/src/bin/gen-accessibility-driver.rs
@@ -6,20 +6,21 @@
use analysis::domains::DefinitelyAccessibleAnalysis;
use rr_rustc_interface::{
- borrowck::BodyWithBorrowckFacts,
+ borrowck::consumers::{self, BodyWithBorrowckFacts},
+ data_structures::fx::FxHashMap,
driver::Compilation,
- hir,
+ errors, hir,
hir::def_id::LocalDefId,
interface::{interface, Config, Queries},
middle::{
+ query::{queries::mir_borrowck::ProvidedValue, ExternProviders, Providers},
ty,
- ty::query::{query_values::mir_borrowck, ExternProviders, Providers},
},
polonius_engine::{Algorithm, Output},
- session::Session,
+ session::{self, EarlyErrorHandler, Session},
span::FileName,
};
-use std::{cell::RefCell, collections::HashMap, path::PathBuf, rc::Rc};
+use std::{cell::RefCell, path::PathBuf, rc::Rc};
struct OurCompilerCalls {
args: Vec<String>,
@@ -36,8 +37,8 @@ mod mir_storage {
// because we cast it back to `'tcx` before using.
thread_local! {
static MIR_BODIES:
- RefCell<HashMap<LocalDefId, BodyWithBorrowckFacts<'static>>> =
- RefCell::new(HashMap::new());
+ RefCell<FxHashMap<LocalDefId, BodyWithBorrowckFacts<'static>>> =
+ RefCell::new(FxHashMap::default());
}
pub unsafe fn store_mir_body<'tcx>(
@@ -68,10 +69,11 @@ mod mir_storage {
}
#[allow(clippy::needless_lifetimes)]
-fn mir_borrowck<'tcx>(tcx: ty::TyCtxt<'tcx>, def_id: LocalDefId) -> mir_borrowck<'tcx> {
- let body_with_facts = rr_rustc_interface::borrowck::consumers::get_body_with_borrowck_facts(
+fn mir_borrowck<'tcx>(tcx: ty::TyCtxt<'tcx>, def_id: LocalDefId) -> ProvidedValue<'tcx> {
+ let body_with_facts = consumers::get_body_with_borrowck_facts(
tcx,
- ty::WithOptConstParam::unknown(def_id),
+ def_id,
+ consumers::ConsumerOptions::PoloniusOutputFacts,
);
// SAFETY: This is safe because we are feeding in the same `tcx` that is
// going to be used as a witness when pulling out the data.
@@ -97,6 +99,7 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
fn after_analysis<'tcx>(
&mut self,
+ _error_handler: &EarlyErrorHandler,
compiler: &interface::Compiler,
queries: &'tcx Queries<'tcx>,
) -> Compilation {
@@ -105,7 +108,7 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
assert!(self.args.iter().any(|a| a == "--generate-test-program"));
- queries.global_ctxt().unwrap().peek_mut().enter(|tcx| {
+ queries.global_ctxt().unwrap().enter(|tcx| {
// Retrieve the MIR body of all user-written functions and run Polonius.
let mut def_ids_with_body: Vec<_> = tcx
.mir_keys(())
@@ -134,11 +137,11 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
// that was used to store the data.
let mut body_with_facts =
unsafe { self::mir_storage::retrieve_mir_body(tcx, local_def_id) };
- body_with_facts.output_facts = Rc::new(Output::compute(
- &body_with_facts.input_facts,
+ body_with_facts.output_facts = Some(Rc::new(Output::compute(
+ body_with_facts.input_facts.as_ref().unwrap(),
Algorithm::Naive,
true,
- ));
+ )));
// Skip macro expansions
let mir_span = body_with_facts.body.span;
@@ -154,7 +157,7 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
// Skip functions that are in an external file.
let source_file = session.source_map().lookup_source_file(mir_span.data().lo);
if let FileName::Real(filename) = &source_file.name {
- if session.local_crate_source_file
+ if session.local_crate_source_file()
!= filename.local_path().map(PathBuf::from)
{
return None;
@@ -174,7 +177,12 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
// Generate and print the programs with the additional statements to check accessibility.
for (num, (local_def_id, body_with_facts)) in def_ids_with_body.iter().enumerate() {
- assert!(!body_with_facts.input_facts.cfg_edge.is_empty());
+ assert!(!body_with_facts
+ .input_facts
+ .as_ref()
+ .unwrap()
+ .cfg_edge
+ .is_empty());
let body = &body_with_facts.body;
if num > 0 {
@@ -205,7 +213,10 @@ impl rr_rustc_interface::driver::Callbacks for OurCompilerCalls {
/// Run an analysis by calling like it rustc
fn main() {
env_logger::init();
- rr_rustc_interface::driver::init_rustc_env_logger();
+ let error_handler = EarlyErrorHandler::new(session::config::ErrorOutputType::HumanReadable(
+ errors::emitter::HumanReadableErrorType::Default(errors::emitter::ColorConfig::Auto),
+ ));
+ rr_rustc_interface::driver::init_rustc_env_logger(&error_handler);
let mut compiler_args = Vec::new();
let mut callback_args = Vec::new();
for arg in std::env::args() {
diff --git a/rr_frontend/analysis/src/domains/definitely_accessible/analysis.rs b/rr_frontend/analysis/src/domains/definitely_accessible/analysis.rs
index 75ba07c36196aff8627145b0254704fc757f760e..9c7e05f5a5a120ca1e9df5a2f43fab3df94bf5a9 100644
--- a/rr_frontend/analysis/src/domains/definitely_accessible/analysis.rs
+++ b/rr_frontend/analysis/src/domains/definitely_accessible/analysis.rs
@@ -14,8 +14,8 @@ use crate::{
PointwiseState,
};
use rr_rustc_interface::{
- borrowck::BodyWithBorrowckFacts,
- data_structures::{fx::FxHashMap, fx::FxHashSet},
+ borrowck::consumers::BodyWithBorrowckFacts,
+ data_structures::fx::{FxHashMap, FxHashSet},
middle::{mir, ty::TyCtxt},
span::def_id::DefId,
};
@@ -48,8 +48,8 @@ impl<'mir, 'tcx: 'mir> DefinitelyAccessibleAnalysis<'mir, 'tcx> {
let borrowed_analysis = MaybeBorrowedAnalysis::new(self.tcx, self.body_with_facts);
let def_init = def_init_analysis.run_fwd_analysis()?;
let borrowed = borrowed_analysis.run_analysis()?;
- let location_table = &self.body_with_facts.location_table;
- let borrowck_out_facts = self.body_with_facts.output_facts.as_ref();
+ let location_table = self.body_with_facts.location_table.as_ref().unwrap();
+ let borrowck_out_facts = self.body_with_facts.output_facts.as_ref().unwrap().as_ref();
let var_live_on_entry: FxHashMap<_, _> = borrowck_out_facts
.var_live_on_entry
.iter()
@@ -58,19 +58,19 @@ impl<'mir, 'tcx: 'mir> DefinitelyAccessibleAnalysis<'mir, 'tcx> {
let empty_locals_set: FxHashSet<mir::Local> = FxHashSet::default();
let mut analysis_state = PointwiseState::default(body);
- for (block, block_data) in body.basic_blocks().iter_enumerated() {
+ for (block, block_data) in body.basic_blocks.iter_enumerated() {
// Initialize the state before each statement
for statement_index in 0..=block_data.statements.len() {
let location = mir::Location {
block,
statement_index,
};
- let def_init_before = def_init.lookup_before(location).unwrap_or_else(|| {
- panic!("No 'def_init' state before location {:?}", location)
- });
- let borrowed_before = borrowed.lookup_before(location).unwrap_or_else(|| {
- panic!("No 'borrowed' state before location {:?}", location)
- });
+ let def_init_before = def_init
+ .lookup_before(location)
+ .unwrap_or_else(|| panic!("No 'def_init' state before location {location:?}"));
+ let borrowed_before = borrowed
+ .lookup_before(location)
+ .unwrap_or_else(|| panic!("No 'borrowed' state before location {location:?}"));
let liveness_before = var_live_on_entry
.get(&location_table.start_index(location))
.unwrap_or(&empty_locals_set);
@@ -86,17 +86,17 @@ impl<'mir, 'tcx: 'mir> DefinitelyAccessibleAnalysis<'mir, 'tcx> {
// Initialize the state of successors of terminators
let def_init_after_block = def_init
.lookup_after_block(block)
- .unwrap_or_else(|| panic!("No 'def_init' state after block {:?}", block));
+ .unwrap_or_else(|| panic!("No 'def_init' state after block {block:?}"));
let borrowed_after_block = borrowed
.lookup_after_block(block)
- .unwrap_or_else(|| panic!("No 'borrowed' state after block {:?}", block));
+ .unwrap_or_else(|| panic!("No 'borrowed' state after block {block:?}"));
let available_after_block = analysis_state.lookup_mut_after_block(block);
for successor in block_data.terminator().successors() {
let def_init_after = def_init_after_block.get(&successor).unwrap_or_else(|| {
- panic!("No 'def_init' state from {:?} to {:?}", block, successor)
+ panic!("No 'def_init' state from {block:?} to {successor:?}")
});
let borrowed_after = borrowed_after_block.get(&successor).unwrap_or_else(|| {
- panic!("No 'borrowed' state from {:?} to {:?}", block, successor)
+ panic!("No 'borrowed' state from {block:?} to {successor:?}")
});
let liveness_after = var_live_on_entry
.get(&location_table.start_index(successor.start_location()))
diff --git a/rr_frontend/analysis/src/domains/definitely_accessible/state.rs b/rr_frontend/analysis/src/domains/definitely_accessible/state.rs
index 466662db6ef3ccb10b3cdf109f9a96c4e864b53c..4effef762d8b8cc89425dfdb36c595a4bc34737e 100644
--- a/rr_frontend/analysis/src/domains/definitely_accessible/state.rs
+++ b/rr_frontend/analysis/src/domains/definitely_accessible/state.rs
@@ -10,7 +10,8 @@ use crate::{
};
use log::info;
use rr_rustc_interface::{
- data_structures::{fx::FxHashSet, fx::FxHashMap},
+ abi::FieldIdx,
+ data_structures::fx::{FxHashMap, FxHashSet},
middle::{mir, ty, ty::TyCtxt},
span::source_map::SourceMap,
target::abi::VariantIdx,
@@ -42,9 +43,7 @@ impl<'tcx> DefinitelyAccessibleState<'tcx> {
self.definitely_accessible
.iter()
.any(|&place| place == owned_place || is_prefix(owned_place, place)),
- "In the state before {:?} the place {:?} is owned but not accessible",
- location,
- owned_place
+ "In the state before {location:?} the place {owned_place:?} is owned but not accessible"
);
}
}
@@ -53,20 +52,23 @@ impl<'tcx> DefinitelyAccessibleState<'tcx> {
impl<'tcx> Serialize for DefinitelyAccessibleState<'tcx> {
fn serialize<Se: Serializer>(&self, serializer: Se) -> Result<Se::Ok, Se::Error> {
let mut seq = serializer.serialize_map(Some(2))?;
+
let mut definitely_accessible_set: Vec<_> = self.definitely_accessible.iter().collect();
- definitely_accessible_set.sort();
- let mut definitely_accessible_strings = vec![];
- for &place in definitely_accessible_set {
- definitely_accessible_strings.push(format!("{:?}", place));
- }
+ definitely_accessible_set.sort_unstable();
+ let definitely_accessible_strings: Vec<_> = definitely_accessible_set
+ .into_iter()
+ .map(|place| format!("{place:?}"))
+ .collect();
seq.serialize_entry("accessible", &definitely_accessible_strings)?;
+
let mut definitely_owned_set: Vec<_> = self.definitely_owned.iter().collect();
- definitely_owned_set.sort();
- let mut definitely_owned_strings = vec![];
- for &place in definitely_owned_set {
- definitely_owned_strings.push(format!("{:?}", place));
- }
+ definitely_owned_set.sort_unstable();
+ let definitely_owned_strings: Vec<_> = definitely_owned_set
+ .into_iter()
+ .map(|place| format!("{place:?}"))
+ .collect();
seq.serialize_entry("owned", &definitely_owned_strings)?;
+
seq.end()
}
}
@@ -87,7 +89,7 @@ impl<'mir, 'tcx: 'mir> PointwiseState<'mir, 'tcx, DefinitelyAccessibleState<'tcx
.map(|line_index| source_file.get_line(line_index).unwrap().to_string())
.collect();
let mut first_location_on_line: FxHashMap<usize, mir::Location> = FxHashMap::default();
- for (block, block_data) in self.mir.basic_blocks().iter_enumerated() {
+ for (block, block_data) in self.mir.basic_blocks.iter_enumerated() {
for statement_index in 0..=block_data.statements.len() {
let location = mir::Location {
block,
@@ -95,26 +97,23 @@ impl<'mir, 'tcx: 'mir> PointwiseState<'mir, 'tcx, DefinitelyAccessibleState<'tcx
};
let span = self.mir.source_info(location).span;
if span.parent_callsite().is_some() {
- info!("Statement {:?} is generated by a macro", location);
+ info!("Statement {location:?} is generated by a macro");
continue;
}
if source_map.is_multiline(span) {
- info!("Statement {:?} is on multiple lines", location);
+ info!("Statement {location:?} is on multiple lines");
continue;
}
if let Ok(file_lines) = source_map.span_to_lines(span) {
if file_lines.lines.len() == 1 {
let line = file_lines.lines.first().unwrap();
let line_num = line.line_index + 1;
- info!(
- "Statement {:?} is on a single line at {}",
- location, line_num
- );
+ info!("Statement {location:?} is on a single line at {line_num}");
// Check that it parses as a statement
let line_seems_stmt =
syn::parse_str::<syn::Stmt>(&result[line.line_index]).is_ok();
if !line_seems_stmt {
- info!("Statement {:?} doesn't parse as a statement", location);
+ info!("Statement {location:?} doesn't parse as a statement");
continue;
}
// Keep the first span
@@ -130,24 +129,21 @@ impl<'mir, 'tcx: 'mir> PointwiseState<'mir, 'tcx, DefinitelyAccessibleState<'tcx
}
}
} else {
- info!("Statement {:?} has no lines", location);
+ info!("Statement {location:?} has no lines");
}
}
}
let mut line_locations: Vec<_> = first_location_on_line.iter().collect();
- line_locations.sort_by(|left, right| right.0.cmp(left.0)); // From last to first
+ line_locations.sort_unstable_by(|left, right| right.0.cmp(left.0)); // From last to first
for (&line_num, &location) in line_locations {
- info!(
- "The first single-line statement on line {} is {:?}",
- line_num, location
- );
+ info!("The first single-line statement on line {line_num} is {location:?}",);
let before = "\t\t\t";
let after = " // Check analysis";
let state = self.lookup_before(location).unwrap();
let mut check_stmts = vec![];
for &place in state.definitely_accessible.iter() {
if let Some(place_expr) = pretty_print_place(tcx, self.mir, place) {
- check_stmts.push(format!("{}let _ = & {};{}", before, place_expr, after));
+ check_stmts.push(format!("{before}let _ = & {place_expr};{after}"));
}
}
for &place in state.definitely_owned.iter() {
@@ -155,8 +151,7 @@ impl<'mir, 'tcx: 'mir> PointwiseState<'mir, 'tcx, DefinitelyAccessibleState<'tcx
let local_decl = &self.mir.local_decls[place.local];
// &mut cannot be used on locals that are not marked as mut
if local_decl.mutability != mir::Mutability::Not {
- check_stmts
- .push(format!("{}let _ = &mut {};{}", before, place_expr, after));
+ check_stmts.push(format!("{before}let _ = &mut {place_expr};{after}"));
}
}
}
@@ -202,7 +197,7 @@ fn pretty_print_place<'tcx>(
})
.map(|var_debug_info| var_debug_info.name);
if let Some(name) = local_name {
- pieces.push(format!("{}", name));
+ pieces.push(format!("{name}"));
} else {
return None;
}
@@ -221,12 +216,13 @@ fn pretty_print_place<'tcx>(
}
mir::ProjectionElem::Field(field, field_ty) => {
let field_name = describe_field_from_ty(tcx, prev_ty, field, variant)?;
- pieces.push(format!(".{})", field_name));
+ pieces.push(format!(".{field_name})"));
prev_ty = field_ty;
variant = None;
}
mir::ProjectionElem::Index(..)
| mir::ProjectionElem::ConstantIndex { .. }
+ | mir::ProjectionElem::OpaqueCast(..)
| mir::ProjectionElem::Subslice { .. } => {
// It's not possible to move-out or borrow an individual element.
unreachable!()
@@ -241,7 +237,7 @@ fn pretty_print_place<'tcx>(
fn describe_field_from_ty(
tcx: TyCtxt<'_>,
ty: ty::Ty<'_>,
- field: mir::Field,
+ field: FieldIdx,
variant_index: Option<VariantIdx>,
) -> Option<String> {
if ty.is_box() {
@@ -256,7 +252,7 @@ fn describe_field_from_ty(
} else {
def.non_enum_variant()
};
- Some(variant.fields[field.index()].ident(tcx).to_string())
+ Some(variant.fields[field].ident(tcx).to_string())
}
ty::TyKind::Tuple(_) => Some(field.index().to_string()),
ty::TyKind::Ref(_, ty, _) | ty::TyKind::RawPtr(ty::TypeAndMut { ty, .. }) => {
diff --git a/rr_frontend/analysis/src/domains/definitely_allocated/analysis.rs b/rr_frontend/analysis/src/domains/definitely_allocated/analysis.rs
index 88b13471985e14e1ea191e5291de198a429e83c9..b5f8d958ea81c8d5e7e2d5119e23d69cc6a3289f 100644
--- a/rr_frontend/analysis/src/domains/definitely_allocated/analysis.rs
+++ b/rr_frontend/analysis/src/domains/definitely_allocated/analysis.rs
@@ -44,7 +44,7 @@ impl<'mir, 'tcx: 'mir> FixpointEngine<'mir, 'tcx> for DefinitelyAllocatedAnalysi
fn new_initial(&self) -> Self::State {
let mut locals_without_explicit_allocation: FxHashSet<_> =
self.mir.vars_and_temps_iter().collect();
- for block in self.mir.basic_blocks() {
+ for block in self.mir.basic_blocks.iter() {
for statement in &block.statements {
match statement.kind {
mir::StatementKind::StorageLive(local)
diff --git a/rr_frontend/analysis/src/domains/definitely_initialized/state.rs b/rr_frontend/analysis/src/domains/definitely_initialized/state.rs
index 7294d9f4fa7e991b3c548b613bf74562d6a06af6..53941bb8113d2ea4c75568e69f4b13eaa6963b11 100644
--- a/rr_frontend/analysis/src/domains/definitely_initialized/state.rs
+++ b/rr_frontend/analysis/src/domains/definitely_initialized/state.rs
@@ -69,7 +69,7 @@ impl<'mir, 'tcx: 'mir> Serialize for DefinitelyInitializedState<'mir, 'tcx> {
let mut seq = serializer.serialize_seq(Some(self.def_init_places.len()))?;
let ordered_place_set: BTreeSet<_> = self.def_init_places.iter().collect();
for place in ordered_place_set {
- seq.serialize_element(&format!("{:?}", place))?;
+ seq.serialize_element(&format!("{place:?}"))?;
}
seq.end()
}
@@ -104,15 +104,11 @@ impl<'mir, 'tcx: 'mir> DefinitelyInitializedState<'mir, 'tcx> {
if place1 != place2 {
debug_assert!(
!is_prefix(place1, place2),
- "The place {:?} is a prefix of the place {:?}",
- place2,
- place1
+ "The place {place2:?} is a prefix of the place {place1:?}"
);
debug_assert!(
!is_prefix(place2, place1),
- "The place {:?} is a prefix of the place {:?}",
- place1,
- place2
+ "The place {place1:?} is a prefix of the place {place2:?}"
);
}
}
@@ -177,9 +173,7 @@ impl<'mir, 'tcx: 'mir> DefinitelyInitializedState<'mir, 'tcx> {
for &place1 in self.def_init_places.iter() {
debug_assert!(
!is_prefix(place1, place) && !is_prefix(place, place1),
- "Bug: failed to ensure that there are no prefixes: place={:?} place1={:?}",
- place,
- place1
+ "Bug: failed to ensure that there are no prefixes: place={place:?} place1={place1:?}"
);
}
@@ -267,27 +261,12 @@ impl<'mir, 'tcx: 'mir> DefinitelyInitializedState<'mir, 'tcx> {
place,
target,
unwind,
+ ..
} => {
new_state.set_place_uninitialised(place);
res_vec.push((target, new_state));
- if let Some(bb) = unwind {
- // imprecision for error states
- res_vec.push((bb, Self::new_top(self.def_id, self.mir, self.tcx)));
- }
- }
- mir::TerminatorKind::DropAndReplace {
- place,
- ref value,
- target,
- unwind,
- } => {
- new_state.set_place_uninitialised(place);
- new_state.apply_operand_effect(value, move_out_copy_types);
- new_state.set_place_initialised(place);
- res_vec.push((target, new_state));
-
- if let Some(bb) = unwind {
+ if let mir::UnwindAction::Cleanup(bb) = unwind {
// imprecision for error states
res_vec.push((bb, Self::new_top(self.def_id, self.mir, self.tcx)));
}
@@ -297,7 +276,7 @@ impl<'mir, 'tcx: 'mir> DefinitelyInitializedState<'mir, 'tcx> {
ref args,
destination,
target,
- cleanup,
+ unwind,
..
} => {
for arg in args.iter() {
@@ -309,7 +288,7 @@ impl<'mir, 'tcx: 'mir> DefinitelyInitializedState<'mir, 'tcx> {
res_vec.push((bb, new_state));
}
- if let Some(bb) = cleanup {
+ if let mir::UnwindAction::Cleanup(bb) = unwind {
// imprecision for error states
res_vec.push((bb, Self::new_top(self.def_id, self.mir, self.tcx)));
}
@@ -317,13 +296,13 @@ impl<'mir, 'tcx: 'mir> DefinitelyInitializedState<'mir, 'tcx> {
mir::TerminatorKind::Assert {
ref cond,
target,
- cleanup,
+ unwind,
..
} => {
new_state.apply_operand_effect(cond, move_out_copy_types);
res_vec.push((target, new_state));
- if let Some(bb) = cleanup {
+ if let mir::UnwindAction::Cleanup(bb) = unwind {
// imprecision for error states
res_vec.push((bb, Self::new_top(self.def_id, self.mir, self.tcx)));
}
diff --git a/rr_frontend/analysis/src/domains/framing/analysis.rs b/rr_frontend/analysis/src/domains/framing/analysis.rs
index 3e9428724a2ddd1e9fe705623f158f7b3d3e3daf..8c4a9b47c840d88d18620fa95dde1fd377f7eb49 100644
--- a/rr_frontend/analysis/src/domains/framing/analysis.rs
+++ b/rr_frontend/analysis/src/domains/framing/analysis.rs
@@ -11,7 +11,7 @@ use crate::{
PointwiseState,
};
use rr_rustc_interface::{
- borrowck::BodyWithBorrowckFacts,
+ borrowck::consumers::BodyWithBorrowckFacts,
middle::{
mir,
mir::visit::{NonMutatingUseContext, PlaceContext, Visitor},
@@ -47,7 +47,7 @@ impl<'mir, 'tcx: 'mir> FramingAnalysis<'mir, 'tcx> {
let mut analysis_state = PointwiseState::default(body);
// Set state_after_block
- for (block, block_data) in body.basic_blocks().iter_enumerated() {
+ for (block, block_data) in body.basic_blocks.iter_enumerated() {
// Initialize the state before each statement and terminator
for statement_index in 0..=block_data.statements.len() {
let location = mir::Location {
@@ -55,7 +55,7 @@ impl<'mir, 'tcx: 'mir> FramingAnalysis<'mir, 'tcx> {
statement_index,
};
let acc_before = accessibility.lookup_before(location).unwrap_or_else(|| {
- panic!("No 'accessibility' state before location {:?}", location)
+ panic!("No 'accessibility' state before location {location:?}")
});
let mut compute_framing = ComputeFramingState::initial(body, self.tcx, acc_before);
if let Some(stmt) = body.stmt_at(location).left() {
@@ -105,7 +105,6 @@ impl<'mir, 'tcx: 'mir> Visitor<'tcx> for ComputeFramingState<'mir, 'tcx> {
) {
let place = (*place).into();
match context {
- PlaceContext::NonMutatingUse(NonMutatingUseContext::UniqueBorrow) => todo!(),
PlaceContext::MutatingUse(_)
| PlaceContext::NonMutatingUse(NonMutatingUseContext::Move) => {
// No permission can be framed
diff --git a/rr_frontend/analysis/src/domains/maybe_borrowed/analysis.rs b/rr_frontend/analysis/src/domains/maybe_borrowed/analysis.rs
index 563e062b30b2f02cc9c071856337090563fa9d21..24680fa85e13829d21bc134aa39ebf525af3fcfb 100644
--- a/rr_frontend/analysis/src/domains/maybe_borrowed/analysis.rs
+++ b/rr_frontend/analysis/src/domains/maybe_borrowed/analysis.rs
@@ -10,7 +10,7 @@ use crate::{
};
use log::{error, trace};
use rr_rustc_interface::{
- borrowck::{consumers::RichLocation, BodyWithBorrowckFacts},
+ borrowck::consumers::{BodyWithBorrowckFacts, RichLocation},
data_structures::fx::FxHashMap,
middle::{mir, ty::TyCtxt},
};
@@ -32,9 +32,9 @@ impl<'mir, 'tcx: 'mir> MaybeBorrowedAnalysis<'mir, 'tcx> {
&self,
) -> AnalysisResult<PointwiseState<'mir, 'tcx, MaybeBorrowedState<'tcx>>> {
let body = &self.body_with_facts.body;
- let location_table = &self.body_with_facts.location_table;
- let borrowck_in_facts = &self.body_with_facts.input_facts;
- let borrowck_out_facts = self.body_with_facts.output_facts.as_ref();
+ let location_table = self.body_with_facts.location_table.as_ref().unwrap();
+ let borrowck_in_facts = self.body_with_facts.input_facts.as_ref().unwrap();
+ let borrowck_out_facts = self.body_with_facts.output_facts.as_ref().unwrap().as_ref();
let loan_issued_at = &borrowck_in_facts.loan_issued_at;
let loan_live_at = &borrowck_out_facts.loan_live_at;
let loan_issued_at_location: FxHashMap<_, mir::Location> = loan_issued_at
@@ -99,7 +99,7 @@ impl<'mir, 'tcx: 'mir> MaybeBorrowedAnalysis<'mir, 'tcx> {
}
// Set state_after_block
- for (block, block_data) in body.basic_blocks().iter_enumerated() {
+ for (block, block_data) in body.basic_blocks.iter_enumerated() {
for successor in block_data.terminator().successors() {
let state = analysis_state
.lookup_before(mir::Location {
diff --git a/rr_frontend/analysis/src/domains/reaching_definitions/state.rs b/rr_frontend/analysis/src/domains/reaching_definitions/state.rs
index 03db1d04f84b190e249aec4c250dadb5e1b3bb41..3715f5e9d74417eace9dcbdca0030352ad6a69db 100644
--- a/rr_frontend/analysis/src/domains/reaching_definitions/state.rs
+++ b/rr_frontend/analysis/src/domains/reaching_definitions/state.rs
@@ -80,19 +80,19 @@ impl<'mir, 'tcx: 'mir> Serialize for ReachingDefsState<'mir, 'tcx> {
let ordered_ass_map: BTreeMap<_, _> = self.reaching_defs.iter().collect();
for (local, location_set) in ordered_ass_map {
let ordered_loc_set: BTreeSet<_> = location_set.iter().collect();
- let mut location_vec = Vec::new();
+ let mut location_vec = Vec::with_capacity(ordered_loc_set.len());
for location in ordered_loc_set {
match location {
DefLocation::Assignment(l) => {
let stmt = location_to_stmt_str(*l, self.mir);
// Include the location to differentiate between same statement on
// different lines.
- location_vec.push(format!("{:?}: {}", l, stmt));
+ location_vec.push(format!("{l:?}: {stmt}"));
}
- DefLocation::Parameter(idx) => location_vec.push(format!("arg{}", idx)),
+ DefLocation::Parameter(idx) => location_vec.push(format!("arg{idx}")),
}
}
- map.serialize_entry(&format!("{:?}", local), &location_vec)?;
+ map.serialize_entry(&format!("{local:?}"), &location_vec)?;
}
map.end()
}
@@ -106,10 +106,7 @@ impl<'mir, 'tcx: 'mir> ReachingDefsState<'mir, 'tcx> {
let stmt = &self.mir[location.block].statements[location.statement_index];
if let mir::StatementKind::Assign(box (ref target, _)) = stmt.kind {
if let Some(local) = target.as_local() {
- let location_set = self
- .reaching_defs
- .entry(local)
- .or_insert_with(FxHashSet::default);
+ let location_set = self.reaching_defs.entry(local).or_default();
location_set.clear();
location_set.insert(DefLocation::Assignment(location));
}
@@ -128,32 +125,27 @@ impl<'mir, 'tcx: 'mir> ReachingDefsState<'mir, 'tcx> {
mir::TerminatorKind::Call {
ref destination,
target,
- cleanup,
+ unwind,
..
} => {
if let Some(bb) = target {
let mut dest_state = self.clone();
if let Some(local) = destination.as_local() {
- let location_set = dest_state
- .reaching_defs
- .entry(local)
- .or_insert_with(FxHashSet::default);
+ let location_set = dest_state.reaching_defs.entry(local).or_default();
location_set.clear();
location_set.insert(DefLocation::Assignment(location));
}
res_vec.push((bb, dest_state));
}
- if let Some(bb) = cleanup {
+ if let mir::UnwindAction::Cleanup(bb) = unwind {
let mut cleanup_state = self.clone();
// error state -> be conservative & add destination as possible reaching def
// while keeping all others
if target.is_some() {
if let Some(local) = destination.as_local() {
- let location_set = cleanup_state
- .reaching_defs
- .entry(local)
- .or_insert_with(FxHashSet::default);
+ let location_set =
+ cleanup_state.reaching_defs.entry(local).or_default();
location_set.insert(DefLocation::Assignment(location));
}
}
@@ -182,10 +174,7 @@ impl<'mir, 'tcx: 'mir> AbstractState for ReachingDefsState<'mir, 'tcx> {
fn join(&mut self, other: &Self) {
for (local, other_locations) in other.reaching_defs.iter() {
- let location_set = self
- .reaching_defs
- .entry(*local)
- .or_insert_with(FxHashSet::default);
+ let location_set = self.reaching_defs.entry(*local).or_default();
location_set.extend(other_locations);
}
}
diff --git a/rr_frontend/analysis/src/mir_utils.rs b/rr_frontend/analysis/src/mir_utils.rs
index e4e253a61e85613008c5f5bbc7841fad892d04de..d11b491105327b745327aa0cc5f9f72fde7df805 100644
--- a/rr_frontend/analysis/src/mir_utils.rs
+++ b/rr_frontend/analysis/src/mir_utils.rs
@@ -7,7 +7,7 @@
//! Various helper functions for working with `mir` types.
//! copied from prusti-interface/utils
-use log::trace;
+//use rustc_abi::FieldIdx;
use rr_rustc_interface::{
data_structures::fx::FxHashSet,
infer::infer::TyCtxtInferExt,
@@ -87,7 +87,7 @@ pub fn location_to_stmt_str(location: mir::Location, mir: &mir::Body) -> String
let bb_mir = &mir[location.block];
if location.statement_index < bb_mir.statements.len() {
let stmt = &bb_mir.statements[location.statement_index];
- format!("{:?}", stmt)
+ format!("{stmt:?}")
} else {
// location = terminator
let terminator = bb_mir.terminator();
@@ -126,68 +126,51 @@ pub fn expand_struct_place<'tcx, P: PlaceImpl<'tcx> + std::marker::Copy>(
) -> Vec<P> {
let mut places: Vec<P> = Vec::new();
let typ = place.to_mir_place().ty(mir, tcx);
- if typ.variant_index.is_some() {
- // Downcast is a no-op.
- } else {
- match typ.ty.kind() {
- ty::Adt(def, substs) => {
- assert!(
- def.is_struct(),
- "Only structs can be expanded. Got def={:?}.",
- def
- );
- let variant = def.non_enum_variant();
- for (index, field_def) in variant.fields.iter().enumerate() {
- if Some(index) != without_field {
- let field = mir::Field::from_usize(index);
- let field_place = tcx.mk_place_field(
- place.to_mir_place(),
- field,
- field_def.ty(tcx, substs),
- );
- places.push(P::from_mir_place(field_place));
- }
+ if !matches!(typ.ty.kind(), ty::Adt(..)) {
+ assert!(
+ typ.variant_index.is_none(),
+ "We have assumed that only enums can have variant_index set. Got {typ:?}."
+ );
+ }
+ match typ.ty.kind() {
+ ty::Adt(def, substs) => {
+ let variant = typ
+ .variant_index
+ .map(|i| def.variant(i))
+ .unwrap_or_else(|| def.non_enum_variant());
+ for (index, field_def) in variant.fields.iter().enumerate() {
+ if Some(index) != without_field {
+ let field_place =
+ tcx.mk_place_field(place.to_mir_place(), index.into(), field_def.ty(tcx, substs));
+ places.push(P::from_mir_place(field_place));
}
}
- ty::Tuple(slice) => {
- for (index, arg) in slice.iter().enumerate() {
- if Some(index) != without_field {
- let field = mir::Field::from_usize(index);
- let field_place = tcx.mk_place_field(place.to_mir_place(), field, arg);
- places.push(P::from_mir_place(field_place));
- }
+ }
+ ty::Tuple(slice) => {
+ for (index, arg) in slice.iter().enumerate() {
+ if Some(index) != without_field {
+ let field_place = tcx.mk_place_field(place.to_mir_place(), index.into(), arg);
+ places.push(P::from_mir_place(field_place));
}
}
- ty::Ref(_region, _ty, _) => match without_field {
- Some(without_field) => {
- assert_eq!(without_field, 0, "References have only a single “fieldâ€.");
- }
- None => {
- places.push(P::from_mir_place(tcx.mk_place_deref(place.to_mir_place())));
- }
- },
- ty::Closure(_, substs) => {
- for (index, subst_ty) in substs.as_closure().upvar_tys().enumerate() {
- if Some(index) != without_field {
- let field = mir::Field::from_usize(index);
- let field_place = tcx.mk_place_field(place.to_mir_place(), field, subst_ty);
- places.push(P::from_mir_place(field_place));
- }
+ }
+ ty::Closure(_, substs) => {
+ for (index, subst_ty) in substs.as_closure().upvar_tys().iter().enumerate() {
+ if Some(index) != without_field {
+ let field_place = tcx.mk_place_field(place.to_mir_place(), index.into(), subst_ty);
+ places.push(P::from_mir_place(field_place));
}
}
- ty::Generator(_, substs, _) => {
- for (index, subst_ty) in substs.as_generator().upvar_tys().enumerate() {
- if Some(index) != without_field {
- let field = mir::Field::from_usize(index);
- let field_place = tcx.mk_place_field(place.to_mir_place(), field, subst_ty);
- places.push(P::from_mir_place(field_place));
- }
+ }
+ ty::Generator(_, substs, _) => {
+ for (index, subst_ty) in substs.as_generator().upvar_tys().iter().enumerate() {
+ if Some(index) != without_field {
+ let field_place = tcx.mk_place_field(place.to_mir_place(), index.into(), subst_ty);
+ places.push(P::from_mir_place(field_place));
}
}
- ref ty => {
- unimplemented!("ty={:?}", ty);
- }
}
+ ty => unreachable!("ty={:?}", ty),
}
places
}
@@ -202,7 +185,7 @@ pub fn expand_one_level<'tcx>(
guide_place: Place<'tcx>,
) -> (Place<'tcx>, Vec<Place<'tcx>>) {
let index = current_place.projection.len();
- let new_projection = tcx.mk_place_elems(
+ let new_projection = tcx.mk_place_elems_from_iter(
current_place
.projection
.iter()
@@ -220,7 +203,8 @@ pub fn expand_one_level<'tcx>(
| mir::ProjectionElem::Index(..)
| mir::ProjectionElem::ConstantIndex { .. }
| mir::ProjectionElem::Subslice { .. }
- | mir::ProjectionElem::Downcast(..) => vec![],
+ | mir::ProjectionElem::Downcast(..)
+ | mir::ProjectionElem::OpaqueCast(..) => vec![],
};
(new_current_place, other_places)
}
@@ -243,23 +227,12 @@ pub(crate) fn expand<'tcx>(
is_prefix(subtrahend, minuend),
"The minuend must be the prefix of the subtrahend."
);
- trace!(
- "[enter] expand minuend={:?} subtrahend={:?}",
- minuend,
- subtrahend
- );
let mut place_set = Vec::new();
while minuend.projection.len() < subtrahend.projection.len() {
let (new_minuend, places) = expand_one_level(mir, tcx, minuend, subtrahend);
minuend = new_minuend;
place_set.extend(places);
}
- trace!(
- "[exit] expand minuend={:?} subtrahend={:?} place_set={:?}",
- minuend,
- subtrahend,
- place_set
- );
place_set
}
@@ -326,21 +299,22 @@ pub fn is_copy<'tcx>(
// `type_implements_trait` doesn't consider that.
matches!(mutability, mir::Mutability::Not)
} else if let Some(copy_trait) = tcx.lang_items().copy_trait() {
- tcx.infer_ctxt().enter(|infcx| {
- // If `ty` has any inference variables (e.g. a region variable), then using it with
- // the freshly-created `InferCtxt` (i.e. `tcx.infer_ctxt().enter(..)`) will cause
- // a panic, since those inference variables don't exist in the new `InferCtxt`.
- // See: https://rust-lang.zulipchat.com/#narrow/stream/182449-t-compiler.2Fhelp/topic/.E2.9C.94.20Panic.20in.20is_copy_modulo_regions
- let fresh_ty = infcx.freshen(ty);
- infcx
- .type_implements_trait(copy_trait, fresh_ty, ty::List::empty(), param_env)
- .must_apply_considering_regions()
- })
+ let infcx = tcx.infer_ctxt().build();
+ // If `ty` has any inference variables (e.g. a region variable), then using it with
+ // the freshly-created `InferCtxt` (i.e. `tcx.infer_ctxt().enter(..)`) will cause
+ // a panic, since those inference variables don't exist in the new `InferCtxt`.
+ // See: https://rust-lang.zulipchat.com/#narrow/stream/182449-t-compiler.2Fhelp/topic/.E2.9C.94.20Panic.20in.20is_copy_modulo_regions
+ infcx
+ .type_implements_trait(copy_trait, [infcx.freshen(ty)], param_env)
+ .must_apply_considering_regions()
} else {
false
}
}
+/// Given an assignment `let _ = & <borrowed_place>`, this function returns the place that is
+/// blocked by the loan.
+/// For example, `let _ = &x.f.g` blocks just `x.f.g`, but `let _ = &x.f[0].g` blocks `x.f`.
pub fn get_blocked_place<'tcx>(tcx: TyCtxt<'tcx>, borrowed: Place<'tcx>) -> Place<'tcx> {
for (place_ref, place_elem) in borrowed.iter_projections() {
match place_elem {
@@ -350,11 +324,13 @@ pub fn get_blocked_place<'tcx>(tcx: TyCtxt<'tcx>, borrowed: Place<'tcx>) -> Plac
| mir::ProjectionElem::Subslice { .. } => {
return (mir::Place {
local: place_ref.local,
- projection: tcx.intern_place_elems(place_ref.projection),
+ projection: tcx.mk_place_elems(place_ref.projection),
})
.into();
}
- mir::ProjectionElem::Field(..) | mir::ProjectionElem::Downcast(..) => {
+ mir::ProjectionElem::Field(..)
+ | mir::ProjectionElem::Downcast(..)
+ | mir::ProjectionElem::OpaqueCast(..) => {
// Continue
}
}
diff --git a/rr_frontend/analysis/src/pointwise_state.rs b/rr_frontend/analysis/src/pointwise_state.rs
index 9921a6871dd46e916c443d1ef0dd03bbc6d80b48..a074c710543ab045e1dc1e1c665560b4e02a612f 100644
--- a/rr_frontend/analysis/src/pointwise_state.rs
+++ b/rr_frontend/analysis/src/pointwise_state.rs
@@ -35,9 +35,9 @@ impl<'mir, 'tcx: 'mir, S: Serialize> Serialize for PointwiseState<'mir, 'tcx, S>
/// Serialize PointwiseState by translating it to a combination of vectors, tuples and maps,
/// such that serde can automatically translate it.
fn serialize<Se: Serializer>(&self, serializer: Se) -> Result<Se::Ok, Se::Error> {
- let mut map = serializer.serialize_map(Some(self.mir.basic_blocks().len()))?;
+ let mut map = serializer.serialize_map(Some(self.mir.basic_blocks.len()))?;
- for bb in self.mir.basic_blocks().indices() {
+ for bb in self.mir.basic_blocks.indices() {
let mir::BasicBlockData { ref statements, .. } = self.mir[bb];
let mut stmt_vec: Vec<_> = Vec::new();
for (statement_index, stmt) in statements.iter().enumerate() {
@@ -138,7 +138,7 @@ impl<'mir, 'tcx: 'mir, S: Serialize> PointwiseState<'mir, 'tcx, S> {
impl<'mir, 'tcx: 'mir, S: Serialize + Default> PointwiseState<'mir, 'tcx, S> {
pub fn default(mir: &'mir mir::Body<'tcx>) -> Self {
let state_before: FxHashMap<_, _> = mir
- .basic_blocks()
+ .basic_blocks
.iter_enumerated()
.flat_map(|(block, bb_data)| {
(0..=bb_data.statements.len()).map(move |statement_index| {
@@ -153,7 +153,7 @@ impl<'mir, 'tcx: 'mir, S: Serialize + Default> PointwiseState<'mir, 'tcx, S> {
})
.collect();
let state_after_block: FxHashMap<_, _> = mir
- .basic_blocks()
+ .basic_blocks
.iter_enumerated()
.map(|(block, bb_data)| {
let successors: FxHashMap<_, _> = bb_data
diff --git a/rr_frontend/rr_rustc_interface/src/lib.rs b/rr_frontend/rr_rustc_interface/src/lib.rs
index fa66662c3e83a36c3188537accab20fa8f067aab..9939d6201876d3de601a5e27e51b32ed7979881e 100644
--- a/rr_frontend/rr_rustc_interface/src/lib.rs
+++ b/rr_frontend/rr_rustc_interface/src/lib.rs
@@ -10,9 +10,11 @@
pub extern crate polonius_engine as polonius_engine;
pub extern crate rustc_ast as ast;
+pub extern crate rustc_abi as abi;
pub extern crate rustc_attr as attr;
pub extern crate rustc_data_structures as data_structures;
pub extern crate rustc_driver as driver;
+pub extern crate rustc_errors as errors;
//pub extern crate rustc_errors as errors;
//pub extern crate rustc_index as index;
pub extern crate rustc_infer as infer;
diff --git a/rr_frontend/rust-version b/rr_frontend/rust-version
index b54ff9e100ed063aab157bd71491cbb319b01e2f..d96e7040aaf73efa0cd7a8016453f95498e1d13e 100644
--- a/rr_frontend/rust-version
+++ b/rr_frontend/rust-version
@@ -1 +1 @@
-41419e70366962c9a878bfe673ef4df38db6f7f1
+c40cfcf0494ff7506e753e750adb00eeea839f9c
diff --git a/rr_frontend/translation/src/caesium/mod.rs b/rr_frontend/translation/src/caesium/mod.rs
index 84ed751df41397d59946d6d3847377556e751ddb..fd87fb7b7e2b3e6fa8671a42824c9c7aea62504c 100644
--- a/rr_frontend/translation/src/caesium/mod.rs
+++ b/rr_frontend/translation/src/caesium/mod.rs
@@ -1108,7 +1108,7 @@ impl<'def> Function<'def> {
out.push_str(format!("{}repeat liRStep; liShow.\n", indent).as_str());
out.push_str(format!("{}all: print_typesystem_goal \"{}\".\n", indent, self.name()).as_str());
- out.push_str(format!("{}Unshelve. all: li_unshelve_sidecond; sidecond_hook.\n", indent).as_str());
+ out.push_str(format!("{}Unshelve. all: unshelve_sidecond; sidecond_hook.\n", indent).as_str());
out.push_str(format!("{}Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; try (unfold_common_defs; solve_goal); unsolved_sidecond_hook.\n", indent).as_str());
// add custom tactics specified in annotations
@@ -1270,7 +1270,7 @@ impl<'def> Into<Function<'def>> for FunctionBuilder<'def> {
self.spec.add_coq_param(CoqName::Named(names.rt_name.to_string()), CoqType::Type, false).unwrap();
self.spec.add_coq_param(CoqName::Unnamed, CoqType::Literal(format!("Inhabited {}", names.rt_name)), true).unwrap();
self.spec.add_coq_param(CoqName::Named(st_name.to_string()), CoqType::SynType, false).unwrap();
- self.spec.add_param(CoqName::Named(names.ty_name.clone()), CoqType::Ttype(box (CoqType::Literal(names.rt_name.clone())))).unwrap();
+ self.spec.add_param(CoqName::Named(names.ty_name.clone()), CoqType::Ttype(Box::new (CoqType::Literal(names.rt_name.clone())))).unwrap();
// Add assumptions that the syntactic type of the semantic argument matches with the
// assumed syntactic type.
diff --git a/rr_frontend/translation/src/caesium/specs.rs b/rr_frontend/translation/src/caesium/specs.rs
index 997bc678ef65ed46db7b94a8501c3eae2e1af559..8a8b9cda8afd4288b232fbfe38bf7db765d94a1b 100644
--- a/rr_frontend/translation/src/caesium/specs.rs
+++ b/rr_frontend/translation/src/caesium/specs.rs
@@ -623,11 +623,11 @@ impl<'def> Type<'def> {
Self::Int(_) => CoqType::Z,
Self::Bool => CoqType::Bool,
Self::MutRef(box ty, _) =>
- CoqType::Prod(vec![CoqType::PlaceRfn(box (ty.get_rfn_type(env))), CoqType::Gname]),
+ CoqType::Prod(vec![CoqType::PlaceRfn(Box::new (ty.get_rfn_type(env))), CoqType::Gname]),
Self::ShrRef(box ty, _) =>
- CoqType::PlaceRfn(box (ty.get_rfn_type(env))),
+ CoqType::PlaceRfn(Box::new (ty.get_rfn_type(env))),
Self::BoxType(box ty) =>
- CoqType::PlaceRfn(box (ty.get_rfn_type(env))),
+ CoqType::PlaceRfn(Box::new (ty.get_rfn_type(env))),
Self::Literal(_, _, t, _) => t.clone(),
Self::Uninit(_) => CoqType::Unit,
Self::Struct(su, _) =>
@@ -740,7 +740,6 @@ pub enum InvariantSpecFlags {
Persistent,
/// invariant with own sharing predicate,
Plain,
- // TODO not implemented
NonAtomic,
Atomic,
}
@@ -1459,7 +1458,7 @@ impl<'def> AbstractStructUse<'def> {
}
// use_struct_layout_alg' ([my_spec] [params])
- let specialized_spec = format!("({})", CoqAppTerm::new(def.borrow().as_ref().unwrap().sls_def_name().clone(), param_sts));
+ let specialized_spec = format!("({})", CoqAppTerm::new(def.borrow().as_ref().unwrap().sls_def_name(), param_sts));
CoqAppTerm::new("use_struct_layout_alg'".to_string(), vec![specialized_spec]).to_string()
}
else {
@@ -1477,7 +1476,7 @@ impl<'def> AbstractStructUse<'def> {
}
// use_struct_layout_alg' ([my_spec] [params])
- let specialized_spec = format!("({})", CoqAppTerm::new(def.borrow().as_ref().unwrap().sls_def_name().clone(), param_sts));
+ let specialized_spec = format!("({})", CoqAppTerm::new(def.borrow().as_ref().unwrap().sls_def_name(), param_sts));
specialized_spec.to_string()
}
else {
@@ -1496,7 +1495,7 @@ impl<'def> AbstractStructUse<'def> {
}
// syn_type_of_sls ([my_spec] [params])
- let specialized_spec = format!("({})", CoqAppTerm::new(def.borrow().as_ref().unwrap().sls_def_name().clone(), param_sts));
+ let specialized_spec = format!("({})", CoqAppTerm::new(def.borrow().as_ref().unwrap().sls_def_name(), param_sts));
SynType::Literal(CoqAppTerm::new("syn_type_of_sls".to_string(), vec![specialized_spec]))
}
else {
@@ -1514,12 +1513,17 @@ impl<'def> AbstractStructUse<'def> {
}
let def = def.borrow();
let def = def.as_ref().unwrap();
- if raw == TypeIsRaw::No && let Some(ref inv) = def.invariant {
- let term = CoqAppTerm::new(inv.type_name.clone(), param_tys);
- term.to_string()
+ if raw == TypeIsRaw::No && def.invariant.is_some() {
+ if let Some(ref inv) = def.invariant {
+ let term = CoqAppTerm::new(inv.type_name.clone(), param_tys);
+ term.to_string()
+ }
+ else {
+ unreachable!();
+ }
}
else {
- let term = CoqAppTerm::new(def.plain_ty_name().clone(), param_tys);
+ let term = CoqAppTerm::new(def.plain_ty_name(), param_tys);
term.to_string()
}
}
@@ -1534,8 +1538,7 @@ impl<'def> AbstractStructUse<'def> {
pub struct EnumSpec {
/// the refinement type of the enum
pub rfn_type: CoqType,
- /// the refinement patterns for each of the variants: pattern for destructing an element of
- /// `rfn_type`, and a term for constructing a term of the variant's refinement
+ /// the refinement patterns for each of the variants
pub variant_patterns: Vec<(String, String)>,
}
@@ -1643,11 +1646,8 @@ impl<'def> AbstractEnum<'def> {
write!(out, "(\"{}\", {})", name, discr).unwrap();
}
- out.push_str("] _ _ _.\n");
-
+ out.push_str("] _.\n");
write!(out, "{indent}Next Obligation. done. Qed.\n").unwrap();
- write!(out, "{indent}Next Obligation. repeat first [econstructor | set_solver]. Qed.\n").unwrap();
- write!(out, "{indent}Next Obligation. repeat first [econstructor | solve_goal]. Qed.\n").unwrap();
write!(out, "Global Typeclasses Opaque {}.\n", self.els_def_name).unwrap();
// finish
diff --git a/rr_frontend/translation/src/checked_op_analysis.rs b/rr_frontend/translation/src/checked_op_analysis.rs
index 0b06b79a07b7d130b6b451343920f43d66b5822c..bb3634d2e1006b671610eb3498a716f70dc68a69 100644
--- a/rr_frontend/translation/src/checked_op_analysis.rs
+++ b/rr_frontend/translation/src/checked_op_analysis.rs
@@ -61,13 +61,10 @@ impl<'def, 'tcx> CheckedOpLocalAnalysis<'def, 'tcx> {
res.push(*target);
}
},
- TerminatorKind::Drop { place: _, target, unwind: _ } => {
+ TerminatorKind::Drop { place: _, target, unwind: _ , replace: _} => {
res.push(*target);
},
- TerminatorKind::DropAndReplace { place: _, value: _, target, unwind: _ } => {
- res.push(*target);
- },
- TerminatorKind::SwitchInt { discr: _, switch_ty: _, targets } => {
+ TerminatorKind::SwitchInt { discr: _, targets } => {
for target in targets.all_targets() {
res.push(*target);
}
@@ -75,13 +72,13 @@ impl<'def, 'tcx> CheckedOpLocalAnalysis<'def, 'tcx> {
TerminatorKind::Goto { target } => {
res.push(*target);
},
- TerminatorKind::Assert { cond: _, expected: _, msg: _, target, cleanup: _ } => {
+ TerminatorKind::Assert { cond: _, expected: _, msg: _, target, unwind: _} => {
res.push(*target);
},
TerminatorKind::Yield { value: _, resume, resume_arg: _, drop: _ } => {
res.push(*resume);
},
- TerminatorKind::InlineAsm { template: _, operands: _, options: _, line_spans: _, destination, cleanup: _ } => {
+ TerminatorKind::InlineAsm { template: _, operands: _, options: _, line_spans: _, destination, unwind: _} => {
if let Some(dest) = destination {
res.push(*dest);
}
diff --git a/rr_frontend/translation/src/environment/borrowck/facts.rs b/rr_frontend/translation/src/environment/borrowck/facts.rs
index 256ef07b2c0aea81b42e0a9d6271c7bc09bb0981..4124bde8040d172bcfab02d5f12e9968f4804279 100644
--- a/rr_frontend/translation/src/environment/borrowck/facts.rs
+++ b/rr_frontend/translation/src/environment/borrowck/facts.rs
@@ -33,7 +33,7 @@ impl LocationTableExt for LocationTable {
pub struct BorrowckFacts {
/// Polonius input facts.
- pub input_facts: RefCell<Option<AllInputFacts>>,
+ pub input_facts: RefCell<Option<Box<AllInputFacts>>>,
/// Polonius output facts.
pub output_facts: Rc<AllOutputFacts>,
/// The table that maps Polonius points to locations in the table.
diff --git a/rr_frontend/translation/src/environment/borrowck/regions.rs b/rr_frontend/translation/src/environment/borrowck/regions.rs
index 95311a205a0bb4fd75f499ca65c711558527916d..a107e9cfaf6fa3caef876cd002c96088a5568ab2 100644
--- a/rr_frontend/translation/src/environment/borrowck/regions.rs
+++ b/rr_frontend/translation/src/environment/borrowck/regions.rs
@@ -88,6 +88,12 @@ impl PlaceRegions {
not supported".to_string()
))
}
+ mir::ProjectionElem::OpaqueCast(_) => {
+ Err(PlaceRegionsError::Unsupported(
+ "determining the region of an opaque cast is \
+ not supported".to_string()
+ ))
+ }
})
.collect::<Result<_, _>>()?;
Ok((place.local, indices))
diff --git a/rr_frontend/translation/src/environment/collect_closure_defs_visitor.rs b/rr_frontend/translation/src/environment/collect_closure_defs_visitor.rs
index 6efe1e7336d494c78fd11c3738cfbc828fc738c0..96c9588ecfa693fa81c672ed9cca1bec5c32702c 100644
--- a/rr_frontend/translation/src/environment/collect_closure_defs_visitor.rs
+++ b/rr_frontend/translation/src/environment/collect_closure_defs_visitor.rs
@@ -37,12 +37,14 @@ impl<'env, 'tcx> Visitor<'tcx> for CollectClosureDefsVisitor<'env, 'tcx> {
}
fn visit_expr(&mut self, expr: &'tcx hir::Expr<'tcx>) {
- if let hir::ExprKind::Closure(_) = expr.kind {
+ if let hir::ExprKind::Closure(hir::Closure {
+ def_id: local_def_id,
+ ..
+ }) = expr.kind {
let _tcx = self.env.tcx();
- let def_id = self.map.local_def_id(expr.hir_id);
- let item_def_path = self.env.get_item_def_path(def_id.to_def_id());
+ let item_def_path = self.env.get_item_def_path(local_def_id.to_def_id());
trace!("Add {} to result", item_def_path);
- self.result.push(def_id);
+ self.result.push(*local_def_id);
}
walk_expr (self, expr)
diff --git a/rr_frontend/translation/src/environment/collect_prusti_spec_visitor.rs b/rr_frontend/translation/src/environment/collect_prusti_spec_visitor.rs
index 2e5f2366069a6780db9908b63c163673c3776086..9fc96042028d0bed118ac32994513f721ce93cc0 100644
--- a/rr_frontend/translation/src/environment/collect_prusti_spec_visitor.rs
+++ b/rr_frontend/translation/src/environment/collect_prusti_spec_visitor.rs
@@ -51,12 +51,12 @@ impl<'a, 'tcx> Visitor<'tcx> for CollectPrustiSpecVisitor<'a, 'tcx> {
fn visit_item(&mut self, item: &hir::Item) {
//let attrs = self.tcx.get_attrs(item.def_id.to_def_id());
if let hir::ItemKind::Fn(..) = item.kind {
- let def_id = self.tcx.hir().local_def_id(item.hir_id());
+ let def_id = item.hir_id().owner.def_id;
let item_def_path = self.env.get_item_def_path(def_id.to_def_id());
trace!("Add {} to result", item_def_path);
self.result.push(def_id);
}
- else if let hir::ItemKind::Const(_, _) = item.kind {
+ else if let hir::ItemKind::Const(_, _, _) = item.kind {
}
}
@@ -75,7 +75,7 @@ impl<'a, 'tcx> Visitor<'tcx> for CollectPrustiSpecVisitor<'a, 'tcx> {
if let hir::TraitItemKind::Fn(_, hir::TraitFn::Required(_)) = trait_item.kind {
return;
}
- let def_id = self.tcx.hir().local_def_id(trait_item.hir_id());
+ let def_id = trait_item.hir_id().owner.def_id;
let item_def_path = self.env.get_item_def_path(def_id.to_def_id());
trace!("Add {} to result", item_def_path);
self.result.push(def_id);
@@ -91,7 +91,7 @@ impl<'a, 'tcx> Visitor<'tcx> for CollectPrustiSpecVisitor<'a, 'tcx> {
return;
}
- let def_id = self.tcx.hir().local_def_id(impl_item.hir_id());
+ let def_id = impl_item.hir_id().owner.def_id;
let item_def_path = self.env.get_item_def_path(def_id.to_def_id());
trace!("Add {} to result", item_def_path);
self.result.push(def_id);
diff --git a/rr_frontend/translation/src/environment/dump_borrowck_info.rs b/rr_frontend/translation/src/environment/dump_borrowck_info.rs
index 5da8ba4fdd4189bfa090d1620bd7e51900b374d2..be0c85131fe7f405290498356019205bf5bcb857 100644
--- a/rr_frontend/translation/src/environment/dump_borrowck_info.rs
+++ b/rr_frontend/translation/src/environment/dump_borrowck_info.rs
@@ -16,7 +16,7 @@ use crate::data::ProcedureDefId;
use rustc_hir as hir;
use rustc_middle::mir;
use rustc_middle::ty::TyCtxt;
-use rustc_index::vec::Idx;
+use rustc_index::Idx;
use rustc_hash::FxHashMap;
use std::cell;
use std::collections::{BTreeMap, BTreeSet, HashSet, HashMap};
@@ -303,7 +303,7 @@ impl<'a, 'tcx> MirInfoPrinter<'a, 'tcx> {
//&self.polonius_info.additional_facts.zombie_requires);
write_graph!(self, "digraph G {{\n");
- for bb in self.mir.basic_blocks().indices() {
+ for bb in self.mir.basic_blocks.indices() {
self.visit_basic_block(bb)?;
}
self.print_temp_variables()?;
@@ -878,46 +878,43 @@ impl<'a, 'tcx> MirInfoPrinter<'a, 'tcx> {
write_edge!(self, bb, target);
}
}
- TerminatorKind::Resume => {
- write_edge!(self, bb, str resume);
- }
- TerminatorKind::Abort => {
- write_edge!(self, bb, str abort);
- }
TerminatorKind::Return => {
write_edge!(self, bb, str return);
}
TerminatorKind::Unreachable => {}
- TerminatorKind::DropAndReplace {
- ref target, unwind, ..
+ TerminatorKind::UnwindResume => {
+ write_edge!(self, bb, str resume);
+ }
+ TerminatorKind::UnwindTerminate => {
+ write_edge!(self, bb, str terminate);
}
| TerminatorKind::Drop {
ref target, unwind, ..
} => {
write_edge!(self, bb, target);
- if let Some(target) = unwind {
- write_edge!(self, bb, unwind target);
- }
+ //if let Some(target) = unwind {
+ //write_edge!(self, bb, unwind target);
+ //}
}
TerminatorKind::Call {
ref target,
- cleanup,
+ unwind,
..
} => {
if let Some(target) = *target {
write_edge!(self, bb, target);
}
- if let Some(target) = cleanup {
- write_edge!(self, bb, unwind target);
- }
+ //if let Some(target) = unwind {
+ //write_edge!(self, bb, unwind target);
+ //}
}
TerminatorKind::Assert {
- target, cleanup, ..
+ target, unwind, ..
} => {
write_edge!(self, bb, target);
- if let Some(target) = cleanup {
- write_edge!(self, bb, unwind target);
- }
+ //if let Some(target) = unwind {
+ //write_edge!(self, bb, unwind target);
+ //}
}
TerminatorKind::Yield { .. } => unimplemented!(),
TerminatorKind::GeneratorDrop => unimplemented!(),
@@ -933,9 +930,9 @@ impl<'a, 'tcx> MirInfoPrinter<'a, 'tcx> {
unwind,
} => {
write_edge!(self, bb, real_target);
- if let Some(target) = unwind {
- write_edge!(self, bb, imaginary target);
- }
+ //if let Some(target) = unwind {
+ //write_edge!(self, bb, imaginary target);
+ //}
}
TerminatorKind::InlineAsm { .. } => unimplemented!(),
};
diff --git a/rr_frontend/translation/src/environment/loops.rs b/rr_frontend/translation/src/environment/loops.rs
index a9b6cc1cc38b1c4c44f1de5aeaeb5dd500100ccb..8ba015098046cf7e1b6125b92965f177b64e105e 100644
--- a/rr_frontend/translation/src/environment/loops.rs
+++ b/rr_frontend/translation/src/environment/loops.rs
@@ -11,7 +11,7 @@ use rustc_middle::mir;
use rustc_middle::mir::visit::Visitor;
use rustc_data_structures::graph::dominators::{Dominators, dominators};
use std::collections::{HashMap, HashSet};
-use rustc_index::vec::{Idx, IndexVec};
+use rustc_index::{Idx, IndexVec};
use log::{debug, trace};
use crate::environment::mir_utils::RealEdges;
@@ -133,7 +133,7 @@ fn order_basic_blocks<'tcx>(
back_edges: &HashSet<(BasicBlockIndex, BasicBlockIndex)>,
loop_depth: &dyn Fn(BasicBlockIndex) -> usize,
) -> Vec<BasicBlockIndex> {
- let basic_blocks = mir.basic_blocks();
+ let basic_blocks = &mir.basic_blocks;
let mut sorted_blocks = Vec::new();
let mut permanent_mark =
IndexVec::<BasicBlockIndex, bool>::from_elem_n(false, basic_blocks.len());
@@ -141,7 +141,6 @@ fn order_basic_blocks<'tcx>(
#[allow(clippy::too_many_arguments)]
fn visit<'tcx>(
- basic_blocks: &IndexVec<BasicBlockIndex, mir::BasicBlockData<'tcx>>,
real_edges: &RealEdges,
back_edges: &HashSet<(BasicBlockIndex, BasicBlockIndex)>,
loop_depth: &dyn Fn(BasicBlockIndex) -> usize,
@@ -171,7 +170,6 @@ fn order_basic_blocks<'tcx>(
continue;
}
visit(
- basic_blocks,
real_edges,
back_edges,
loop_depth,
@@ -189,7 +187,6 @@ fn order_basic_blocks<'tcx>(
while let Some(index) = permanent_mark.iter().position(|x| !*x) {
let index = BasicBlockIndex::new(index);
visit(
- basic_blocks,
real_edges,
back_edges,
loop_depth,
@@ -234,9 +231,9 @@ impl ProcedureLoops {
let dominators = dominators(&mir.basic_blocks);
let mut back_edges: HashSet<(_, _)> = HashSet::new();
- for bb in mir.basic_blocks().indices() {
+ for bb in mir.basic_blocks.indices() {
for successor in real_edges.successors(bb) {
- if dominators.is_dominated_by(bb, *successor) {
+ if dominators.dominates(*successor, bb) {
back_edges.insert((bb, *successor));
debug!("Loop head: {:?}", successor);
}
@@ -440,7 +437,7 @@ impl ProcedureLoops {
/// Check if ``block`` is inside a given loop.
pub fn is_block_in_loop(&self, loop_head: BasicBlockIndex, block: BasicBlockIndex) -> bool {
- self.dominators.is_dominated_by(block, loop_head)
+ self.dominators.dominates(loop_head, block)
}
/// Compute what paths that are accessed inside the loop.
diff --git a/rr_frontend/translation/src/environment/mir_analyses/allocation.rs b/rr_frontend/translation/src/environment/mir_analyses/allocation.rs
index 1b75b9a5f1030d71952e70c986f8f5745867e89b..9194fd110a7d3a650c06dd78d9bc2f4ac286b898 100644
--- a/rr_frontend/translation/src/environment/mir_analyses/allocation.rs
+++ b/rr_frontend/translation/src/environment/mir_analyses/allocation.rs
@@ -44,7 +44,7 @@ pub fn compute_definitely_allocated<'a, 'tcx: 'a>(
// Convert the pointwise_state to analysis_result.
// TODO: Replace AnalysisResult with PointwiseState, to avoid this conversion.
let mut analysis_result = AnalysisResult::new();
- for (bb, bb_data) in body.basic_blocks().iter_enumerated() {
+ for (bb, bb_data) in body.basic_blocks.iter_enumerated() {
let num_statements = bb_data.statements.len();
let mut location = bb.start_location();
analysis_result.before_block.insert(
diff --git a/rr_frontend/translation/src/environment/mir_analyses/initialization.rs b/rr_frontend/translation/src/environment/mir_analyses/initialization.rs
index 1d77bb08be1916227f1164c10ab21d2f8f462212..180411156a3e7288d73b2001fd82f0481a6d2b47 100644
--- a/rr_frontend/translation/src/environment/mir_analyses/initialization.rs
+++ b/rr_frontend/translation/src/environment/mir_analyses/initialization.rs
@@ -83,7 +83,7 @@ pub fn compute_definitely_initialized<'a, 'tcx: 'a>(
// Convert the pointwise_state to analysis_result.
// TODO: Replace AnalysisResult with PointwiseState, to avoid this conversion.
let mut analysis_result = AnalysisResult::new();
- for (bb, bb_data) in body.basic_blocks().iter_enumerated() {
+ for (bb, bb_data) in body.basic_blocks.iter_enumerated() {
let num_statements = bb_data.statements.len();
let mut location = bb.start_location();
analysis_result.before_block.insert(
diff --git a/rr_frontend/translation/src/environment/mir_storage.rs b/rr_frontend/translation/src/environment/mir_storage.rs
index c0d6cca19743c3709338c4cefd0a690cc0acf812..665a04cc57e4b5f9e021323772288a89fc2a34fb 100644
--- a/rr_frontend/translation/src/environment/mir_storage.rs
+++ b/rr_frontend/translation/src/environment/mir_storage.rs
@@ -14,7 +14,7 @@
use rustc_hir::def_id::LocalDefId;
use rustc_middle::ty::TyCtxt;
-use rustc_borrowck::BodyWithBorrowckFacts;
+use rustc_borrowck::consumers::BodyWithBorrowckFacts;
use std::{cell::RefCell, collections::HashMap, thread_local};
thread_local! {
diff --git a/rr_frontend/translation/src/environment/mir_utils/all_places.rs b/rr_frontend/translation/src/environment/mir_utils/all_places.rs
index 0ce813de308d7f7c4e0fc7f73cf2f41101d70028..1c934101b5d79bc3782a1bb2fa7940164a660145 100644
--- a/rr_frontend/translation/src/environment/mir_utils/all_places.rs
+++ b/rr_frontend/translation/src/environment/mir_utils/all_places.rs
@@ -4,7 +4,6 @@
// License, v. 2.0. If a copy of the MPL was not distributed with this
// file, You can obtain one at http://mozilla.org/MPL/2.0/.
-use rustc_index::vec::Idx;
use rustc_middle::mir;
use rustc_middle::ty;
@@ -21,8 +20,7 @@ impl<'tcx> AllPlaces<'tcx> for mir::Local {
let ty = mir.local_decls[self].ty;
if let ty::TyKind::Tuple(types) = ty.kind() {
for (i, ty) in types.iter().enumerate() {
- let field = mir::Field::new(i);
- let place = tcx.mk_place_field(self.into(), field, ty);
+ let place = tcx.mk_place_field(self.into(), i.into(), ty);
places.push(place);
}
}
diff --git a/rr_frontend/translation/src/environment/mir_utils/args_for_mir.rs b/rr_frontend/translation/src/environment/mir_utils/args_for_mir.rs
index ba9fda5813530174b88575d3fb00074442d1153d..87b7850b24fa6c31df5324eae6c06397d5d30f0d 100644
--- a/rr_frontend/translation/src/environment/mir_utils/args_for_mir.rs
+++ b/rr_frontend/translation/src/environment/mir_utils/args_for_mir.rs
@@ -4,7 +4,7 @@
// License, v. 2.0. If a copy of the MPL was not distributed with this
// file, You can obtain one at http://mozilla.org/MPL/2.0/.
-use rustc_index::vec::Idx;
+use rustc_index::Idx;
use rustc_middle::mir;
use rustc_middle::ty;
diff --git a/rr_frontend/translation/src/environment/mir_utils/real_edges.rs b/rr_frontend/translation/src/environment/mir_utils/real_edges.rs
index 8d5e00c0693313169fec9e43e043c7adf986db87..0654fbc15506848f8bb13a0c3babd31c868fdeef 100644
--- a/rr_frontend/translation/src/environment/mir_utils/real_edges.rs
+++ b/rr_frontend/translation/src/environment/mir_utils/real_edges.rs
@@ -5,7 +5,7 @@
// file, You can obtain one at http://mozilla.org/MPL/2.0/.
use rustc_middle::mir::{self, TerminatorKind};
-use rustc_index::vec::IndexVec;
+use rustc_index::IndexVec;
/// A data structure to store the non-virtual CFG edges of a MIR body.
pub struct RealEdges {
@@ -16,11 +16,11 @@ pub struct RealEdges {
impl RealEdges {
pub fn new(body: &mir::Body) -> Self {
let mut successors: IndexVec<_, Vec<_>> =
- body.basic_blocks().iter().map(|_| Vec::new()).collect();
+ body.basic_blocks.iter().map(|_| Vec::new()).collect();
let mut predecessors: IndexVec<_, Vec<_>> =
- body.basic_blocks().iter().map(|_| Vec::new()).collect();
+ body.basic_blocks.iter().map(|_| Vec::new()).collect();
- for (bb, bb_data) in body.basic_blocks().iter_enumerated() {
+ for (bb, bb_data) in body.basic_blocks.iter_enumerated() {
let targets = real_targets(bb_data.terminator());
for &target in &targets {
successors[bb].push(target);
@@ -54,13 +54,12 @@ fn real_targets(terminator: &mir::Terminator) -> Vec<mir::BasicBlock> {
targets.all_targets().to_vec()
}
- TerminatorKind::Resume
- | TerminatorKind::Abort
+ | TerminatorKind::UnwindResume
+ | TerminatorKind::UnwindTerminate
| TerminatorKind::Return
| TerminatorKind::GeneratorDrop
| TerminatorKind::Unreachable => vec![],
- TerminatorKind::DropAndReplace { ref target, .. }
| TerminatorKind::Drop { ref target, .. } => vec![*target],
TerminatorKind::Call {
diff --git a/rr_frontend/translation/src/environment/mir_utils/split_aggregate_assignment.rs b/rr_frontend/translation/src/environment/mir_utils/split_aggregate_assignment.rs
index f0701ffe29da12fa4b70090dcb1a69ecdf685e33..01bc5bcdc7d2c267b4c3eb890af3353d87a8a47d 100644
--- a/rr_frontend/translation/src/environment/mir_utils/split_aggregate_assignment.rs
+++ b/rr_frontend/translation/src/environment/mir_utils/split_aggregate_assignment.rs
@@ -4,7 +4,6 @@
// License, v. 2.0. If a copy of the MPL was not distributed with this
// file, You can obtain one at http://mozilla.org/MPL/2.0/.
-use rustc_index::vec::Idx;
use rustc_middle::mir;
use rustc_middle::ty;
@@ -53,8 +52,7 @@ impl<'tcx> SplitAggregateAssignment<'tcx> for mir::Statement<'tcx> {
operands.into_iter().zip(items_ty.into_iter())
.enumerate()
.map(|(i, (rhs, ty))| {
- let field = mir::Field::new(i);
- let lhs = tcx.mk_place_field(local.into(), field, ty);
+ let lhs = tcx.mk_place_field(local.into(), i.into(), ty);
let rhs = mir::Rvalue::Use(rhs);
(lhs, rhs)
})
@@ -63,7 +61,7 @@ impl<'tcx> SplitAggregateAssignment<'tcx> for mir::Statement<'tcx> {
mir::Rvalue::Use(_) |
mir::Rvalue::Ref(_, _, _) => vec![(lhs, rhs)],
// slice creation is ok
- mir::Rvalue::Cast(mir::CastKind::Pointer(ty::adjustment::PointerCast::Unsize), _, ty)
+ mir::Rvalue::Cast(mir::CastKind::PointerCoercion(ty::adjustment::PointerCoercion::Unsize), _, ty)
if ty.is_slice() && !ty.is_unsafe_ptr() => vec![(lhs, rhs)],
_ => unreachable!("Rvalue {:?} is not supported", rhs)
};
@@ -71,7 +69,7 @@ impl<'tcx> SplitAggregateAssignment<'tcx> for mir::Statement<'tcx> {
let source_info = self.source_info;
atomic_assignments.into_iter()
.map(|(lhs, rhs)| {
- let kind = mir::StatementKind::Assign(box (lhs, rhs));
+ let kind = mir::StatementKind::Assign(Box::new ((lhs, rhs)));
mir::Statement { source_info, kind }
})
.collect()
diff --git a/rr_frontend/translation/src/environment/mod.rs b/rr_frontend/translation/src/environment/mod.rs
index efba37c394b2df1f4417cc98b62184e8608a324d..a93e45abfd754ce63bf9e36bbfcf5fb6d8370bb7 100644
--- a/rr_frontend/translation/src/environment/mod.rs
+++ b/rr_frontend/translation/src/environment/mod.rs
@@ -66,7 +66,7 @@ impl<'tcx> Environment<'tcx> {
/// Returns the path of the source that is being compiled
pub fn source_path(&self) -> PathBuf {
- self.tcx.sess.local_crate_source_file.clone().unwrap()
+ self.tcx.sess.local_crate_source_file().unwrap()
}
/// Returns the file name of the source that is being compiled
@@ -88,10 +88,10 @@ impl<'tcx> Environment<'tcx> {
}
/// Returns the type of a `HirId`
- pub fn hir_id_to_type(&self, hir_id: HirId) -> ty::Ty<'tcx> {
- let def_id = self.tcx.hir().local_def_id(hir_id);
- self.tcx.type_of(def_id)
- }
+ //pub fn hir_id_to_type(&self, hir_id: HirId) -> ty::EarlyBinder<ty::Ty<'tcx>> {
+ //let def_id = self.tcx.hir().local_def_id(hir_id);
+ //self.tcx.type_of(def_id)
+ //}
/// Returns the `CodeMap`
pub fn codemap(&self) -> &'tcx SourceMap {
@@ -231,9 +231,9 @@ impl<'tcx> Environment<'tcx> {
};
let body = body_with_facts.body;
let facts = BorrowckFacts {
- input_facts: RefCell::new(Some(body_with_facts.input_facts)),
- output_facts: body_with_facts.output_facts,
- location_table: RefCell::new(Some(body_with_facts.location_table)),
+ input_facts: RefCell::new(body_with_facts.input_facts),
+ output_facts: body_with_facts.output_facts.unwrap(),
+ location_table: RefCell::new(body_with_facts.location_table),
};
let mut borrowck_facts = self.borrowck_facts.borrow_mut();
@@ -393,6 +393,7 @@ impl<'tcx> Environment<'tcx> {
}
*/
+ /*
fn primitive_type_implements_trait(
&self,
ty: ty::Ty<'tcx>,
@@ -406,4 +407,5 @@ impl<'tcx> Environment<'tcx> {
.must_apply_considering_regions()
)
}
+*/
}
diff --git a/rr_frontend/translation/src/environment/polonius_info.rs b/rr_frontend/translation/src/environment/polonius_info.rs
index 581d040be9a17dace03ee6dab0f5809d279fd61d..8a6520a41c37c6f2d5841e18c1e11d856a9d073e 100644
--- a/rr_frontend/translation/src/environment/polonius_info.rs
+++ b/rr_frontend/translation/src/environment/polonius_info.rs
@@ -16,7 +16,7 @@ use log::trace;
use polonius_engine::Algorithm;
use polonius_engine::Output;
use rustc_data_structures::fx::FxHashMap;
-use rustc_index::vec::Idx;
+use rustc_index::Idx;
use rustc_middle::mir;
use rustc_middle::ty;
use rustc_span::def_id::DefId;
@@ -381,7 +381,7 @@ fn get_borrowed_places<'a, 'tcx: 'a>(
.collect())
}
// slice creation involves an unsize pointer cast like [i32; 3] -> &[i32]
- &mir::Rvalue::Cast(mir::CastKind::Pointer(ty::adjustment::PointerCast::Unsize), ref operand, ref ty) if ty.is_slice() && !ty.is_unsafe_ptr() => {
+ &mir::Rvalue::Cast(mir::CastKind::PointerCoercion(ty::adjustment::PointerCoercion::Unsize), ref operand, ref ty) if ty.is_slice() && !ty.is_unsafe_ptr() => {
trace!("slice: operand={:?}, ty={:?}", operand, ty);
Ok(match operand {
mir::Operand::Copy(ref place) |
@@ -493,7 +493,7 @@ impl<'a, 'tcx: 'a> PoloniusInfo<'a, 'tcx> {
let output = Output::compute(&all_facts, Algorithm::Naive, true);
let all_facts_without_back_edges = remove_back_edges(
- all_facts.clone(),
+ *all_facts.clone(),
&interner,
&loop_info.back_edges,
);
@@ -531,7 +531,7 @@ impl<'a, 'tcx: 'a> PoloniusInfo<'a, 'tcx> {
let info = Self {
tcx,
mir,
- borrowck_in_facts: all_facts,
+ borrowck_in_facts: *all_facts,
borrowck_out_facts: output,
interner,
loan_position,
diff --git a/rr_frontend/translation/src/environment/procedure.rs b/rr_frontend/translation/src/environment/procedure.rs
index 92fe391a562b342cf119e7cfa2836ce073c0329c..835ef379df94720069940847000cdc3ec73f8a30 100644
--- a/rr_frontend/translation/src/environment/procedure.rs
+++ b/rr_frontend/translation/src/environment/procedure.rs
@@ -9,7 +9,6 @@ use crate::data::ProcedureDefId;
use rustc_middle::mir::{self, Body as Mir};
use rustc_middle::mir::{BasicBlock, TerminatorKind};
use rustc_middle::ty::{self, Ty, TyCtxt};
-use rustc_middle::ty::subst::SubstsRef;
use std::rc::Rc;
use std::collections::{HashSet, HashMap};
use rustc_span::Span;
@@ -24,7 +23,7 @@ pub type BasicBlockIndex = mir::BasicBlock;
pub struct Procedure<'tcx> {
tcx: TyCtxt<'tcx>,
proc_def_id: ProcedureDefId,
- ty_params: ty::subst::SubstsRef<'tcx>,
+ ty_params: ty::GenericArgsRef<'tcx>,
mir: Rc<Mir<'tcx>>,
real_edges: RealEdges,
loop_info: loops::ProcedureLoops,
@@ -44,7 +43,7 @@ impl<'tcx> Procedure<'tcx> {
//let nonspec_basic_blocks = build_nonspec_basic_blocks(&mir, &real_edges, &tcx);
let loop_info = loops::ProcedureLoops::new(&mir, &real_edges);
- let ty = tcx.type_of(proc_def_id);
+ let ty = tcx.type_of(proc_def_id).instantiate_identity();
let ty_params = match ty.kind() {
ty::TyKind::FnDef(_, params) => params,
_ => panic!(""),
@@ -98,7 +97,7 @@ impl<'tcx> Procedure<'tcx> {
}
/// Get the type parameters of this procedure.
- pub fn get_type_params(&self) -> SubstsRef<'tcx> {
+ pub fn get_type_params(&self) -> ty::GenericArgsRef<'tcx> {
self.ty_params
}
@@ -127,7 +126,7 @@ impl<'tcx> Procedure<'tcx> {
/// Get the first CFG block
pub fn get_first_cfg_block(&self) -> BasicBlock {
- self.mir.basic_blocks().indices().next().unwrap()
+ self.mir.basic_blocks.indices().next().unwrap()
}
/// Iterate over all CFG basic blocks
@@ -205,7 +204,7 @@ impl<'tcx> Procedure<'tcx> {
fn build_reachable_basic_blocks(mir: &Mir, real_edges: &RealEdges) -> HashSet<BasicBlock> {
let mut reachable_basic_blocks: HashSet<BasicBlock> = HashSet::new();
let mut visited: HashSet<BasicBlock> = HashSet::new();
- let mut to_visit: Vec<BasicBlock> = vec![mir.basic_blocks().indices().next().unwrap()];
+ let mut to_visit: Vec<BasicBlock> = vec![mir.basic_blocks.indices().next().unwrap()];
while !to_visit.is_empty() {
let source = to_visit.pop().unwrap();
diff --git a/rr_frontend/translation/src/function_body.rs b/rr_frontend/translation/src/function_body.rs
index a15a2b23f78ac0177461dfb29e4f62439eeff4f3..5388779fd46ac219fdd5368e5b316e6772908747 100644
--- a/rr_frontend/translation/src/function_body.rs
+++ b/rr_frontend/translation/src/function_body.rs
@@ -9,7 +9,7 @@ use log::{info};
use rustc_ast::ast::Attribute;
use rustc_hir::def_id::DefId;
use rustc_middle::ty as ty;
-use rustc_middle::ty::{Ty, TyKind, ConstKind, subst::Subst};
+use rustc_middle::ty::{Ty, TyKind, ConstKind};
use rustc_middle::mir;
use rustc_middle::mir::interpret::{ConstValue, Scalar};
use rustc_middle::mir::tcx::PlaceTy;
@@ -149,7 +149,7 @@ pub struct BodyTranslator<'a, 'def, 'tcx> {
/// and rewrite accesses to the first component to directly use the place,
/// while rewriting accesses to the second component to true.
/// TODO: once we handle panics properly, we should use a different translation.
- /// NOTE: we only rewrite uses of these temporaries, as these are the only places the temporaries are relevant.
+ /// NOTE: we only rewrite for uses, as these are the only places these are used.
checked_op_temporaries: HashMap<Local, Ty<'tcx>>,
}
@@ -197,6 +197,9 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
VarDebugInfoContents::Const(_) => {
// is this case used when constant propagation happens during MIR construction?
},
+ VarDebugInfoContents::Composite { ty: _, fragments: _ } => {
+ // Not sure
+ },
}
}
@@ -204,22 +207,22 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
}
/// Generate a key for generics to index into our map of other required procedures.
- fn generate_procedure_inst_key(&self, ty_params: ty::subst::SubstsRef<'tcx>) -> Result<FnGenericKey<'tcx>, TranslationError> {
+ fn generate_procedure_inst_key(&self, ty_params: ty::GenericArgsRef<'tcx>) -> Result<FnGenericKey<'tcx>, TranslationError> {
// erase parameters to their syntactic types
let mut key = Vec::new();
let mut region_eraser = TyRegionEraseFolder::new(self.env.tcx());
for p in ty_params.iter() {
match p.unpack() {
- ty::subst::GenericArgKind::Lifetime(_) => {
+ ty::GenericArgKind::Lifetime(_) => {
// lifetimes are not relevant here
},
- ty::subst::GenericArgKind::Type(t) => {
+ ty::GenericArgKind::Type(t) => {
// TODO: this should erase to the syntactic type.
// Is erasing regions enough for that?
let t_erased = t.fold_with(&mut region_eraser);
key.push(t_erased);
},
- ty::subst::GenericArgKind::Const(_c) => {
+ ty::GenericArgKind::Const(_c) => {
return Err(TranslationError::UnsupportedFeature{description:
"RefinedRust does not support const generics".to_string()})
},
@@ -229,7 +232,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
}
/// Internally register that we have used a procedure with a particular instantiation of generics, and return the code parameter name.
- fn register_use_procedure(&mut self, did: &DefId, ty_params: ty::subst::SubstsRef<'tcx>) -> Result<String, TranslationError> {
+ fn register_use_procedure(&mut self, did: &DefId, ty_params: ty::GenericArgsRef<'tcx>) -> Result<String, TranslationError> {
let key = self.generate_procedure_inst_key(ty_params)?;
let tup = (*did, key);
@@ -259,7 +262,8 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
let mangled_name = strip_coq_ident(&mangled_name);
// also gather all the layouts of the arguments.
- let full_ty: Ty<'tcx> = self.env.tcx().type_of(*did);
+ let full_ty: ty::EarlyBinder<Ty<'tcx>> = self.env.tcx().type_of(*did);
+ let full_ty: Ty<'tcx> = full_ty.instantiate_identity();
let sig = full_ty.fn_sig(self.env.tcx());
let inputs = sig.inputs().skip_binder();
@@ -267,8 +271,8 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
//info!("substs: {:?}, inputs {:?} ", ty_params, inputs);
for i in inputs.iter() {
// need to wrap it, because there's no Subst instance for Ty
- let i = ty::EarlyBinder(*i);
- let ty = i.subst(self.env.tcx(), ty_params);
+ let i = ty::EarlyBinder::bind(*i);
+ let ty = i.instantiate(self.env.tcx(), ty_params);
let t = self.ty_translator.translate_type_to_syn_type(&ty)?;
syntypes.push(t);
}
@@ -282,7 +286,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
pub fn dump_body(body: &Body) {
// TODO: print to file
- let basic_blocks = body.basic_blocks();
+ let basic_blocks = &body.basic_blocks;
for (bb_idx, bb) in basic_blocks.iter_enumerated() {
Self::dump_basic_block(&bb_idx, bb);
};
@@ -301,7 +305,8 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
// dump debug info
Self::dump_body(body);
- let ty: Ty<'tcx> = env.tcx().type_of(proc.get_id());
+ let ty: ty::EarlyBinder<Ty<'tcx>> = env.tcx().type_of(proc.get_id());
+ let ty = ty.instantiate_identity();
let (sig, substs) = match ty.kind() {
TyKind::FnDef(_def, args) => {
assert!(ty.is_fn());
@@ -328,15 +333,15 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
// we create a substitution that replaces early bound regions with their Polonius
// region variables
- let mut subst_early_bounds: Vec<ty::subst::GenericArg<'tcx>> = Vec::new();
+ let mut subst_early_bounds: Vec<ty::GenericArg<'tcx>> = Vec::new();
let mut num_early_bounds = 0;
for a in substs.iter() {
match a.unpack() {
- ty::subst::GenericArgKind::Lifetime(r) => {
+ ty::GenericArgKind::Lifetime(r) => {
// skip over 0 = static
- let revar = env.tcx().mk_region(ty::RegionKind::ReVar(ty::RegionVid::from_u32(num_early_bounds + 1)));
+ let revar = ty::Region::new_var(env.tcx(), ty::RegionVid::from_u32(num_early_bounds + 1));
num_early_bounds += 1;
- subst_early_bounds.push(ty::subst::GenericArg::from(revar));
+ subst_early_bounds.push(ty::GenericArg::from(revar));
match *r {
ty::RegionKind::ReEarlyBound(r) => {
@@ -355,7 +360,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
},
}
}
- let subst_early_bounds = env.tcx().mk_substs(subst_early_bounds.iter());
+ let subst_early_bounds = env.tcx().mk_args(&subst_early_bounds);
// add names for late bound region variables
let mut num_late_bounds = 0;
@@ -387,15 +392,15 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
|_| {
let cur_index = next_index;
next_index += 1;
- env.tcx().mk_region(ty::RegionKind::ReVar(ty::RegionVid::from_u32(cur_index)))
+ ty::Region::new_var(env.tcx(),ty::RegionVid::from_u32(cur_index))
};
let (late_sig, _late_region_map) = env.tcx().replace_late_bound_regions(sig, &mut folder);
let inputs: Vec<_> = late_sig.inputs().iter().map(|ty| {
- let wrapped_ty = ty::EarlyBinder(*ty);
- wrapped_ty.subst(env.tcx(), subst_early_bounds) }).collect();
- let output = ty::EarlyBinder(late_sig.output());
- let output = output.subst(env.tcx(), subst_early_bounds);
+ let wrapped_ty = ty::EarlyBinder::bind(*ty);
+ wrapped_ty.instantiate(env.tcx(), subst_early_bounds) }).collect();
+ let output = ty::EarlyBinder::bind(late_sig.output());
+ let output = output.instantiate(env.tcx(), subst_early_bounds);
info!("Have lifetime parameters: {:?} {:?}", universal_lifetimes, user_lifetime_names);
@@ -473,7 +478,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
match kind {
LocalKind::Arg => translated_fn.code.add_argument(&name, st),
- LocalKind::Var => translated_fn.code.add_local(&name, st),
+ //LocalKind::Var => translated_fn.code.add_local(&name, st),
LocalKind::Temp => translated_fn.code.add_local(&name, st),
LocalKind::ReturnPointer => {
return_synty = st.clone();
@@ -697,7 +702,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
}
// translate the function's basic blocks
- let basic_blocks = self.proc.get_mir().basic_blocks();
+ let basic_blocks = &self.proc.get_mir().basic_blocks;
// first translate the initial basic block; we add some additional annotations to the front
let initial_bb_idx = BasicBlock::from_u32(0);
@@ -950,14 +955,14 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
/// Split the type of a function operand of a call expression to a base type and an instantiation for
/// generics.
- fn call_expr_op_split_inst(&self, op: &Operand<'tcx>) -> Result<(DefId, ty::PolyFnSig<'tcx>, ty::subst::SubstsRef<'tcx>), TranslationError> {
+ fn call_expr_op_split_inst(&self, op: &Operand<'tcx>) -> Result<(DefId, ty::PolyFnSig<'tcx>, ty::GenericArgsRef<'tcx>), TranslationError> {
match op {
Operand::Constant(box Constant {literal, ..}) => {
match literal {
ConstantKind::Ty(c) => {
match c.ty().kind() {
TyKind::FnDef(def, args) => {
- let ty: Ty<'tcx> = self.env.tcx().type_of(def);
+ let ty: Ty<'tcx> = self.env.tcx().type_of(def).instantiate_identity();
assert!(ty.is_fn());
let sig = ty.fn_sig(self.env.tcx());
//let inputs = sig.inputs().skip_binder();
@@ -971,7 +976,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
ConstantKind::Val(_, ty) => {
match ty.kind() {
TyKind::FnDef(def, args) => {
- let ty: Ty<'tcx> = self.env.tcx().type_of(def);
+ let ty: Ty<'tcx> = self.env.tcx().type_of(def).instantiate_identity();
assert!(ty.is_fn());
let sig = ty.fn_sig(self.env.tcx());
//let inputs = sig.inputs().skip_binder();
@@ -981,7 +986,9 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
// TODO handle FnPtr
_ => Err(TranslationError::Unimplemented{description: "implement function pointers".to_string()}),
}
- //panic!("should not be reachable: calling literal {:?}", ty)
+ },
+ ConstantKind::Unevaluated(_, _) => {
+ Err(TranslationError::Unimplemented{description: "implement ConstantKind::Unevaluated".to_string()})
}
}
},
@@ -992,7 +999,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
/// Find the optional DefId of the closure giving the invariant for the loop with head `head_bb`.
fn find_loop_spec_closure(&self, head_bb: BasicBlock) -> Result<Option<DefId>, TranslationError> {
let bodies = self.proc.loop_info().ordered_loop_bodies.get(&head_bb).unwrap();
- let basic_blocks = self.proc.get_mir().basic_blocks();
+ let basic_blocks = &self.proc.get_mir().basic_blocks;
// we go in order through the bodies in order to not stumble upon an annotation for a
// nested loop!
@@ -1084,6 +1091,12 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
let mut res_stmt;
match term.kind {
+ TerminatorKind::UnwindResume => {
+ return Err(TranslationError::Unimplemented { description: "implement UnwindResume".to_string() })
+ },
+ TerminatorKind::UnwindTerminate => {
+ return Err(TranslationError::Unimplemented { description: "implement UnwindTerminate".to_string() })
+ },
TerminatorKind::Goto {ref target} => {
res_stmt = self.translate_goto_like(&loc, target)?;
},
@@ -1122,7 +1135,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
info!("call substs: {:?} = {:?}, {:?}", func, sig, substs);
for a in substs.iter() {
match a.unpack() {
- ty::subst::GenericArgKind::Lifetime(r) => {
+ ty::GenericArgKind::Lifetime(r) => {
match r.kind() {
ty::RegionKind::ReVar(r) => early_regions.push(r),
_ => (),
@@ -1176,17 +1189,17 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
// we just hand out the late bound regions in sequence
let v = late_regions.get(next_index).unwrap();
next_index += 1;
- self.env.tcx().mk_region(ty::RegionKind::ReVar(*v))
+ ty::Region::new_var(self.env.tcx(), *v)
};
let (late_sig, late_region_map) = self.env.tcx().replace_late_bound_regions(sig, &mut folder);
info!("recovered late map: {:?}, sig: {}", late_region_map, late_sig);
// fully substitute the types (late parameters are already substituted, now subst early parameters)
let subst_inputs: Vec<Ty<'tcx>> = late_sig.inputs().iter().map(|ty| {
- let wrapped_ty = ty::EarlyBinder(*ty);
- wrapped_ty.subst(self.env.tcx(), substs) }).collect();
- let output = ty::EarlyBinder(late_sig.output());
- let _subst_output = output.subst(self.env.tcx(), substs);
+ let wrapped_ty = ty::EarlyBinder::bind(*ty);
+ wrapped_ty.instantiate(self.env.tcx(), substs) }).collect();
+ let output = ty::EarlyBinder::bind(late_sig.output());
+ let _subst_output = output.instantiate(self.env.tcx(), substs);
// solve the constraints for the new_regions
@@ -1375,14 +1388,15 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
// TODO is this right?
res_stmt = self.prepend_endlfts(res_stmt, dying_loans.into_iter());
},
- TerminatorKind::Abort => {
- res_stmt = caesium::Stmt::Stuck;
- res_stmt = self.prepend_endlfts(res_stmt, dying_loans.into_iter());
- },
- TerminatorKind::SwitchInt{ref discr, switch_ty, ref targets} => {
+ //TerminatorKind::Abort => {
+ //res_stmt = caesium::Stmt::Stuck;
+ //res_stmt = self.prepend_endlfts(res_stmt, dying_loans.into_iter());
+ //},
+ TerminatorKind::SwitchInt{ref discr, ref targets} => {
let operand = self.translate_operand(discr, true)?;
let all_targets: &[BasicBlock] = targets.all_targets();
+ let switch_ty = self.get_type_of_operand(discr)?;
if switch_ty.is_bool() {
// we currently special-case this as Caesium has a built-in if and this is more
// convenient to handle for the type-checker
@@ -1454,10 +1468,6 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
//res_stmt = caesium::Stmt::ExprS { e: drope, s: Box::new(res_stmt)};
},
- TerminatorKind::DropAndReplace{ .. } => {
- // TODO: we really should support this.
- return Err(TranslationError::UnsupportedFeature{description: "DropAndReplace terminators are currently not supported".to_string()})
- },
TerminatorKind::FalseEdge { real_target, .. } => {
// just a goto for our purposes
res_stmt = self.translate_goto_like(&loc, &real_target)?;
@@ -1472,9 +1482,6 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
TerminatorKind::Yield { .. } => {
return Err(TranslationError::UnsupportedFeature{description: format!("Unsupported terminator {:?}", term)})
},
- TerminatorKind::Resume => {
- return Err(TranslationError::UnsupportedFeature{description: format!("Unsupported terminator {:?}", term)})
- },
TerminatorKind::Unreachable => {
res_stmt = caesium::Stmt::Stuck;
},
@@ -1513,7 +1520,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
else {
// check for gotos that go to this basic block
let pred_bbs = self.proc.predecessors(loc.block);
- let basic_blocks = self.proc.get_mir().basic_blocks();
+ let basic_blocks = &self.proc.get_mir().basic_blocks;
pred_bbs.iter().map(|bb| {
let data = &basic_blocks[*bb];
Location {block: *bb, statement_index: data.statements.len()}
@@ -1814,9 +1821,14 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
StatementKind::SetDiscriminant { place: _place, variant_index: _variant_index } =>
// TODO
return Err(TranslationError::UnsupportedFeature{description: "TODO: implement SetDiscriminant".to_string()}),
- StatementKind::CopyNonOverlapping(_) =>
- // TODO: should handle that with a shim
- return Err(TranslationError::UnsupportedFeature{description: "TODO: implement CopyNonOverlapping".to_string()}),
+ StatementKind::PlaceMention(_place) =>
+ // TODO: this is missed UB
+ return Err(TranslationError::UnsupportedFeature{description: "TODO: implement PlaceMention".to_string()}),
+ StatementKind::Intrinsic(_intrinsic) =>
+ return Err(TranslationError::UnsupportedFeature{description: "TODO: implement Intrinsic".to_string()}),
+ StatementKind::ConstEvalCounter =>
+ // no-op
+ (),
StatementKind::StorageLive(_) =>
// just ignore
(),
@@ -1852,9 +1864,6 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
// TODO: figure out what to do with this
// arises in match lowering
Err(TranslationError::UnsupportedFeature { description: "Do not support Shallow borrows currently".to_string() }),
- BorrowKind::Unique =>
- // only used in implicit closure bindings
- Err(TranslationError::UnsupportedFeature { description: "Do not support Unique borrows currently".to_string() }),
BorrowKind::Mut{..} => {
// TODO: handle two-phase borrows?
Ok(caesium::BorKind::Mutable)
@@ -1885,6 +1894,11 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
/// Caesium layout annotation.
fn translate_binop(&self, op: BinOp, e1: &Operand<'tcx>, _e2: &Operand<'tcx>) -> Result<caesium::Binop, TranslationError> {
match op {
+ BinOp::AddUnchecked => Ok(caesium::Binop::AddOp),
+ BinOp::SubUnchecked => Ok(caesium::Binop::SubOp),
+ BinOp::MulUnchecked => Ok(caesium::Binop::MulOp),
+ BinOp::ShlUnchecked => Ok(caesium::Binop::ShlOp),
+ BinOp::ShrUnchecked => Ok(caesium::Binop::ShrOp),
BinOp::Add => Ok(caesium::Binop::AddOp),
BinOp::Sub => Ok(caesium::Binop::SubOp),
BinOp::Mul => Ok(caesium::Binop::MulOp),
@@ -2158,30 +2172,46 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
mir::CastKind::PointerFromExposedAddress => {
Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
},
- mir::CastKind::Pointer(x) => {
+ mir::CastKind::PointerCoercion(x) => {
match x {
- ty::adjustment::PointerCast::MutToConstPointer => {
+ ty::adjustment::PointerCoercion::MutToConstPointer => {
// this is a NOP in our model
Ok(translated_op)
},
- ty::adjustment::PointerCast::ArrayToPointer => {
+ ty::adjustment::PointerCoercion::ArrayToPointer => {
Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
},
- ty::adjustment::PointerCast::ClosureFnPointer(_) => {
+ ty::adjustment::PointerCoercion::ClosureFnPointer(_) => {
Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
},
- ty::adjustment::PointerCast::ReifyFnPointer => {
+ ty::adjustment::PointerCoercion::ReifyFnPointer => {
Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
},
- ty::adjustment::PointerCast::UnsafeFnPointer => {
+ ty::adjustment::PointerCoercion::UnsafeFnPointer => {
Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
},
- ty::adjustment::PointerCast::Unsize => {
+ ty::adjustment::PointerCoercion::Unsize => {
Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
},
}
},
- mir::CastKind::Misc => {
+ mir::CastKind::DynStar => {
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported dyn* cast").to_string()})
+ }
+ mir::CastKind::IntToInt => {
+ // TODO
+ Err(TranslationError::Unimplemented {description: format!("unsupported int-to-int cast").to_string()})
+ },
+ mir::CastKind::IntToFloat => {
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported int-to-float cast").to_string()})
+ },
+ mir::CastKind::FloatToInt => {
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported float-to-int cast").to_string()})
+ },
+ mir::CastKind::FloatToFloat => {
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported float-to-float cast").to_string()})
+ }
+ mir::CastKind::PtrToPtr => {
match (op_ty.kind(), ty.kind()) {
(TyKind::RawPtr(_), TyKind::RawPtr(_)) => {
// Casts between raw pointers are NOPs for us
@@ -2189,10 +2219,16 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
},
_ => {
// TODO: any other cases we should handle?
- Err(TranslationError::UnsupportedFeature{description: format!("unsupported rvalue: {:?}", rval).to_string()})
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported ptr-to-ptr cast: {:?}", rval).to_string()})
},
}
},
+ mir::CastKind::FnPtrToPtr => {
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported fnptr-to-ptr cast: {:?}", rval).to_string()})
+ },
+ mir::CastKind::Transmute => {
+ Err(TranslationError::UnsupportedFeature{description: format!("unsupported transmute cast: {:?}", rval).to_string()})
+ },
}
},
Rvalue::Len(..) => {
@@ -2215,7 +2251,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
/// Make a trivial place accessing `local`.
fn make_local_place(&self, local: &Local) -> Place<'tcx> {
- Place { local: *local, projection: self.env.tcx().intern_place_elems(&[]) }
+ Place { local: *local, projection: self.env.tcx().mk_place_elems(&[]) }
}
/// Translate an operand.
@@ -2364,7 +2400,7 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
_ => Err(TranslationError::UnsupportedFeature{description: "Unsupported ConstKind".to_string()})
}
},
- ConstantKind::Val(val, ty) =>
+ ConstantKind::Val(val, ty) => {
match val {
ConstValue::Scalar(sc) => {
self.translate_scalar(&sc, ty)
@@ -2385,6 +2421,10 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
Err(TranslationError::UnsupportedFeature{description: format!("Unsupported Constant: ConstValue; {:?}", constant.literal)})
}
}
+ },
+ ConstantKind::Unevaluated(_, _) => {
+ Err(TranslationError::UnsupportedFeature{description: format!("Unsupported Constant: Unevaluated; {:?}", constant.literal)})
+ },
}
}
@@ -2441,6 +2481,9 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
return Err(TranslationError::UnknownError("places: ADT downcasting on non-enum type".to_string()));
}
},
+ ProjectionElem::OpaqueCast(_) => {
+ return Err(TranslationError::UnsupportedFeature{description: "places: implement opaque casts".to_string()});
+ },
};
// update cur_ty
cur_ty = cur_ty.projection_ty(self.env.tcx(), *it);
@@ -2462,7 +2505,8 @@ impl<'a, 'def : 'a, 'tcx : 'def> BodyTranslator<'a, 'def, 'tcx> {
fn get_type_of_const(&self, cst: &Constant<'tcx>) -> Result<Ty<'tcx>, TranslationError> {
match cst.literal {
ConstantKind::Ty(cst) => Ok(cst.ty()),
- ConstantKind::Val(_, ty) => Ok(ty)
+ ConstantKind::Val(_, ty) => Ok(ty),
+ ConstantKind::Unevaluated(_, ty) => Ok(ty),
}
}
diff --git a/rr_frontend/translation/src/main.rs b/rr_frontend/translation/src/main.rs
index a1d20e6fe637ca43ea212fde10db287fe228ed3e..310a0b8c1dc9d778723f66addea2d6d78229cce9 100644
--- a/rr_frontend/translation/src/main.rs
+++ b/rr_frontend/translation/src/main.rs
@@ -12,7 +12,6 @@
#![feature(box_patterns)]
-#![feature(box_syntax)]
#![feature(rustc_private)]
extern crate rustc_driver;
extern crate rustc_errors;
@@ -20,6 +19,7 @@ extern crate rustc_interface;
extern crate rustc_middle;
extern crate rustc_hir;
extern crate rustc_index;
+extern crate rustc_abi;
extern crate rustc_ast;
extern crate rustc_span;
extern crate rustc_trait_selection;
@@ -36,7 +36,7 @@ extern crate lazy_static;
use log::{debug, info, warn};
use rustc_hir::{def_id::DefId, def_id::LocalDefId};
-use rustc_middle::ty::query::{query_values::mir_borrowck, Providers, ExternProviders};
+use rustc_middle::query::{queries::mir_borrowck, Providers, ExternProviders};
use std::env;
use rustc_driver::Compilation;
@@ -108,7 +108,7 @@ fn order_struct_defs<'tcx>(env: &Environment<'tcx>, defs: &[DefId]) -> Vec<DefId
let mut dependencies: HashMap<DefId, HashSet<DefId>> = HashMap::new();
for did in defs.iter() {
let mut deps = HashSet::new();
- let ty: ty::Ty<'tcx> = env.tcx().type_of(*did);
+ let ty: ty::Ty<'tcx> = env.tcx().type_of(*did).instantiate_identity();
match ty.kind() {
ty::TyKind::Adt(adt, _) => {
let variants = &adt.variants();
@@ -118,7 +118,7 @@ fn order_struct_defs<'tcx>(env: &Environment<'tcx>, defs: &[DefId]) -> Vec<DefId
continue;
}
for f in v.fields.iter() {
- let field_ty = env.tcx().type_of(f.did);
+ let field_ty = env.tcx().type_of(f.did).instantiate_identity();
// check if the field_ty is also an ADT -- if so, add it to the dependencies
match field_ty.kind() {
ty::TyKind::Adt(adt2, _) => {
@@ -278,9 +278,9 @@ pub fn analyze<'tcx>(tcx : TyCtxt<'tcx>) {
}
// get file stem for naming
- let crate_name = (tcx.crate_name(rustc_hir::def_id::LOCAL_CRATE));
+ //let a = tcx.gcx;
let stem;
- let filepath = &tcx.sess.local_crate_source_file;
+ let filepath = &tcx.sess.local_crate_source_file();
if let Some(path) = filepath {
if let Some (file_stem) = path.file_stem() {
info!("file stem: {:?}", file_stem);
@@ -299,7 +299,6 @@ pub fn analyze<'tcx>(tcx : TyCtxt<'tcx>) {
// write output
let dir_str = rrconfig::output_dir();
let mut dir_path = std::path::PathBuf::from(&dir_str);
- dir_path.push(&crate_name.as_str());
dir_path.push(&stem);
let dir_path = dir_path.as_path();
if let Err(_) = fs::read_dir(dir_path) {
@@ -513,10 +512,11 @@ struct RRCompilerCalls {
}
// From Prusti.
-fn mir_borrowck<'tcx>(tcx: TyCtxt<'tcx>, def_id: LocalDefId) -> mir_borrowck<'tcx> {
+fn mir_borrowck<'tcx>(tcx: TyCtxt<'tcx>, def_id: LocalDefId) -> mir_borrowck::ProvidedValue<'tcx> {
let body_with_facts = rustc_borrowck::consumers::get_body_with_borrowck_facts(
tcx,
- ty::WithOptConstParam::unknown(def_id),
+ def_id,
+ rustc_borrowck::consumers::ConsumerOptions::PoloniusOutputFacts
);
// SAFETY: This is safe because we are feeding in the same `tcx` that is
// going to be used as a witness when pulling out the data.
@@ -544,11 +544,12 @@ impl rustc_driver::Callbacks for RRCompilerCalls {
fn after_analysis<'tcx>(
&mut self,
+ _handler: &rustc_session::EarlyErrorHandler,
_ : &rustc_interface::interface::Compiler,
queries : &'tcx rustc_interface::Queries<'tcx>
) -> Compilation {
// Analyze the crate and inspect the types under the cursor.
- queries.global_ctxt().unwrap().take().enter(|tcx| {
+ queries.global_ctxt().unwrap().enter(|tcx| {
analyze(tcx);
}
);
@@ -579,7 +580,7 @@ fn run_compiler(
}
fn main() {
- rustc_driver::install_ice_hook();
+ rustc_driver::install_ice_hook("", |_| ());
env_logger::init();
diff --git a/rr_frontend/translation/src/parse.rs b/rr_frontend/translation/src/parse.rs
index 20266f22c7b849ba80e6576f9ef243fef9b7bddd..21aa93ba145e931b5685dd794db98dc10c079af8 100644
--- a/rr_frontend/translation/src/parse.rs
+++ b/rr_frontend/translation/src/parse.rs
@@ -168,7 +168,7 @@ impl ParseBuffer {
pub fn peek_token(&self, token: TokenKind) -> bool {
let tok = self.peek(0);
match tok {
- Ok(TokenTree::Token(tok)) => {
+ Ok(TokenTree::Token(tok, _)) => {
tok.kind == token
},
_ => {
@@ -181,7 +181,7 @@ impl ParseBuffer {
pub fn expect_token(&self, token: TokenKind) -> ParseResult<Span> {
let tok = self.peek(0)?;
match tok {
- TokenTree::Token(tok) => {
+ TokenTree::Token(tok, _) => {
if tok.kind == token {
self.advance(1);
Ok(tok.span)
@@ -200,7 +200,7 @@ impl ParseBuffer {
pub fn expect_ident(&self) -> ParseResult<(Symbol, Span)> {
let tok = self.peek(0)?;
match tok {
- TokenTree::Token(tok) => {
+ TokenTree::Token(tok, _) => {
match tok.kind {
TokenKind::Ident(sym, _) => {
self.advance(1);
@@ -219,7 +219,7 @@ impl ParseBuffer {
pub fn expect_literal(&self) -> ParseResult<(Lit, Span)> {
let tok = self.peek(0)?;
match tok {
- TokenTree::Token(tok) => {
+ TokenTree::Token(tok, _) => {
match tok.kind {
TokenKind::Literal(lit) => {
self.advance(1);
diff --git a/rr_frontend/translation/src/type_translator.rs b/rr_frontend/translation/src/type_translator.rs
index 5283565428ac7a06d83cad1bcf9735b0d933d4a9..db0bd614dcf8d1e9f8d919e37e72831e68c98965 100644
--- a/rr_frontend/translation/src/type_translator.rs
+++ b/rr_frontend/translation/src/type_translator.rs
@@ -9,7 +9,7 @@ use log::info;
use rustc_hir::def_id::DefId;
use rustc_middle::ty as ty;
use rustc_middle::ty::{Ty, IntTy, UintTy, TyKind};
-use rustc_middle::mir::Field;
+//use rustc_middle::mir::Field;
use crate::rustc_middle::ty::TypeFoldable;
use std::cell::RefCell;
@@ -142,7 +142,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
/// Enter a procedure and add corresponding type parameters to the scope, as well as universal
/// lifetimes with given names.
- pub fn enter_procedure(&self, ty_params: &ty::subst::SubstsRef<'tcx>, univ_lfts: Vec<String>) -> Result<(), TranslationError> {
+ pub fn enter_procedure(&self, ty_params: &ty::GenericArgsRef<'tcx>, univ_lfts: Vec<String>) -> Result<(), TranslationError> {
info!("Entering procedure with ty_params {:?} and univ_lfts {:?}", ty_params, univ_lfts);
let mut v: Vec<Option<caesium::Type<'def>>> = Vec::new();
@@ -150,7 +150,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
let mut rfntypes = Vec::new();
for gen_arg in ty_params.iter() {
match gen_arg.unpack() {
- ty::subst::GenericArgKind::Type(ty) => {
+ ty::GenericArgKind::Type(ty) => {
match ty.kind() {
TyKind::Param(p) => {
info!("ty param {} @ {}", p.name, p.index);
@@ -173,7 +173,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
},
}
},
- ty::subst::GenericArgKind::Lifetime(r) => {
+ ty::GenericArgKind::Lifetime(r) => {
match *r {
ty::RegionKind::ReLateBound(..)
| ty::RegionKind::ReEarlyBound(..) => {
@@ -188,7 +188,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
},
}
},
- ty::subst::GenericArgKind::Const(_c) => {
+ ty::GenericArgKind::Const(_c) => {
return Err(TranslationError::UnsupportedFeature{description:
"RefinedRust does not currently support const generics".to_string()});
},
@@ -532,7 +532,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
// first thing: figure out the generics we are using here.
let mut folder = TyVarFolder::new(self.env.tcx());
for f in ty.fields.iter() {
- let f_ty = self.env.tcx().type_of(f.did);
+ let f_ty = self.env.tcx().type_of(f.did).instantiate_identity();
f_ty.fold_with(&mut folder);
}
let mut used_generics: Vec<ty::ParamTy> = folder.get_result().into_iter().collect();
@@ -647,7 +647,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
let attrs = self.env.get_attributes(f.did);
let attrs = crate::utils::filter_tool_attrs(attrs);
- let f_ty = self.env.tcx().type_of(f.did);
+ let f_ty = self.env.tcx().type_of(f.did).instantiate_identity();
let mut ty = self.translate_type(&f_ty)?;
ty.subst(&ty_env);
@@ -702,7 +702,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
info!("Discriminant for {:?}: {:?}", v, v.discr);
match v.discr {
ty::VariantDiscr::Explicit(did) => {
- let ty: ty::Ty<'tcx> = self.env.tcx().type_of(did);
+ let ty: ty::EarlyBinder<ty::Ty<'tcx>> = self.env.tcx().type_of(did);
let did = did.expect_local();
let hir = self.env.tcx().hir();
let node = hir.get_by_def_id(did);
@@ -770,7 +770,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
let mut folder = TyVarFolder::new(self.env.tcx());
for v in def.variants().iter() {
for f in v.fields.iter() {
- let f_ty = self.env.tcx().type_of(f.did);
+ let f_ty = self.env.tcx().type_of(f.did).instantiate_identity();
f_ty.fold_with(&mut folder);
}
}
@@ -795,7 +795,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
for v in def.variants().iter() {
let mut folder = TyVarFolder::new(self.env.tcx());
for f in v.fields.iter() {
- let f_ty = self.env.tcx().type_of(f.did);
+ let f_ty = self.env.tcx().type_of(f.did).instantiate_identity();
f_ty.fold_with(&mut folder);
}
let variant_generics: HashSet<ty::ParamTy> = folder.get_result();
@@ -844,7 +844,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
// get the type of the discriminant
let it = def.repr().discr_type();
- let translated_it = self.translate_int_type(it)?;
+ let translated_it = self.translate_integer_type(it)?;
// build the discriminant map
let discrs = self.build_discriminant_map(def)?;
@@ -935,9 +935,9 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
match mutability {
rustc_ast::ast::Mutability::Mut =>
- Ok(caesium::Type::MutRef(box translated_ty, lft)),
+ Ok(caesium::Type::MutRef(Box::new(translated_ty), lft)),
_ =>
- Ok(caesium::Type::ShrRef(box translated_ty, lft)),
+ Ok(caesium::Type::ShrRef(Box::new(translated_ty), lft)),
}
},
TyKind::Never => Ok(caesium::Type::Never),
@@ -948,7 +948,7 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
assert!(substs.len() == 2);
let ty = substs[0].expect_ty();
let translated_ty = self.translate_type(&ty)?;
- Ok(caesium::Type::BoxType(box translated_ty))
+ Ok(caesium::Type::BoxType(Box::new(translated_ty)))
}
else if let Some(true) = self.is_struct_definitely_zero_sized(adt.did()) {
// make this unit
@@ -997,10 +997,10 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
"RefinedRust does currently not support generators".to_string()}),
TyKind::GeneratorWitness(..) => Err(TranslationError::UnsupportedType {description:
"RefinedRust does currently not support generators".to_string()}),
- TyKind::Projection(..) => Err(TranslationError::UnsupportedType {description:
- "RefinedRust does currently not support associated types".to_string()}),
- TyKind::Opaque(..) => Err(TranslationError::UnsupportedType {description:
- "RefinedRust does currently not support returning impls".to_string()}),
+ //TyKind::Projection(..) => Err(TranslationError::UnsupportedType {description:
+ //"RefinedRust does currently not support associated types".to_string()}),
+ //TyKind::Opaque(..) => Err(TranslationError::UnsupportedType {description:
+ //"RefinedRust does currently not support returning impls".to_string()}),
_ => Err(TranslationError::UnsupportedType {description: format!("Unknown unsupported type {}", ty)}),
}
}
@@ -1031,6 +1031,40 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
}
}
+ /// Translate a rustc_attr::IntType (this is different from the rustc_ty IntType).
+ fn translate_integer_type(&self, it: rustc_abi::IntegerType) -> Result<caesium::IntType, TranslationError> {
+ match it {
+ rustc_abi::IntegerType::Fixed(size, sign) => {
+ if sign {
+ Ok(match size {
+ rustc_abi::Integer::I8 => caesium::IntType::I8,
+ rustc_abi::Integer::I16 => caesium::IntType::I16,
+ rustc_abi::Integer::I32 => caesium::IntType::I32,
+ rustc_abi::Integer::I64 => caesium::IntType::I64,
+ rustc_abi::Integer::I128 => caesium::IntType::I128,
+ })
+ }
+ else {
+ Ok(match size {
+ rustc_abi::Integer::I8 => caesium::IntType::U8,
+ rustc_abi::Integer::I16 => caesium::IntType::U16,
+ rustc_abi::Integer::I32 => caesium::IntType::U32,
+ rustc_abi::Integer::I64 => caesium::IntType::U64,
+ rustc_abi::Integer::I128 => caesium::IntType::U128,
+ })
+ }
+ },
+ rustc_abi::IntegerType::Pointer(sign) => {
+ if sign {
+ Ok(caesium::IntType::ISize)
+ }
+ else {
+ Ok(caesium::IntType::USize)
+ }
+ },
+ }
+ }
+
/// Translate a MIR type to the Caesium syntactic type we need when storing an element of the type,
/// substituting all generics.
pub fn translate_type_to_syn_type(&self, ty: &Ty<'tcx>) -> Result<caesium::SynType, TranslationError> {
@@ -1055,20 +1089,20 @@ impl <'def, 'tcx : 'def> TypeTranslator<'def, 'tcx> {
}
/// Get the name for a field of an ADT or tuple type
- pub fn get_field_name_of(&self, f: &Field, ty: Ty<'tcx>, variant: Option<usize>) -> Result<String, TranslationError> {
+ pub fn get_field_name_of(&self, f: &rustc_target::abi::FieldIdx, ty: Ty<'tcx>, variant: Option<usize>) -> Result<String, TranslationError> {
let tcx = self.env.tcx();
match ty.kind() {
TyKind::Adt(def, _) => {
info!("getting field name of {:?} at {} (variant {:?})", f, ty, variant);
if def.is_struct() {
let i = def.variants().get(rustc_target::abi::VariantIdx::from_usize(0)).unwrap();
- i.fields.get(f.as_usize()).map(|f| f.ident(tcx).to_string())
+ i.fields.get(*f).map(|f| f.ident(tcx).to_string())
.ok_or(TranslationError::UnknownError(format!("could not get field {:?} of {}", f, ty)))
}
else if def.is_enum() {
let variant = variant.unwrap();
let i = def.variants().get(rustc_target::abi::VariantIdx::from_usize(variant)).unwrap();
- i.fields.get(f.as_usize()).map(|f| f.ident(tcx).to_string())
+ i.fields.get(*f).map(|f| f.ident(tcx).to_string())
.ok_or(TranslationError::UnknownError(format!("could not get field {:?} of {}", f, ty)))
}
else {
diff --git a/rr_frontend/translation/src/tyvars.rs b/rr_frontend/translation/src/tyvars.rs
index 3c59bdc2aa2bc0260d366e2618b4a55d0de37f49..4a5e1e195a6f8aac5a2d93707b6f97e21ea1121d 100644
--- a/rr_frontend/translation/src/tyvars.rs
+++ b/rr_frontend/translation/src/tyvars.rs
@@ -34,15 +34,15 @@ impl<'tcx> TyVarFolder<'tcx> {
}
}
-impl<'tcx> ty::TypeFolder<'tcx> for TyVarFolder<'tcx> {
- fn tcx(&self) -> TyCtxt<'tcx> {
+impl<'tcx> ty::TypeFolder<TyCtxt<'tcx>> for TyVarFolder<'tcx> {
+ fn interner(&self) -> TyCtxt<'tcx> {
self.tcx
}
// TODO: handle the case that we pass below binders
fn fold_binder<T>(&mut self, t: ty::Binder<'tcx, T>) -> ty::Binder<'tcx, T>
where
- T: ty::TypeFoldable<'tcx>,
+ T: ty::TypeFoldable<TyCtxt<'tcx>>,
{
t.super_fold_with(self)
}
@@ -84,15 +84,15 @@ impl<'tcx> TyVarRenameFolder<'tcx> {
}
}
-impl<'tcx> ty::TypeFolder<'tcx> for TyVarRenameFolder<'tcx> {
- fn tcx(&self) -> TyCtxt<'tcx> {
+impl<'tcx> ty::TypeFolder<TyCtxt<'tcx>> for TyVarRenameFolder<'tcx> {
+ fn interner(&self) -> TyCtxt<'tcx> {
self.tcx
}
// TODO: handle the case that we pass below binders
fn fold_binder<T>(&mut self, t: ty::Binder<'tcx, T>) -> ty::Binder<'tcx, T>
where
- T: ty::TypeFoldable<'tcx>,
+ T: ty::TypeFoldable<TyCtxt<'tcx>>,
{
t.super_fold_with(self)
}
@@ -101,14 +101,14 @@ impl<'tcx> ty::TypeFolder<'tcx> for TyVarRenameFolder<'tcx> {
match t.kind() {
TyKind::Param(param) => {
if let Some (new_param) = self.name_map.get(¶m) {
- self.tcx.mk_ty_param(new_param.index, new_param.name)
+ Ty::new_param(self.interner(), new_param.index, new_param.name)
}
else {
// create another type param
let new_index = self.new_subst.len() as u32;
// reuse the name
let name = param.name;
- let new_ty = self.tcx.mk_ty_param(new_index, name);
+ let new_ty = Ty::new_param(self.interner(), new_index, name);
let new_param = ty::ParamTy::new(new_index, name);
self.name_map.insert(*param, new_param);
@@ -135,21 +135,21 @@ impl<'tcx> TyRegionEraseFolder<'tcx> {
}
}
}
-impl<'tcx> ty::TypeFolder<'tcx> for TyRegionEraseFolder<'tcx> {
- fn tcx(&self) -> TyCtxt<'tcx> {
+impl<'tcx> ty::TypeFolder<TyCtxt<'tcx>> for TyRegionEraseFolder<'tcx> {
+ fn interner(&self) -> TyCtxt<'tcx> {
self.tcx
}
// TODO: handle the case that we pass below binders
fn fold_binder<T>(&mut self, t: ty::Binder<'tcx, T>) -> ty::Binder<'tcx, T>
where
- T: ty::TypeFoldable<'tcx>,
+ T: ty::TypeFoldable<TyCtxt<'tcx>>,
{
t.super_fold_with(self)
}
fn fold_region(&mut self, _ : ty::Region<'tcx>) -> ty::Region<'tcx> {
- self.tcx().mk_region(ty::RegionKind::ReErased)
+ ty::Region::new_from_kind(self.interner(), ty::RegionKind::ReErased)
}
}
@@ -170,15 +170,15 @@ impl<'tcx> TyRegionCollectFolder<'tcx> {
self.regions
}
}
-impl<'tcx> ty::TypeFolder<'tcx> for TyRegionCollectFolder<'tcx> {
- fn tcx(&self) -> TyCtxt<'tcx> {
+impl<'tcx> ty::TypeFolder<TyCtxt<'tcx>> for TyRegionCollectFolder<'tcx> {
+ fn interner(&self) -> TyCtxt<'tcx> {
self.tcx
}
// TODO: handle the case that we pass below binders
fn fold_binder<T>(&mut self, t: ty::Binder<'tcx, T>) -> ty::Binder<'tcx, T>
where
- T: ty::TypeFoldable<'tcx>,
+ T: ty::TypeFoldable<TyCtxt<'tcx>>,
{
t.super_fold_with(self)
}
diff --git a/rr_frontend/translation/src/utils.rs b/rr_frontend/translation/src/utils.rs
index 584dffa1e8f2888c06c7dd9f953ba9df9c446f50..2aff45a2a9a67e859f6eacef8cb32d3e2b33e5c3 100644
--- a/rr_frontend/translation/src/utils.rs
+++ b/rr_frontend/translation/src/utils.rs
@@ -82,7 +82,7 @@ pub fn try_resolve_method_did<'tcx>(tcx: TyCtxt<'tcx>, path: &[&str]) -> Option<
for impl_did in impls {
//let ty = tcx.type_of(*impl_did);
//info!("type of impl: {:?}", ty);
- let items: &ty::AssocItems<'tcx> = tcx.associated_items(impl_did);
+ let items: &ty::AssocItems = tcx.associated_items(impl_did);
//info!("items here: {:?}", items);
// TODO more robust error handling if there are multiple matches.
for item in items.in_definition_order() {
@@ -148,8 +148,7 @@ pub fn expand_struct_place<'tcx>(
let variant = def.non_enum_variant();
for (index, field_def) in variant.fields.iter().enumerate() {
if Some(index) != without_field {
- let field = mir::Field::from_usize(index);
- let field_place = tcx.mk_place_field(*place, field, field_def.ty(tcx, substs));
+ let field_place = tcx.mk_place_field(*place, index.into(), field_def.ty(tcx, substs));
places.push(field_place);
}
}
@@ -157,8 +156,7 @@ pub fn expand_struct_place<'tcx>(
ty::Tuple(slice) => {
for (index, arg) in slice.iter().enumerate() {
if Some(index) != without_field {
- let field = mir::Field::from_usize(index);
- let field_place = tcx.mk_place_field(*place, field, arg);
+ let field_place = tcx.mk_place_field(*place, index.into(), arg);
places.push(field_place);
}
}
@@ -223,7 +221,7 @@ pub fn try_pop_one_level<'tcx>(tcx: TyCtxt<'tcx>, place: mir::Place<'tcx>) -> Op
let last_index = place.projection.len()-1;
let new_place = mir::Place {
local: place.local,
- projection: tcx.intern_place_elems(&place.projection[..last_index]),
+ projection: tcx.mk_place_elems(&place.projection[..last_index]),
};
Some((place.projection[last_index], new_place))
} else {
@@ -363,11 +361,9 @@ impl<'tcx> VecPlace<'tcx> {
/// Any arguments of the attribute are ignored.
pub fn has_tool_attr(attrs: &[ast::Attribute], name: &str) -> bool {
attrs.iter().any(|attr| match &attr.kind {
- ast::AttrKind::Normal(ast::AttrItem {
- path: ast::Path { span: _, segments, tokens: _ },
- args: _,
- tokens: _,
- }, _) => {
+ ast::AttrKind::Normal(n) => {
+ let na: &rustc_ast::ast::NormalAttr = &(*n);
+ let segments = &na.item.path.segments;
segments.len() == 2
&& segments[0].ident.as_str() == config::spec_hotword().as_str()
&& segments[1].ident.as_str() == name
@@ -381,7 +377,9 @@ pub fn has_tool_attr(attrs: &[ast::Attribute], name: &str) -> bool {
pub fn filter_tool_attrs(attrs: &[ast::Attribute]) -> Vec<&ast::AttrItem> {
let v: Vec<_> = attrs.iter().filter_map(|attr| {
match attr.kind {
- ast::AttrKind::Normal(ref it, _) => {
+ ast::AttrKind::Normal(ref n) => {
+ let na: &rustc_ast::ast::NormalAttr = &*(n);
+ let it = &na.item;
let ref path_segs = it.path.segments;
// parse path
diff --git a/theories/caesium/base.v b/theories/caesium/base.v
index 3cdb7b5204c5f195ba3ea3def7d31307c47beb70..47c4bbd6b4ab81259d0454e3a75bfc764b9d9413 100644
--- a/theories/caesium/base.v
+++ b/theories/caesium/base.v
@@ -31,23 +31,6 @@ Proof.
inversion 1; econstructor; naive_solver.
Qed.
-
-
-
-(* TODO Move *)
-Lemma drop_app' {A} (l k : list A) n :
- length l = n → drop n (l ++ k) = k.
-Proof. intros <-. apply drop_app. Qed.
-Lemma take_app' {A} (l k : list A) n :
- length l = n → take n (l ++ k) = l.
-Proof. intros <-. apply take_app. Qed.
-
-
-
-
-
-
-
(* TODO move *)
Definition list_map_option {X Y} (f : X → option Y) (l : list X) : option (list Y) :=
foldr (λ (x : X) (y : option (list Y)),
@@ -116,5 +99,3 @@ Proof.
simpl. destruct (f x) eqn:Heq2; last done.
simpl. intros [= <-]. eauto.
Qed.
-
-
diff --git a/theories/caesium/bitfield.v b/theories/caesium/bitfield.v
index 1c15ad9b5588b24178b387dcd5204aabd946ea5b..e41c3f59ba1332a30060ffa442bbfa9dae855a65 100644
--- a/theories/caesium/bitfield.v
+++ b/theories/caesium/bitfield.v
@@ -1,4 +1,5 @@
-From lithium Require Import simpl_classes tactics_extend infrastructure Z_bitblast classes.
+From stdpp.unstable Require Import bitblast.
+From lithium Require Import simpl_classes definitions.
From caesium Require Import base int_type builtins_specs.
(* raw bit vector constructors *)
@@ -259,8 +260,8 @@ Qed.
Create HintDb bitfield_rewrite discriminated.
#[export] Hint Rewrite bf_land_nil : bitfield_rewrite.
-#[export] Hint Rewrite bf_land_mask_cons using can_solve_tac : bitfield_rewrite.
-#[export] Hint Rewrite bf_land_mask_flip using can_solve_tac : bitfield_rewrite.
+#[export] Hint Rewrite bf_land_mask_cons using can_solve : bitfield_rewrite.
+#[export] Hint Rewrite bf_land_mask_flip using can_solve : bitfield_rewrite.
#[export] Hint Rewrite bf_lor_nil_l : bitfield_rewrite.
#[export] Hint Rewrite bf_lor_nil_r : bitfield_rewrite.
@@ -273,11 +274,11 @@ Create HintDb bitfield_rewrite discriminated.
#[export] Hint Rewrite bf_lor_mask_cons using lia : bitfield_rewrite.
#[export] Hint Rewrite bf_slice_nil : bitfield_rewrite.
-#[export] Hint Rewrite bf_slice_cons using can_solve_tac : bitfield_rewrite.
+#[export] Hint Rewrite bf_slice_cons using can_solve : bitfield_rewrite.
#[export] Hint Rewrite bf_slice_cons_ne using lia : bitfield_rewrite.
#[export] Hint Rewrite bf_update_nil : bitfield_rewrite.
-#[export] Hint Rewrite bf_update_cons using can_solve_tac : bitfield_rewrite.
+#[export] Hint Rewrite bf_update_cons using can_solve : bitfield_rewrite.
#[export] Hint Rewrite bf_update_cons_ne using lia : bitfield_rewrite.
(* Tactic to normalize a bitfield *)
@@ -288,15 +289,15 @@ Ltac normalize_bitfield :=
Definition normalize_bitfield {Σ} (bv : Z) (T : Z → iProp Σ) : iProp Σ := T bv.
Global Typeclasses Opaque normalize_bitfield.
-Program Definition normalize_bitfield_hint {Σ} bv norm :
+Program Definition li_normalize_bitfield {Σ} bv norm :
bv = norm →
- TacticHint (normalize_bitfield (Σ:=Σ) bv) := λ H, {|
- tactic_hint_P T := T norm;
+ LiTactic (normalize_bitfield (Σ:=Σ) bv) := λ H, {|
+ li_tactic_P T := T norm;
|}.
Next Obligation. move => ??? -> ?. unfold normalize_bitfield. iIntros "$". Qed.
-Global Hint Extern 10 (TacticHint (normalize_bitfield _)) =>
- eapply normalize_bitfield_hint; normalize_bitfield : typeclass_instances.
+Global Hint Extern 10 (LiTactic (normalize_bitfield _)) =>
+ eapply li_normalize_bitfield; normalize_bitfield : typeclass_instances.
(* enable using normalize_bitfield in function call specifications
where one cannot use tactic_hint *)
@@ -359,7 +360,7 @@ Qed.
(* Simplify data list eq *)
Global Instance bf_cons_eq a k x1 l1 x2 l2 :
- SimplAndUnsafe true (bf_cons a k x1 l1 = bf_cons a k x2 l2) (λ T, x1 = x2 ∧ l1 = l2 ∧ T).
+ SimplAndUnsafe (bf_cons a k x1 l1 = bf_cons a k x2 l2) (λ T, x1 = x2 ∧ l1 = l2 ∧ T).
Proof.
unfold CanSolve, SimplAndUnsafe in *.
naive_solver.
diff --git a/theories/caesium/builtins_specs.v b/theories/caesium/builtins_specs.v
index 5b4de81f6810628313d4fc32234d8f5a089fb5c5..7fb3dd8b0736e6be1d2a5d20138c5912a11c476b 100644
--- a/theories/caesium/builtins_specs.v
+++ b/theories/caesium/builtins_specs.v
@@ -1,4 +1,4 @@
-From lithium Require Import Z_bitblast.
+From stdpp.unstable Require Import bitblast.
From caesium Require Import base int_type.
(* least significant 1-bit *)
@@ -24,11 +24,96 @@ Proof.
rewrite Z_bits_opp_nz ?andb_negb_r // => Hn. bitblast Hn with k as Hn'. congruence.
Qed.
+Lemma Z_least_significant_one_lower_bound_pos n :
+ 0 < n →
+ 0 ≤ Z_least_significant_one n.
+Proof.
+ rewrite /Z_least_significant_one => ?.
+ case_bool_decide; [lia|].
+ apply Z.log2_nonneg.
+Qed.
+
Lemma Z_least_significant_one_lower_bound n :
-1 ≤ Z_least_significant_one n.
Proof.
rewrite /Z_least_significant_one.
case_bool_decide; [done|].
- trans 0; [done|].
- apply Z.log2_nonneg.
+ trans 0; [done|]. apply Z.log2_nonneg.
+Qed.
+
+Lemma Z_land_neg_pos n :
+ 0 < n →
+ 0 < Z.land n (- n).
+Proof.
+ move => Hn.
+ suff : Z.land n (- n) ≠0. { move => ?. have := Z.land_nonneg n (-n). naive_solver lia. }
+ destruct n as [|p|p]; [lia| |lia]. clear Hn.
+ elim: p.
+ - move => p ?.
+ have ->: (- Z.pos p~1 = Z.lnot (Z.pos p~1) + 1) by rewrite -Z.opp_lnot; lia.
+ rewrite Z.add_nocarry_lor. 2: bitblast.
+ move => Hx. by bitblast Hx with 0.
+ - move => p Hp.
+ have -> : - Z.pos p~0 = (- Z.pos p) ≪ 1 by [].
+ contradict Hp. bitblast as i. by bitblast Hp with (i + 1).
+ - done.
+Qed.
+
+Lemma Z_least_significant_one_xH :
+ Z_least_significant_one (Z.pos 1) = 0.
+Proof. done. Qed.
+
+Lemma Z_least_significant_one_xO p :
+ Z_least_significant_one (Z.pos (p~0)) = Z_least_significant_one (Z.pos p) + 1.
+Proof.
+ rewrite /Z_least_significant_one. do 2 (case_bool_decide; [lia|]).
+ rewrite -Z.log2_shiftl; [..|lia].
+ 2: { apply Z_land_neg_pos. lia. }
+ f_equal. have -> : - Z.pos p~0 = (- Z.pos p) ≪ 1 by [].
+ bitblast.
+Qed.
+
+Lemma Z_least_significant_one_xI p :
+ Z_least_significant_one (Z.pos (p~1)) = 0.
+Proof.
+ rewrite /Z_least_significant_one. case_bool_decide; [lia|].
+ have ->: (- Z.pos p~1 = Z.lnot (Z.pos p~1) + 1) by rewrite -Z.opp_lnot; lia.
+ apply (Z.log2_unique' _ _ 0); [lia..|]. rewrite Z.add_0_r.
+ rewrite Z.add_nocarry_lor.
+ - bitblast.
+ - bitblast.
+Qed.
+
+Lemma Z_least_significant_one_is_least_significant_one n :
+ 0 < n →
+ is_least_significant_one (Z_least_significant_one n) n.
+Proof.
+ destruct n as [|p|p]; [lia| |lia] => _.
+ elim: p.
+ - move => p IH. rewrite Z_least_significant_one_xI.
+ split; [done|lia].
+ - move => p [IH1 IH2]. rewrite Z_least_significant_one_xO.
+ split.
+ + bitblast. have := Z_least_significant_one_lower_bound_pos (Z.pos p). lia.
+ + move => i ?. bitblast. apply IH2. lia.
+ - rewrite Z_least_significant_one_xH. split; [done|lia].
+Qed.
+
+Lemma Z_least_significant_one_upper_bound n m :
+ 0 ≤ n < 2 ^ m →
+ Z_least_significant_one n < m.
+Proof.
+ move => [Hn Hnm].
+ have ? : 0 ≤ m. { have := Z.pow_neg_r 2 m. lia. }
+ destruct (decide (n = 0)).
+ { subst. rewrite /Z_least_significant_one => //=. lia. }
+ set (x := Z_least_significant_one n).
+ assert (Hx : is_least_significant_one x n).
+ { unfold x. apply Z_least_significant_one_is_least_significant_one; lia. }
+ destruct (decide (m ≤ x)) as [Hxm|]; [|lia].
+ apply (Z.pow_le_mono_r 2) in Hxm; try lia.
+ apply (Z.lt_le_trans _ _ _ Hnm) in Hxm.
+ destruct Hx as [Htestbit _].
+ rewrite Z.testbit_true in Htestbit; last by apply Z_least_significant_one_lower_bound_pos; lia.
+ rewrite Z.div_small in Htestbit; [done| lia].
Qed.
diff --git a/theories/caesium/ghost_state.v b/theories/caesium/ghost_state.v
index 09c17e9ad087d86c5914d94eeb71874e73c0103e..d1b63248502c688ab8a36060accb04106e8b3009 100644
--- a/theories/caesium/ghost_state.v
+++ b/theories/caesium/ghost_state.v
@@ -20,13 +20,13 @@ Definition heapUR : ucmra :=
gmapUR addr heap_cellR.
Class heapG Σ := HeapG {
- heap_heap_inG :> inG Σ (authR heapUR);
+ heap_heap_inG :: inG Σ (authR heapUR);
heap_heap_name : gname;
- heap_alloc_meta_map_inG :> ghost_mapG Σ alloc_id (Z * nat * alloc_kind);
+ heap_alloc_meta_map_inG :: ghost_mapG Σ alloc_id (Z * nat * alloc_kind);
heap_alloc_meta_map_name : gname;
- heap_alloc_alive_map_inG :> ghost_mapG Σ alloc_id bool;
+ heap_alloc_alive_map_inG :: ghost_mapG Σ alloc_id bool;
heap_alloc_alive_map_name : gname;
- heap_fntbl_inG :> ghost_mapG Σ addr function;
+ heap_fntbl_inG :: ghost_mapG Σ addr function;
heap_fntbl_name : gname;
}.
@@ -108,12 +108,20 @@ Section definitions.
AsFractional (alloc_alive id (DfracOwn q) a) (λ q, alloc_alive id (DfracOwn q) a) q.
Proof. split; [done|]. apply _. Qed.
- Definition alloc_global (l : loc) : iProp Σ :=
+ (** [alloc_global l] is knowledge that the provenance of [l] is
+ alive forever (i.e. corresponds to a global variable). *)
+ Definition alloc_global_def (l : loc) : iProp Σ :=
∃ id, ⌜l.1 = ProvAlloc (Some id)⌠∗ alloc_alive id DfracDiscarded true.
+ Definition alloc_global_aux : seal (@alloc_global_def). by eexists. Qed.
+ Definition alloc_global := unseal alloc_global_aux.
+ Definition alloc_global_eq : @alloc_global = @alloc_global_def :=
+ seal_eq alloc_global_aux.
+
Global Instance alloc_global_tl l : Timeless (alloc_global l).
- Proof. by apply _. Qed.
+ Proof. rewrite alloc_global_eq. by apply _. Qed.
Global Instance alloc_global_pers l : Persistent (alloc_global l).
- Proof. rewrite /alloc_global alloc_alive_eq. by apply _. Qed.
+ Proof. rewrite alloc_global_eq /alloc_global_def alloc_alive_eq. by apply _. Qed.
+
(** * Function table stuff. *)
(** [fntbl_entry l f] persistently records the information that function
@@ -227,7 +235,9 @@ Section definitions.
fntbl_ctx σ.(st_fntbl).
End definitions.
-Global Typeclasses Opaque heap_mapsto_mbyte heap_mapsto.
+Global Typeclasses Opaque alloc_meta loc_in_bounds alloc_alive alloc_global
+ fntbl_entry heap_mapsto_mbyte heap_mapsto alloc_alive_loc
+ freeable.
Notation "l ↦{ q } v" := (heap_mapsto l q v)
(at level 20, q at level 50, format "l ↦{ q } v") : bi_scope.
@@ -287,7 +297,10 @@ Section alloc_meta.
alloc_same_range a1 a2 →
a1.(al_kind) = a2.(al_kind) →
alloc_meta id a1 -∗ alloc_meta id a2.
- Proof. destruct a1 as [????], a2 as [????] => -[/= <- <-] <-. by rewrite alloc_meta_eq. Qed.
+ Proof.
+ destruct a1 as [????], a2 as [????] => -[/= <- <-] <-.
+ rewrite alloc_meta_eq. iIntros "$".
+ Qed.
Lemma alloc_meta_agree id a1 a2 :
alloc_meta id a1 -∗ alloc_meta id a2 -∗ ⌜alloc_same_range a1 a2âŒ.
@@ -484,13 +497,13 @@ Section loc_in_bounds.
(m ≤ n)%nat ->
loc_in_bounds l k n -∗ loc_in_bounds l k m.
Proof.
- move => ?. rewrite (le_plus_minus m n) // -loc_in_bounds_split_suf. iIntros "[$ _]".
+ move => ?. rewrite -(Nat.sub_add m n) // Nat.add_comm -loc_in_bounds_split_suf. iIntros "[$ _]".
Qed.
Lemma loc_in_bounds_shorten_pre l k n m:
(m ≤ n)%nat ->
loc_in_bounds l n k -∗ loc_in_bounds l m k.
Proof.
- move => ?. rewrite (le_plus_minus m n) // -loc_in_bounds_split_pre. iIntros "[_ $]".
+ move => ?. rewrite -(Nat.sub_add m n) // Nat.add_comm -loc_in_bounds_split_pre. iIntros "[_ $]".
Qed.
Local Lemma loc_in_bounds_offset_suf l1 l2 (suf1 suf2 : nat):
@@ -571,7 +584,8 @@ Section loc_in_bounds.
Lemma loc_in_bounds_in_range_uintptr_t l pre suf :
loc_in_bounds l pre suf -∗ ⌜l.2 ∈ uintptr_tâŒ.
Proof.
- etrans; first by apply loc_in_bounds_ptr_in_range. iPureIntro.
+ iIntros "Hl". iDestruct (loc_in_bounds_ptr_in_range with "Hl") as %Hrange.
+ iPureIntro. move: Hrange.
rewrite /min_alloc_start /max_alloc_end /bytes_per_addr /bytes_per_addr_log /=.
move => [??]. split; cbn; first by lia.
rewrite /max_int /= /int_modulus /bits_per_int /bytes_per_int /=. lia.
@@ -616,7 +630,7 @@ Section heap.
Global Instance heap_mapsto_mbyte_as_fractional l q v:
AsFractional (heap_mapsto_mbyte l q v) (λ q, heap_mapsto_mbyte l q v)%I q.
- Proof. split. done. apply _. Qed.
+ Proof. split; [done|]. apply _. Qed.
Global Instance heap_mapsto_timeless l q v : Timeless (l↦{q}v).
Proof. rewrite heap_mapsto_eq. apply _. Qed.
@@ -626,7 +640,7 @@ Section heap.
Global Instance heap_mapsto_as_fractional l q v:
AsFractional (l ↦{q} v) (λ q, l ↦{q} v)%I q.
- Proof. split. done. apply _. Qed.
+ Proof. split; first done. apply _. Qed.
Lemma heap_mapsto_loc_in_bounds l q v:
l ↦{q} v -∗ loc_in_bounds l 0 (length v).
@@ -684,7 +698,7 @@ Section heap.
- move => b v1 IH l /=.
rewrite heap_mapsto_cons IH assoc -heap_mapsto_cons.
rewrite shift_loc_assoc.
- by have ->:(∀ n : nat, 1 + n = S n) by lia.
+ by have -> : (∀ n : nat, 1 + n = S n) by lia.
Qed.
Lemma heap_mapsto_mbyte_agree l q1 q2 v1 v2 :
@@ -703,7 +717,7 @@ Section heap.
length v1 = length v2 →
l ↦{q1} v1 -∗ l ↦{q2} v2 -∗ ⌜v1 = v2âŒ.
Proof.
- elim: v1 v2 l. by iIntros ([] ??)"??".
+ elim: v1 v2 l. 1: by iIntros ([] ??)"??".
move => ?? IH []//=???[?].
rewrite !heap_mapsto_cons_mbyte.
iIntros "[? [_ ?]] [? [_ ?]]".
@@ -799,7 +813,9 @@ Section heap.
/to_agree_included ?; simplify_eq.
destruct ls as [|n], ls'' as [|n''],
Hincl as [[[|n'|]|] [=]%leibniz_equiv]; subst.
- by exists O. eauto. exists O. by rewrite Nat.add_0_r.
+ - by exists O.
+ - by eauto.
+ - exists O. by rewrite Nat.add_0_r.
Qed.
Lemma heap_mapsto_mbyte_lookup_1 ls l aid h b:
@@ -849,7 +865,7 @@ Section heap.
==∗ heap_ctx (<[l.2:=HeapCell aid (RSt (n2 + nf)) b]> h)
∗ heap_mapsto_mbyte_st (RSt n2) l aid q b.
Proof.
- intros Hσv. apply wand_intro_r. rewrite -!own_op to_heapUR_insert.
+ intros Hσv. do 2 apply wand_intro_r. rewrite left_id -!own_op to_heapUR_insert.
eapply own_update, auth_update, singleton_local_update.
{ by rewrite /to_heapUR lookup_fmap Hσv. }
apply prod_local_update_1, prod_local_update_2, csum_local_update_r.
@@ -893,7 +909,7 @@ Section heap.
heap_ctx h -∗ heap_mapsto_mbyte_st st1 l aid 1%Qp b
==∗ heap_ctx (<[l.2:=HeapCell aid st2 b']> h) ∗ heap_mapsto_mbyte_st st2 l aid 1%Qp b'.
Proof.
- intros Hσv. apply wand_intro_r. rewrite -!own_op to_heapUR_insert.
+ intros Hσv. do 2 apply wand_intro_r. rewrite left_id -!own_op to_heapUR_insert.
eapply own_update, auth_update, singleton_local_update.
{ by rewrite /to_heapUR lookup_fmap Hσv. }
apply exclusive_local_update. by destruct st2.
@@ -981,7 +997,7 @@ Section heap.
Proof.
iIntros "Hctx Hl".
iDestruct (heap_mapsto_is_alloc with "Hl") as %[[??]|(? & _ & ->)]; last done.
- iMod (heap_free_free_st with "[$Hctx Hl]"); last done. done.
+ iMod (heap_free_free_st with "[$Hctx Hl]"); [done| |done].
rewrite heap_mapsto_eq /heap_mapsto_def. iDestruct "Hl" as "[_ Hl]".
iApply (big_sepL_impl with "Hl"). iIntros (???) "!> H".
rewrite heap_mapsto_mbyte_eq /heap_mapsto_mbyte_def /=.
@@ -995,7 +1011,7 @@ Section alloc_alive.
Lemma alloc_alive_loc_mono (l1 l2 : loc) :
l1.1 = l2.1 →
alloc_alive_loc l1 -∗ alloc_alive_loc l2.
- Proof. by rewrite alloc_alive_loc_eq /alloc_alive_loc_def => ->. Qed.
+ Proof. rewrite alloc_alive_loc_eq /alloc_alive_loc_def => ->. by iIntros "$". Qed.
Lemma heap_mapsto_alive_strong l :
(|={⊤, ∅}=> (∃ q v, ⌜length v ≠0%nat⌠∗ l ↦{q} v)) -∗ alloc_alive_loc l.
@@ -1016,7 +1032,8 @@ Section alloc_alive.
Lemma alloc_global_alive l:
alloc_global l -∗ alloc_alive_loc l.
Proof.
- iIntros "(%id&%&Ha)". rewrite alloc_alive_loc_eq. iApply fupd_mask_intro; [set_solver|].
+ rewrite alloc_global_eq alloc_alive_loc_eq. iIntros "(%id&%&Ha)".
+ iApply fupd_mask_intro; [set_solver|].
iIntros "_". iLeft. eauto.
Qed.
diff --git a/theories/caesium/heap.v b/theories/caesium/heap.v
index 3b18752f8a72ad80a6e9612650250a9c1e3b4c6b..5ce0d5187ea36ca02fee4679ee498d6d2021ed63 100644
--- a/theories/caesium/heap.v
+++ b/theories/caesium/heap.v
@@ -584,22 +584,6 @@ Proof.
by apply: free_block_inj.
Qed.
-(*
-Inductive realloc_block : heap_state → alloc_kind → loc → val → loc → val → heap_state → Prop :=
-| ReallocBlock σ l_old l_new aid v_old v_new :
- let old_alloc := Allocation l_old.2 (length v_old) true kind in
- let new_alloc := Allocation l_new.2 (length v_new) true kind in
- (* reallocation preserves provenance *)
- l_old.1 = ProvAlloc (Some aid) →
- l_new.1 = ProvAlloc (Some aid) →
- σ.(hs_allocs) !! aid = Some old_alloc →
- allocation_in_range new_alloc →
- heap_range_free σ ?? →
- heap_lookup_loc l v_old (λ st, st = RSt 0%nat) σ.(hs_heap) →
- (* TODO: ensure that the new heap really contains v_new *)
- *)
-
-
(** ** Heap state invariant definition. *)
(** Predicate stating that every address [a] mapped by the heap of [st] has
@@ -867,4 +851,3 @@ Proof.
- move => *. naive_solver.
- by eapply heap_update_alloc_alive_in_heap.
Qed.
-
diff --git a/theories/caesium/int_type.v b/theories/caesium/int_type.v
index 7bab3c31ee0127c8402442593366f2c89ea5db6d..664e9d14abb63a325da2968ec537f6001b253817 100644
--- a/theories/caesium/int_type.v
+++ b/theories/caesium/int_type.v
@@ -94,7 +94,7 @@ Qed.
Lemma bytes_per_int_gt_0 it : bytes_per_int it > 0.
Proof.
rewrite /bytes_per_int. move: it => [log ?] /=.
- rewrite Z2Nat_inj_pow. assert (0 < 2%nat ^ log); last lia.
+ rewrite Z2Nat.inj_pow. assert (0 < 2%nat ^ log); last lia.
apply Z.pow_pos_nonneg; lia.
Qed.
@@ -112,7 +112,7 @@ Proof.
rewrite -[X in X * _]Z.pow_1_r -Z.pow_add_r; try f_equal; try lia.
rewrite /bits_per_int /bytes_per_int.
apply Z.le_add_le_sub_l. rewrite Z.add_0_r.
- rewrite Z2Nat_inj_pow.
+ rewrite Z2Nat.inj_pow.
assert (0 < 2%nat ^ it_byte_size_log it * bits_per_byte); last lia.
apply Z.mul_pos_pos; last (rewrite /bits_per_byte; lia).
apply Z.pow_pos_nonneg; lia.
@@ -148,22 +148,6 @@ Proof.
rewrite int_modulus_twice_half_modulus. specialize (int_half_modulus_ge_1 it). lia.
Qed.
-(*
- if n positive,
-Lemma it_signed_in_range_mod n it :
- n ∈ it → n `mod` int_half_modulus it = n.
-Proof.
- specialize (int_half_modulus_ge_1 it).
- move => ? [??].
-
- Search Z.modulo.
- rewrite Z.mod_small //.
- destruct it as [bs signed].
- destruct signed; unfold min_int, max_int in *; simpl in *.
- - lia. rewrite /int_half_modulus.
- speci
- *)
-
Lemma min_int_le_0 (it : int_type) : min_int it ≤ 0.
Proof.
have ? := bytes_per_int_gt_0 it. rewrite /min_int /int_half_modulus.
diff --git a/theories/caesium/lang.v b/theories/caesium/lang.v
index d63c78ae2b9ded7868174c6557ac0e8668c02cbb..ee86cb2ed32b2d1b7df31dde3e8c5d4fa3e33cc8 100644
--- a/theories/caesium/lang.v
+++ b/theories/caesium/lang.v
@@ -23,6 +23,7 @@ Inductive bin_op : Set :=
Inductive un_op : Set :=
| NotBoolOp | NotIntOp | NegOp | CastOp (ot : op_type) | EraseProv.
+
Inductive order : Set :=
| ScOrd | Na1Ord | Na2Ord.
@@ -36,7 +37,7 @@ Inductive expr :=
| CheckUnOp (op : un_op) (ot : op_type) (e : expr)
| CheckBinOp (op : bin_op) (ot1 ot2 : op_type) (e1 e2 : expr)
| CopyAllocId (ot1 : op_type) (e1 : expr) (e2 : expr)
-| Deref (o : order) (ot : op_type) (e : expr)
+| Deref (o : order) (ot : op_type) (memcast : bool) (e : expr)
| CAS (ot : op_type) (e1 e2 e3 : expr)
| Call (f : expr) (args : list expr)
| Concat (es : list expr)
@@ -56,7 +57,7 @@ Lemma expr_ind (P : expr → Prop) :
(∀ (op : un_op) (ot : op_type) (e : expr), P e → P (CheckUnOp op ot e)) →
(∀ (op : bin_op) (ot1 ot2 : op_type) (e1 e2 : expr), P e1 → P e2 → P (CheckBinOp op ot1 ot2 e1 e2)) →
(∀ (ot1 : op_type) (e1 e2 : expr), P e1 → P e2 → P (CopyAllocId ot1 e1 e2)) →
- (∀ (o : order) (ot : op_type) (e : expr), P e → P (Deref o ot e)) →
+ (∀ (o : order) (ot : op_type) (memcast : bool) (e : expr), P e → P (Deref o ot memcast e)) →
(∀ (ot : op_type) (e1 e2 e3 : expr), P e1 → P e2 → P e3 → P (CAS ot e1 e2 e3)) →
(∀ (f : expr) (args : list expr), P f → Forall P args → P (Call f args)) →
(∀ (es : list expr), Forall P es → P (Concat es)) →
@@ -134,7 +135,7 @@ with rtexpr :=
| RTCheckUnOp (op : un_op) (ot : op_type) (e : runtime_expr)
| RTCheckBinOp (op : bin_op) (ot1 ot2 : op_type) (e1 e2 : runtime_expr)
| RTCopyAllocId (ot1 : op_type) (e1 : runtime_expr) (e2 : runtime_expr)
-| RTDeref (o : order) (ot : op_type) (e : runtime_expr)
+| RTDeref (o : order) (ot : op_type) (memcast : bool) (e : runtime_expr)
| RTCall (f : runtime_expr) (args : list runtime_expr)
| RTCAS (ot : op_type) (e1 e2 e3 : runtime_expr)
| RTConcat (es : list runtime_expr)
@@ -163,7 +164,7 @@ Fixpoint to_rtexpr (e : expr) : runtime_expr :=
| CheckUnOp op ot e => RTCheckUnOp op ot (to_rtexpr e)
| CheckBinOp op ot1 ot2 e1 e2 => RTCheckBinOp op ot1 ot2 (to_rtexpr e1) (to_rtexpr e2)
| CopyAllocId ot1 e1 e2 => RTCopyAllocId ot1 (to_rtexpr e1) (to_rtexpr e2)
- | Deref o ot e => RTDeref o ot (to_rtexpr e)
+ | Deref o ot mc e => RTDeref o ot mc (to_rtexpr e)
| Call f args => RTCall (to_rtexpr f) (to_rtexpr <$> args)
| CAS ot e1 e2 e3 => RTCAS ot (to_rtexpr e1) (to_rtexpr e2) (to_rtexpr e3)
| Concat es => RTConcat (to_rtexpr <$> es)
@@ -191,12 +192,12 @@ Definition to_rtstmt (rf : runtime_function) (s : stmt) : runtime_expr :=
Global Instance to_rtexpr_inj : Inj (=) (=) to_rtexpr.
Proof.
elim => [ ^ e1 ] [ ^ e2 ] // ?; simplify_eq => //; try naive_solver.
- - f_equal. naive_solver.
+ - f_equal; [naive_solver|].
generalize dependent e2args.
- revert select (Forall _ _). elim. by case.
+ revert select (Forall _ _). elim; [by case|].
move => ????? [|??]//. naive_solver.
- generalize dependent e2es.
- revert select (Forall _ _). elim. by case.
+ revert select (Forall _ _). elim; [by case|].
move => ????? [|??]//. naive_solver.
Qed.
Global Instance to_rtstmt_inj : Inj2 (=) (=) (=) to_rtstmt.
@@ -214,7 +215,7 @@ Fixpoint subst (x : var_name) (v : val) (e : expr) : expr :=
| CheckUnOp op ot e => CheckUnOp op ot (subst x v e)
| CheckBinOp op ot1 ot2 e1 e2 => CheckBinOp op ot1 ot2 (subst x v e1) (subst x v e2)
| CopyAllocId ot1 e1 e2 => CopyAllocId ot1 (subst x v e1) (subst x v e2)
- | Deref o l e => Deref o l (subst x v e)
+ | Deref o l mc e => Deref o l mc (subst x v e)
| Call e es => Call (subst x v e) (subst x v <$> es)
| CAS ly e1 e2 e3 => CAS ly (subst x v e1) (subst x v e2) (subst x v e3)
| Concat el => Concat (subst x v <$> el)
@@ -454,8 +455,9 @@ Inductive eval_un_op : un_op → op_type → state → val → val → Prop :=
val_of_Z l.2 it None = Some vt →
is_Some (σ.(st_fntbl) !! l.2) →
eval_un_op (CastOp (IntOp it)) PtrOp σ vs vt
-| CastOpPINull it σ vs vt:
- vs = NULL →
+| CastOpPINull it σ vs vt l :
+ val_to_loc vs = Some l →
+ l = NULL_loc →
val_of_Z 0 it None = Some vt →
eval_un_op (CastOp (IntOp it)) PtrOp σ vs vt
| CastOpIP it σ vs vt l l' a:
@@ -535,7 +537,7 @@ Inductive expr_step : expr → state → list Empty_set → runtime_expr → sta
| CheckBinOpS op v1 v2 σ b ot1 ot2 :
check_bin_op op ot1 ot2 v1 v2 b →
expr_step (CheckBinOp op ot1 ot2 (Val v1) (Val v2)) σ [] (Val (val_of_bool b)) σ []
-| DerefS o v l ot v' σ:
+| DerefS o v l ot v' σ (mc : bool):
let start_st st := ∃ n, st = if o is Na2Ord then RSt (S n) else RSt n in
let end_st st :=
match o, st with
@@ -545,10 +547,14 @@ Inductive expr_step : expr → state → list Empty_set → runtime_expr → sta
| _ , _ => WSt (* unreachable *)
end
in
- let end_expr := if o is Na1Ord then Deref Na2Ord ot (Val v) else Val (mem_cast v' ot (dom σ.(st_fntbl), σ.(st_heap))) in
+ let end_expr :=
+ if o is Na1Ord then
+ Deref Na2Ord ot mc (Val v)
+ else
+ Val (if mc then mem_cast v' ot (dom σ.(st_fntbl), σ.(st_heap)) else v') in
val_to_loc v = Some l →
heap_at l (ot_layout ot) v' start_st σ.(st_heap).(hs_heap) →
- expr_step (Deref o ot (Val v)) σ [] end_expr (heap_fmap (heap_upd l v' end_st) σ) []
+ expr_step (Deref o ot mc (Val v)) σ [] end_expr (heap_fmap (heap_upd l v' end_st) σ) []
(* TODO: look at CAS and see whether it makes sense. Also allow
comparing pointers? (see lambda rust) *)
(* corresponds to atomic_compare_exchange_strong, see https://en.cppreference.com/w/c/atomic/atomic_compare_exchange *)
@@ -729,7 +735,7 @@ Inductive expr_ectx :=
| CheckBinOpRCtx (op : bin_op) (ot1 ot2 : op_type) (v1 : val)
| CopyAllocIdLCtx (ot1 : op_type) (e2 : runtime_expr)
| CopyAllocIdRCtx (ot1 : op_type) (v1 : val)
-| DerefCtx (o : order) (ot : op_type)
+| DerefCtx (o : order) (ot : op_type) (memcast : bool)
| CallLCtx (args : list runtime_expr)
| CallRCtx (f : val) (vl : list val) (el : list runtime_expr)
| CASLCtx (ot : op_type) (e2 e3 : runtime_expr)
@@ -752,7 +758,7 @@ Definition expr_fill_item (Ki : expr_ectx) (e : runtime_expr) : rtexpr :=
| CheckBinOpRCtx op ot1 ot2 v1 => RTCheckBinOp op ot1 ot2 (Val v1) e
| CopyAllocIdLCtx ot1 e2 => RTCopyAllocId ot1 e e2
| CopyAllocIdRCtx ot1 v1 => RTCopyAllocId ot1 (Val v1) e
- | DerefCtx o l => RTDeref o l e
+ | DerefCtx o l mc => RTDeref o l mc e
| CallLCtx args => RTCall e args
| CallRCtx f vl el => RTCall (Val f) ((Expr <$> (RTVal <$> vl)) ++ e :: el)
| CASLCtx ot e2 e3 => RTCAS ot e e2 e3
@@ -889,9 +895,3 @@ Canonical Structure layoutO := leibnizO layout.
Canonical Structure valO := leibnizO val.
Canonical Structure exprO := leibnizO expr.
Canonical Structure allocationO := leibnizO allocation.
-
-
-Ltac unfold_size_constants :=
- rewrite /min_alloc_start/max_alloc_end;
- rewrite /bits_per_int/bytes_per_int;
- rewrite /bytes_per_addr/bits_per_byte/bytes_per_addr_log.
diff --git a/theories/caesium/layout.v b/theories/caesium/layout.v
index 966b8fa5acb6c06907aa24da1242bae2b375389c..0c8673ce3009b7598272d81cf2ef633270af0fd3 100644
--- a/theories/caesium/layout.v
+++ b/theories/caesium/layout.v
@@ -141,12 +141,3 @@ Proof. done. Qed.
Lemma ly_align_ly_set_size ly n:
ly_align (ly_set_size ly n) = ly_align ly.
Proof. done. Qed.
-
-
-Lemma layout_wf_align_log_0 ly :
- ly_align_log ly = 0%nat → layout_wf ly.
-Proof.
- intros Ha. rewrite /layout_wf/ly_align Ha/=.
- apply Z.divide_1_l.
-Qed.
-
diff --git a/theories/caesium/lifting.v b/theories/caesium/lifting.v
index 7d24f8b0ee22a0675d82bd7d10bd442f941681d9..8ac903856853b33e82276586ac21940ff5fa3201 100644
--- a/theories/caesium/lifting.v
+++ b/theories/caesium/lifting.v
@@ -1,5 +1,4 @@
From iris.proofmode Require Import tactics.
-From iris.base_logic Require Export later_credits.
From iris.program_logic Require Export weakestpre.
From iris.program_logic Require Import ectx_lifting.
From caesium Require Export lang ghost_state time notation.
@@ -8,9 +7,9 @@ Set Default Proof Using "Type".
Import uPred.
Class refinedcG Σ := RefinedCG {
- refinedcG_invG :> invGS Σ;
- refinedcG_gen_heapG :> heapG Σ;
- refinedcG_timeGS :> timeGS Σ;
+ refinedcG_invG :: invGS Σ;
+ refinedcG_gen_heapG :: heapG Σ;
+ refinedcG_timeGS :: timeGS Σ;
refinedcG_time_dis_name : gname;
}.
@@ -176,7 +175,7 @@ Global Instance wp_expr_wp `{!refinedcG Σ} : Wp (iProp Σ) expr val stuckness :
Lemma to_expr_wp `{!refinedcG Σ} (e : expr) s E Φ :
WP e @ s; E {{ Φ }} -∗
WP (coerce_rtexpr e) @ s; E {{ Φ }}.
-Proof. done. Qed.
+Proof. auto. Qed.
Local Hint Extern 0 (reducible _ _) => eexists _, _, _, _; simpl : core.
Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _, _; simpl : core.
@@ -192,7 +191,7 @@ Global Instance cas_atomic s ot (v1 v2 v3 : val) : Atomic s (coerce_rtexpr (CAS
Proof. solve_atomic. Qed.
Global Instance skipe_atomic s (v : val) : Atomic s (coerce_rtexpr (SkipE v)).
Proof. solve_atomic. Qed.
-Global Instance deref_atomic s (l : loc) ly : Atomic s (coerce_rtexpr (Deref ScOrd ly l)).
+Global Instance deref_atomic s (l : loc) ly mc : Atomic s (coerce_rtexpr (Deref ScOrd ly mc l)).
Proof. solve_atomic. Qed.
(*Global Instance use_atomic s (l : loc) ly : Atomic s (coerce_rtexpr (Use ScOrd ly l)).*)
(*Proof. solve_atomic. Qed.*)
@@ -229,7 +228,7 @@ Section logical_steps.
logical_step E (|={E}=> P) -∗
logical_step E P.
Proof.
- rewrite /logical_step. setoid_rewrite fupd_trans. done.
+ rewrite /logical_step. setoid_rewrite fupd_trans. auto.
Qed.
Lemma logical_step_intro E P :
@@ -371,32 +370,6 @@ End logical_steps.
Section lifting.
Context `{!refinedcG Σ}.
-
-
- (* what kinds of lemmas do we get?
- wp_credit_access
-
-
- - if I have atime n (banked n), then I get n credits in the post.
- - if I have ptime n, then I can't compositionally get credits in the post from that
- (because, it is persistent, I could do it multiple times)
- I can only do that to compose in parallel
- I should be able to do however:
- if I have ptime n, and P is guarded under n laters, then I get P in the post (because I can compose that in parallel)
-
- intuition: I reserve n later credits for direct spending.
- Problem: this might be hard to prove. If we apply that rule multiple times, we need to "bundle up" all the Ps, because we can only do this stripping once.
- (only when I actually do the step should I take ownership of the generated credits and do it.)
-
- So: this doesn't really work like that. I need to do this parallelization manually.
-
- maybe: use our notion of delayed_prop. this composes in parallel with ptime, and then have a rule for pure steps that eliminates delayed_prop.
- I think we mostly need it for skips (when unblocking) anyways.
-
- - need a rule for putting credits + atime in the post for credit generation.
- *)
-
-
(** steps related to time receipts *)
(* We can use a additive time receipt to generate credits. *)
@@ -470,68 +443,6 @@ Section lifting.
WP e @ s; E {{ v, |={E}=> Φ v }} -∗ WP e @ s; E {{ Φ }}.
Proof. rewrite /wp /wp_expr_wp. iApply wp_fupd. Qed.
-
- (* TODO: the following lemmas reprove stuff from the lifting lemmas... *)
- (* Reason: we want to generate a time receipt atime, but that is difficult.
-
- Ideally, we'd like to get the lemma [wp_additive_time_receipt] below, but that is incompatible with our invariant,
- as we can't know that we have not just disabled more atimes.
- (we don't get a lemma similar to [step_additive_time_receipt] for [timec_interp]).
- That would seem incompatible with [wp_credit_access]...
- *)
- (*
- Lemma wp_additive_time_receipt E e Φ :
- TCEq (to_val e) None → ↑timeN ⊆ E →
- time_ctx -∗
- WP e @ (E∖↑timeN) {{ v, atime 1 -∗ Φ v }} -∗
- WP e @ E {{ Φ }}.
- Proof.
- rewrite !wp_unfold /wp_pre /=. iIntros (-> ?) "#TIME Hwp".
- iIntros (?????) "[Hσ Ht]".
- (*iMod (step_additive_time_receipt with "TIME Ht") as "[Ht Hclose]"=>//.*)
- iMod ("Hwp" $! _ _ _ [] 0%nat with "[$]") as "[$ Hwp]".
- iIntros "!>" (e2 σ2 efs stp). iMod ("Hwp" $! e2 σ2 efs stp) as "Hwp".
- iIntros "!> !>". iMod "Hwp". iModIntro.
- iApply (step_fupdN_wand with "Hwp"). iIntros ">([$ Ht] & Hwp & $)".
- iMod ("Hclose" with "Ht") as "[$ ?]".
- iApply (wp_wand with "[Hwp]"); [iApply (wp_mask_mono with "Hwp"); solve_ndisj|].
- iIntros "!> % H". by iApply "H".
- Qed.
- *)
-
- (*
- Lemma wp_pure_step_atime s E E' e1 e2 φ n Φ :
- PureExec φ 1 e1 e2 →
- φ →
- ↑timeN ⊆ E' →
- time_ctx -∗
- atime n -∗
- (|={E}[E']▷=> (£ (S n) -∗ atime (S n) -∗ WP e2 @ s; E {{ Φ }})) -∗
- WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros (Hexec Hφ ?) "#CTX Hc Hwp". specialize (Hexec Hφ).
- inversion Hexec as [ | ???? [Hred Hsafe] Hb]; inversion Hb; subst.
- iApply wp_lift_step_fupd.
- { specialize (Hred inhabitant).
- eapply reducible_not_val, reducible_no_obs_reducible, Hred. }
- iIntros (σ1 ns κ κs nt) "(Hσ & Ht)".
- iMod "Hwp". iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
- iModIntro. iSplit.
- { iPureIntro. destruct s; last done. eapply reducible_no_obs_reducible, Hred. }
- iIntros (e2' σ2 efs Hstep) "Hcred". iModIntro. iNext.
- destruct (Hsafe _ _ _ _ _ Hstep) as (-> & -> & -> & ->).
- iMod "Hclose" as "_".
- iMod (timec_interp_bound_atime with "CTX Ht Hc") as "(Ht & Hc & %)"; first done.
- iMod (timec_interp_alloc_atime _ 1 with "CTX Ht") as "($ & Hc2)"; first done.
- iMod (flc_weaken _ (S n) with "Hcred") as "Hcred". { simpl. lia. }
- iMod "Hwp". iModIntro.
- replace (S n) with (1 + n)%nat by lia.
- iDestruct ("Hwp" with "Hcred [Hc Hc2]") as "$".
- { iSplitL "Hc2"; done. }
- iFrame. done.
- Qed.
- *)
-
Lemma lc_elim_step_fupdN E E' n P :
£ n -∗
(|={E}[E']▷=>^n P) -∗
@@ -545,39 +456,6 @@ Section lifting.
iMod "HP". iApply ("IH" with "Hc HP").
Qed.
- (* When taking a step, we access a delayed prop *)
- (*
- Lemma wp_pure_step_ptime s ϕ n E E' e1 e2 Φ :
- PureExec ϕ 1 e1 e2 →
- ϕ →
- ↑timeN ⊆ E →
- time_ctx -∗
- ptime n -∗
- (atime 1 -∗ £ 1 -∗ |={E}[E']▷=>^n WP e2 @ s; E {{ Φ }}) -∗
- WP e1 @ s; E {{ Φ }}.
- Proof.
- iIntros (Hexec HÏ• ?) "#CTX Hp Hwp". specialize (Hexec HÏ•).
- inversion Hexec as [ | ???? [Hred Hsafe] Hb]; inversion Hb; subst.
- iApply wp_lift_step_fupd.
- { specialize (Hred inhabitant).
- eapply reducible_not_val, reducible_no_obs_reducible, Hred. }
- iIntros (σ1 ns κ κs nt) "(Hσ & Ht)".
- iMod (fupd_mask_subseteq ∅) as "Hclose"; first set_solver.
- iModIntro. iSplit.
- { iPureIntro. destruct s; last done. eapply reducible_no_obs_reducible, Hred. }
- iIntros (e2' σ2 efs Hstep) "Hcred". iModIntro. iNext.
- destruct (Hsafe _ _ _ _ _ Hstep) as (-> & -> & -> & ->).
- iMod "Hclose" as "_".
- iMod (timec_interp_bound_ptime with "CTX Ht Hp") as "(Ht & %)"; first done.
- iMod (timec_interp_alloc_atime _ 1 with "CTX Ht") as "($ & Hc2)"; first done.
- iMod (flc_weaken _ (S n) with "Hcred") as "Hcred". { simpl. lia. }
- rewrite (flc_succ n). iDestruct "Hcred" as "[H1 Hcred]".
- iSpecialize ("Hwp" with "Hc2 H1").
- iMod (flc_step_fupdN with "Hcred Hwp") as "Hwp".
- iFrame. iModIntro. done.
- Qed.
- *)
-
(* TODO: add this lemma to iris? *)
Lemma wp_lift_head_step_fupdN {s E Φ} e1 :
to_val e1 = None →
@@ -722,7 +600,6 @@ Section lifting.
-∗ WP to_rtstmt rf s @ E {{ Φ }}.
Proof. iIntros "HWP". iApply wp_c_lift_step_fupd => //. naive_solver. Qed.
-
Lemma wp_c_lift_step_credits E n m e step_rel Φ:
↑timeN ⊆ E →
((∃ e', e = to_rtexpr e' ∧ step_rel = expr_step e') ∨
@@ -769,7 +646,6 @@ Section lifting.
-∗ WP to_rtstmt rf s @ E {{ Φ }}.
Proof. iIntros (?) "CTX Hc Hp HWP". iApply (wp_c_lift_step_credits with "CTX Hc Hp") => //. naive_solver. Qed.
-
Lemma wp_c_lift_step E e step_rel Φ:
((∃ e', e = to_rtexpr e' ∧ step_rel = expr_step e') ∨
(∃ rf s, e = to_rtstmt rf s ∧ step_rel = stmt_step s rf)) →
@@ -1001,7 +877,7 @@ Proof.
iIntros ([[h ub] fn]) "((%&Hhctx&Hactx)&Hfctx)/=".
iDestruct (heap_mapsto_is_alloc with "Hmt") as %Haid.
destruct o; try by destruct Ho.
- - iModIntro. iDestruct (heap_mapsto_lookup_q (λ st, ∃ n, st = RSt n) with "Hhctx Hmt") as %Hat. naive_solver.
+ - iModIntro. iDestruct (heap_mapsto_lookup_q (λ st, ∃ n, st = RSt n) with "Hhctx Hmt") as %Hat. { naive_solver. }
iSplit; first by eauto 11 using DerefS.
iIntros (? e2 σ2 efs Hst ?) "!> Hcred Hc !>". inv_expr_step.
iSplit => //. unfold end_st, end_expr.
@@ -1036,7 +912,7 @@ Proof.
iIntros ([[h ub] fn]) "((%&Hhctx&Hactx)&Hfctx)/=".
iDestruct (heap_mapsto_is_alloc with "Hmt") as %Haid.
destruct o; try by destruct Ho.
- - iModIntro. iDestruct (heap_mapsto_lookup_q (λ st, ∃ n, st = RSt n) with "Hhctx Hmt") as %Hat. naive_solver.
+ - iModIntro. iDestruct (heap_mapsto_lookup_q (λ st, ∃ n, st = RSt n) with "Hhctx Hmt") as %Hat. { naive_solver. }
iSplit; first by eauto 11 using DerefS.
iIntros (? e2 σ2 efs Hst ?) "!> Hcred !>". inv_expr_step.
iSplit => //. unfold end_st, end_expr.
@@ -1314,7 +1190,7 @@ Proof.
all: destruct l; simplify_eq/=.
all: have ? := val_to_of_loc NULL_loc.
all: unfold NULL in *; by simplify_eq.
- - move => ->. by econstructor.
+ - move => ->. by econstructor; try apply val_to_of_loc.
Qed.
Lemma wp_cast_int_ptr_weak Φ v a E it:
@@ -1524,14 +1400,14 @@ Proof.
- rewrite /int_half_modulus.
move ? : (bits_per_int it - 1) => k.
have Hb : ∀ n, -2^k ≤ n ≤ 2^k - 1 ↔ ∀ l, k ≤ l → Z.testbit n l = bool_decide (n < 0).
- { move => ?. rewrite -Z_bounded_iff_bits; lia. }
+ { move => ?. rewrite -Z.bounded_iff_bits; lia. }
move => /Hb Hn1 /Hb Hn2.
apply Hb => l Hl.
by rewrite Htestbit Hsign Hn1 ?Hn2.
- rewrite /int_modulus.
move ? : (bits_per_int it) => k.
have Hb : ∀ n, 0 ≤ n → n ≤ 2^k - 1 ↔ ∀ l, k ≤ l → Z.testbit n l = bool_decide (n < 0).
- { move => ??. rewrite bool_decide_false -?Z_bounded_iff_bits_nonneg; lia. }
+ { move => ??. rewrite bool_decide_false -?Z.bounded_iff_bits_nonneg; lia. }
move => [Hn1 /Hb HN1] [Hn2 /Hb HN2].
have Hn := Hnonneg Hn1 Hn2.
split; first done.
@@ -1539,27 +1415,6 @@ Proof.
by rewrite Htestbit HN1 ?HN2.
Qed.
-
-(* one possible semantics:
- interpret as unsigned, then add, then wrap.
-Definition wrap_to_it (n : Z) (it : int_type) : Z :=
-
-
-Definition int_wrap_modulus (it : int_type) : Z :=
- if it_signed it then int_half_modulus it else int_modulus it.
-
-Lemma int_arithop_wrap_in_range (it : int_type) n :
- n ∈ it → n `mod` (int_wrap_modulus it) = n.
-Proof.
- intros Hel. destruct it as [bs signed].
- destruct signed; rewrite /int_wrap_modulus; simpl.
- - admit.
- - rewrite it_in_range_mod; done.
- rewrite int_modulus_mod_in_range.
- int_half_modulus
- Search Z.modulo int_half_modulus.
- *)
-
Lemma int_arithop_result_in_range (it : int_type) (n1 n2 n : Z) op :
n1 ∈ it → n2 ∈ it → int_arithop_result it n1 n2 op = Some n →
int_arithop_sidecond it n1 n2 n op → n ∈ it.
@@ -2031,7 +1886,6 @@ Lemma wp_concat_bind E Φ es:
WP Concat es @ E {{ Φ }}.
Proof. by iApply (wps_concat_bind_ind []). Qed.
-
Lemma wp_struct_init'' `{!LayoutAlg} E Φ sl fs:
foldr (λ '(n, ly) f, (λ vl,
WP (default (Val (replicate (ly_size ly) MPoison)) (n' ↠n; (list_to_map fs : gmap _ _) !! n'))
@@ -2111,58 +1965,6 @@ Proof.
simpl. rewrite pad_struct_snoc_None; done.
Qed.
-(* A slightly more usable version defined via a fixpoint *)
-Fixpoint struct_init_components `{!LayoutAlg} E (fields : list (var_name * syn_type)) (fs : list (string * expr)) (Φ : list val → iProp Σ) : iProp Σ :=
- match fields with
- | [] => Φ []
- | (n, st) :: fields' =>
- ∀ ly, ⌜syn_type_has_layout st ly⌠-∗
- WP (default (Val (replicate (ly_size ly) MPoison)) ((list_to_map fs : gmap _ _) !! n)) @ E {{ v, struct_init_components E fields' fs (λ vs, Φ (v :: vs)) }}
- end.
-Instance struct_init_components_proper `{!LayoutAlg} E fields fs :
- Proper (((=) ==> (≡)) ==> (≡)) (struct_init_components E fields fs).
-Proof.
- intros a b Heq.
- induction fields as [ | [ n st] fields IH] in a, b, Heq|-*; simpl.
- { by iApply Heq. }
- do 3 f_equiv.
- apply wp_proper. intros ?. apply IH.
- intros ? ? ->. apply Heq. done.
-Qed.
-Lemma wp_struct_init2 `{!LayoutAlg} E (Φ : val → iProp Σ) (sls : struct_layout_spec) (sl : struct_layout) (fs : list (string * expr)) :
- use_struct_layout_alg sls = Some sl →
- struct_init_components E sls.(sls_fields) fs (λ vl : list val, Φ (mjoin (M:=list)(pad_struct sl.(sl_members) vl (λ ly, (replicate (ly_size ly) MPoison))))) -∗
- WP StructInit sls fs @ E {{ Φ }}.
-Proof.
- iIntros (Halg) "Hinit".
- iApply wp_struct_init; first done.
- apply use_struct_layout_alg_inv in Halg as (mems & Halg & Hfields).
- efeed pose proof struct_layout_alg_has_fields as Hmems; first apply Halg.
- move: Hfields Hmems. clear Halg.
- generalize (sls_fields sls) as fields => fields.
- rewrite /sl_has_members.
- generalize (sl_members sl) as all_mems => all_mems.
- move => Hfields ?. clear sls. subst mems.
-
- (* hack because rewrite doesn't work *)
- iAssert (∀ vi Φ,
- struct_init_components E fields fs (λ vl : list val, Φ (vi ++ vl)) -∗
- foldr (λ '(n, st) (f : list val → iPropI Σ) (vl : list val), ∀ ly : layout, ⌜syn_type_has_layout st ly⌠-∗ WP default (Val $ replicate (ly_size ly) ☠%V) (list_to_map (M:=gmap _ _) fs !! n) @ E {{ v, f (vl ++ [v]) }}) (λ vl : list val, Φ vl) fields vi)%I as "Ha".
- {
- iIntros (vi Ψ) "Ha". clear Hfields.
- iInduction fields as [ | [n st] fields] "IH" forall (vi); simpl.
- { rewrite app_nil_r. done. }
- iIntros (ly) "%Hst". iPoseProof ("Ha" $! ly with "[//]") as "Ha".
- iApply (wp_wand with "Ha").
- iIntros (v) "Hinit".
- iApply "IH".
- iClear "IH".
- iStopProof.
- rewrite struct_init_components_proper; first eauto.
- intros ?? ->. by rewrite -app_assoc. }
- by iApply "Ha".
-Qed.
-
Lemma wp_enum_init `{!LayoutAlg} E Φ (els : enum_layout_spec) el variant rsty e :
use_enum_layout_alg els = Some el →
WP e @ E {{ v,
@@ -2297,14 +2099,14 @@ Lemma stmt_wp_unfold s E Q Ψ :
Proof. by rewrite stmt_wp_eq. Qed.
Lemma fupd_wps s E Q Ψ :
- (|={E}=> WPs s @ E {{ Q, Ψ }}) -∗ WPs s @ E{{ Q, Ψ }}.
+ (|={E}=> WPs s @ E {{ Q, Ψ }}) ⊢ WPs s @ E{{ Q, Ψ }}.
Proof.
rewrite stmt_wp_unfold. iIntros "Hs" (? rf HQ) "HΨ".
iApply fupd_wp. by iApply "Hs".
Qed.
Lemma wps_fupd s E Q Ψ :
- WPs s @ E {{ Q, (λ v, |={E}=> Ψ v)}} -∗ WPs s @ E {{ Q, Ψ }}.
+ WPs s @ E {{ Q, (λ v, |={E}=> Ψ v)}} ⊢ WPs s @ E {{ Q, Ψ }}.
Proof.
rewrite !stmt_wp_unfold. iIntros "Hs" (? rf HQ) "HΨ".
iApply wp_fupd. iApply "Hs"; first done.
@@ -2329,11 +2131,6 @@ Proof.
iApply "HΨ". iApply "H". iApply "Hv".
Qed.
-(* TODO what is a good way to get a rule corresponding to [wp_logical_step]?
- The problem is that we can't really bind on [WPs], so that we can't easily get it directly after the enext step.
- Would have to build logical_step into all statement stepping rules?
- *)
-
Lemma wp_call_credits vf vl f fn Φ n m :
val_to_loc vf = Some f →
Forall2 has_layout_val vl (f_args fn).*2 →
@@ -2370,7 +2167,7 @@ Proof.
iDestruct ("HWP" $! lsa lsv with "[//] Hla [Hlv] Hcred Hc") as "Ha". {
rewrite big_sepL2_fmap_r. iApply (big_sepL2_mono with "Hlv") => ??? ?? /=.
iIntros "?". iExists _. iFrame. iPureIntro. split; first by apply replicate_length.
- apply: Forall2_lookup_lr. 2: done. done. rewrite list_lookup_fmap. apply fmap_Some. naive_solver.
+ apply: Forall2_lookup_lr. 2: done. 1: done. rewrite list_lookup_fmap. apply fmap_Some. naive_solver.
}
iApply fupd_wp. iMod "Ha" as (Ψ') "(HQinit & HΨ')". iModIntro.
rewrite stmt_wp_eq. iApply "HQinit" => //.
@@ -2432,7 +2229,7 @@ Proof.
iDestruct ("HWP" $! lsa lsv with "[//] Hla [Hlv] Hcred") as (Ψ') "(HQinit & HΨ')". {
rewrite big_sepL2_fmap_r. iApply (big_sepL2_mono with "Hlv") => ??? ?? /=.
iIntros "?". iExists _. iFrame. iPureIntro. split; first by apply replicate_length.
- apply: Forall2_lookup_lr. 2: done. done. rewrite list_lookup_fmap. apply fmap_Some. naive_solver.
+ apply: Forall2_lookup_lr. 2: done. 1: done. rewrite list_lookup_fmap. apply fmap_Some. naive_solver.
}
iFrame. rewrite stmt_wp_eq. iApply "HQinit" => //.
@@ -2557,7 +2354,7 @@ Proof.
iDestruct (heap_mapsto_lookup_1 (λ st : lock_state, st = RSt 0%nat) with "Hhctx Hl") as %? => //.
iSplit; first by eauto 12 using AssignS.
iIntros (? e2 σ2 efs Hstep ?) "Hcred Hat !> !>". inv_stmt_step. unfold end_val.
- iMod (heap_write with "Hhctx Hl") as "[$ Hl]" => //. congruence.
+ iMod (heap_write with "Hhctx Hl") as "[$ Hl]" => //; first congruence.
iMod ("HWP" with "Hl Hat Hcred") as "HWP".
iModIntro => /=. iSplit; first done. iFrame. iSplit; first done. by iApply "HWP".
- iMod (heap_write_na _ _ _ vr with "Hhctx Hl") as (?) "[Hhctx Hc]" => //; first by congruence.
@@ -2595,7 +2392,7 @@ Proof.
iDestruct (heap_mapsto_lookup_1 (λ st : lock_state, st = RSt 0%nat) with "Hhctx Hl") as %? => //.
iSplit; first by eauto 12 using AssignS.
iIntros (? e2 σ2 efs Hstep ?) "Hcred !> !>". inv_stmt_step. unfold end_val.
- iMod (heap_write with "Hhctx Hl") as "[$ Hl]" => //. congruence.
+ iMod (heap_write with "Hhctx Hl") as "[$ Hl]" => //; first congruence.
iMod ("HWP" with "Hl Hcred") as "HWP".
iModIntro => /=. iSplit; first done. iFrame. iSplit; first done. by iApply "HWP".
- iMod (heap_write_na _ _ _ vr with "Hhctx Hl") as (?) "[Hhctx Hc]" => //; first by congruence.
@@ -2725,7 +2522,7 @@ Proof.
iIntros "!#" (b P HPs).
iDestruct 1 as (s HQ) "#Hs".
iIntros "!# HP".
- iApply wps_goto. by apply: lookup_weaken.
+ iApply wps_goto; first by apply: lookup_weaken.
iModIntro. by iApply "Hs".
Qed.
diff --git a/theories/caesium/loc.v b/theories/caesium/loc.v
index e7c6bd20f942cb75a0c17ebdde4f4b8a224eef57..8e9beb41711ffe25662c818b59f077eb49e68413 100644
--- a/theories/caesium/loc.v
+++ b/theories/caesium/loc.v
@@ -163,7 +163,7 @@ Proof.
move => Hl. apply Z.divide_add_r.
- apply: has_layout_loc_trans => //. rewrite {1}/ly_align_log/=. destruct n; lia.
- rewrite/ly_offset. destruct n;[by subst;apply Z.divide_0_r|].
- etrans;[apply Zdivide_nat_pow, Min.le_min_r|]. by apply factor2_divide.
+ etrans;[apply Zdivide_nat_pow, Nat.le_min_r|]. by apply factor2_divide.
Qed.
Lemma has_layout_loc_ly_mult_offset l ly n:
diff --git a/theories/caesium/notation.v b/theories/caesium/notation.v
index 4a056f43ccb0b730c86403849363994e9dcb674f..24ca1d5215d100a81eafbf4e634a06fe4e0a3c68 100644
--- a/theories/caesium/notation.v
+++ b/theories/caesium/notation.v
@@ -8,8 +8,9 @@ Definition string_to_varname (s : string) : var_name := s.
Coercion string_to_varname : string >-> var_name.
Coercion it_layout : int_type >-> layout.
Notation "☠" := MPoison : val_scope.
-Notation "!{ ot , o } e" := (Deref o ot e%E) (at level 9, format "!{ ot , o } e") : expr_scope.
-Notation "!{ ot } e" := (Deref Na1Ord ot e%E) (at level 9, format "!{ ot } e") : expr_scope.
+Notation "!{ ot , o , mc } e" := (Deref o ot mc e%E) (at level 9, format "!{ ot , o , mc } e") : expr_scope.
+Notation "!{ ot , o } e" := (Deref o ot true e%E) (at level 9, format "!{ ot , o } e") : expr_scope.
+Notation "!{ ot } e" := (Deref Na1Ord ot true e%E) (at level 9, format "!{ ot } e") : expr_scope.
(* − is a unicode minus, not the normal minus to prevent parsing conflicts *)
Notation "'−' '{' ot } e" := (UnOp NegOp ot e%E)
(at level 40, format "'−' '{' ot } e") : expr_scope.
@@ -93,9 +94,10 @@ Notation "'free{' e_size ',' e_align '}' e_ptr ; s" := (Free e_size%E e_align%E
(** This has a skip in order to facilitate unblocking. *)
-Definition Use (o : order) (ot : op_type) (e : expr) := Deref o ot (SkipE e).
-Notation "'use{' ot , o } e" := (Use o ot e%E) (at level 9, format "'use{' ot , o } e") : expr_scope.
-Notation "'use{' ot } e" := (Use Na1Ord ot e%E) (at level 9, format "'use{' ot } e") : expr_scope.
+Definition Use (o : order) (ot : op_type) (memcast : bool) (e : expr) := Deref o ot memcast (SkipE e).
+Notation "'use{' ot , o , mc } e" := (Use o ot mc e%E) (at level 9, format "'use{' ot , o , mc } e") : expr_scope.
+Notation "'use{' ot , o } e" := (Use o ot true e%E) (at level 9, format "'use{' ot , o } e") : expr_scope.
+Notation "'use{' ot } e" := (Use Na1Ord ot true e%E) (at level 9, format "'use{' ot } e") : expr_scope.
Arguments Use : simpl never.
Global Typeclasses Opaque Use.
@@ -168,10 +170,9 @@ Notation "'annot:' a ; s" := (AnnotStmt 1%nat a s%E)
Arguments AnnotStmt : simpl never.
Global Typeclasses Opaque AnnotStmt.
-
-Definition Move (o : order) (ot : op_type) (e : expr) := Deref o ot e.
-Notation "'move{' ot , o } e" := (Move o (UntypedOp ot) e%E) (at level 9, format "'move{' ot , o } e") : expr_scope.
-Notation "'move{' ot } e" := (Move Na1Ord (UntypedOp ot) e%E) (at level 9, format "'move{' ot } e") : expr_scope.
+Definition Move (o : order) (ot : op_type) (memcast : bool) (e : expr) := Deref o ot memcast e.
+Notation "'move{' ot , o , mc } e" := (Move o (UntypedOp ot) mc e%E) (at level 9, format "'move{' ot , o , mc } e") : expr_scope.
+Notation "'move{' ot } e" := (Move Na1Ord (UntypedOp ot) true e%E) (at level 9, format "'move{' ot } e") : expr_scope.
Arguments Move : simpl never.
Global Typeclasses Opaque Move.
@@ -226,13 +227,13 @@ Lemma annot_expr_S {A} n (a : A) e:
Proof. done. Qed.
Lemma annot_expr_S_r {A} n (a : A) e:
AnnotExpr (S n) a e = (AnnotExpr n a (SkipE e)).
-Proof. by rewrite /AnnotExpr Nat_iter_S_r. Qed.
+Proof. by rewrite /AnnotExpr Nat.iter_succ_r. Qed.
Lemma annot_stmt_S {A} n (a : A) s:
AnnotStmt (S n) a s = SkipES (AnnotStmt n a s).
Proof. done. Qed.
Lemma annot_stmt_S_r {A} n (a : A) s:
AnnotStmt (S n) a s = (AnnotStmt n a (SkipES s)).
-Proof. by rewrite /AnnotStmt Nat_iter_S_r. Qed.
+Proof. by rewrite /AnnotStmt Nat.iter_succ_r. Qed.
(** Call notation including lifetime instantiation *)
Definition CallE (ef : expr) (eκs : list string) (es : list expr) := Call ef es.
@@ -326,10 +327,10 @@ Notation zst_val := ([] : val).
(*** Tests *)
Example test1 (l : loc) ly ot :
(l <-{ly} use{ot}(&l +{PtrOp, IntOp usize_t} (l ={PtrOp, PtrOp, i32} l)); ExprS (Call l [ (l : expr); (l : expr)]) (l <-{ly, ScOrd} l; Goto "a"))%E =
- (AssignSE Na1Ord ly l (Use Na1Ord ot (BinOp AddOp PtrOp (IntOp usize_t) (AddrOf l) (BinOp (EqOp i32) PtrOp PtrOp l l))))
+ (AssignSE Na1Ord ly l (Use Na1Ord ot true (BinOp AddOp PtrOp (IntOp usize_t) (AddrOf l) (BinOp (EqOp i32) PtrOp PtrOp l l))))
(ExprS (Call l [ Val (val_of_loc l); Val (val_of_loc l)]) ((AssignSE ScOrd ly l l) (Goto "a"))).
Proof. simpl. reflexivity. Abort.
Example test_get_member `{!LayoutAlg} (l : loc) (sls : struct_layout_spec) ot :
- (!{ot} (!{ot, ScOrd} l) at{sls} "a")%E = GetMember (Deref Na1Ord ot (Deref ScOrd ot l%E)) sls "a".
+ (!{ot} (!{ot, ScOrd} l) at{sls} "a")%E = GetMember (Deref Na1Ord ot true (Deref ScOrd ot true l%E)) sls "a".
Proof. simpl. reflexivity. Abort.
diff --git a/theories/caesium/proofmode.v b/theories/caesium/proofmode.v
index e4deece713b13e525e171125081c1c8d60367704..6ec57306320bcf5e451f44a82755b7a1d6d38bee 100644
--- a/theories/caesium/proofmode.v
+++ b/theories/caesium/proofmode.v
@@ -8,7 +8,7 @@ Import uPred.
Lemma tac_wps_bind `{refinedcG Σ} `{!LayoutAlg} e Ks Q Ψ E s:
W.find_stmt_fill s = Some (Ks, e) →
- WP (W.to_expr e) @ E {{ v, WPs W.to_stmt (W.stmt_fill Ks (W.Val v)) @ E {{ Q, Ψ }} }} -∗
+ WP (W.to_expr e) @ E {{ v, WPs W.to_stmt (W.stmt_fill Ks (W.Val v)) @ E {{ Q, Ψ }} }} ⊢
WPs (W.to_stmt s) @ E {{ Q, Ψ }}.
Proof.
move => /W.find_stmt_fill_correct ->. iIntros "He".
@@ -30,7 +30,7 @@ Tactic Notation "wps_bind" :=
end.
Lemma tac_wp_bind' `{refinedcG Σ} `{!LayoutAlg} e Ks Φ E:
- WP (W.to_expr e) @ E {{ v, WP (W.to_expr (W.fill Ks (W.Val v))) @ E{{ Φ }} }} -∗
+ WP (W.to_expr e) @ E {{ v, WP (W.to_expr (W.fill Ks (W.Val v))) @ E{{ Φ }} }} ⊢
WP (W.to_expr (W.fill Ks e)) @ E {{ Φ }}.
Proof.
iIntros "HWP".
@@ -42,7 +42,7 @@ Qed.
Lemma tac_wp_bind `{refinedcG Σ} `{!LayoutAlg} e Ks e' Φ E:
W.find_expr_fill e false = Some (Ks, e') →
- WP (W.to_expr e') @ E {{ v, if Ks is [] then Φ v else WP (W.to_expr (W.fill Ks (W.Val v))) @ E{{ Φ }} }} -∗
+ WP (W.to_expr e') @ E {{ v, if Ks is [] then Φ v else WP (W.to_expr (W.fill Ks (W.Val v))) @ E{{ Φ }} }} ⊢
WP (W.to_expr e) @ E {{ Φ }}.
Proof.
move => /W.find_expr_fill_correct ->. move: Ks => [|K Ks] //.
@@ -58,4 +58,3 @@ Tactic Notation "wp_bind" :=
unfold W.to_expr; simpl
| _ => fail "wp_bind: not a 'wp'"
end.
-
diff --git a/theories/caesium/struct.v b/theories/caesium/struct.v
index b70c63b6da4bcc700dc2c9215cabe10ed0c1c38b..6607e406f5c83adc7925feaab06bc071f7e2efc9 100644
--- a/theories/caesium/struct.v
+++ b/theories/caesium/struct.v
@@ -214,7 +214,7 @@ Proof.
destruct j; simpl in *.
- destruct n', l; simplify_eq; destruct Ha; done.
- destruct n'; simplify_eq; simpl.
- + eapply IH; first done. done.
+ + eapply IH; [done.. | ].
destruct Ha; first by left.
right. rewrite field_idx_of_idx_cons_Some in H.
destruct l; simpl in *; lia.
@@ -238,7 +238,7 @@ Lemma pad_struct_snoc_Some {A} s n ly ls (l : A) f :
length (field_names s) = length ls →
pad_struct (s ++ [(Some n, ly)]) (ls ++ [l]) f = pad_struct s ls f ++ [l].
Proof.
- elim: s ls => /=. by destruct ls.
+ elim: s ls => /=. 1: by destruct ls.
move => -[n' ly'] s IH ls /=. case_match.
- destruct ls => //= -[?]. f_equal. by apply IH.
- move => ?. f_equal. by apply IH.
@@ -285,10 +285,10 @@ Qed.
Lemma offset_of_from_in m s:
Some m ∈ s.*1 → ∃ n, offset_of s m = Some n.
Proof.
- elim: s. set_solver.
+ elim: s. 1: set_solver.
move => [??]? IH. rewrite offset_of_cons'. csimpl => ?.
case_decide => //; [ naive_solver |].
- have [|? ->]:= IH. by set_solver.
+ have [|? ->] := IH. 1: by set_solver.
naive_solver.
Qed.
@@ -324,20 +324,6 @@ Proof.
- rewrite shift_loc_assoc_nat. apply IH => //. apply: has_layout_loc_trans => //. rewrite /ly_align_log. lia.
Qed.
-Lemma struct_layout_member_size_bound sl n :
- ∀ on ly, (on, ly) ∈ sl_members sl → ly_size sl ≤ n → ly_size ly ≤ n.
-Proof.
- intros on ly.
- rewrite /layout_of{1}/ly_size/=.
- generalize (sl_members sl) as mems.
- induction mems as [ | [n2 ly2] mem IH].
- { intros []%elem_of_nil. }
- intros Ha%elem_of_cons. destruct Ha as [[= <- <-] | Hel].
- - simpl. lia.
- - simpl. intros Ha. apply IH; first done.
- unfold fmap. lia.
-Qed.
-
Definition GetMemberLoc (l : loc) (s : struct_layout) (m : var_name) : loc :=
(l +â‚— Z.of_nat (default 0%nat (offset_of s.(sl_members) m))).
Notation "l 'at{' s '}â‚—' m" := (GetMemberLoc l s m) (at level 10, format "l 'at{' s '}â‚—' m") : stdpp_scope.
diff --git a/theories/caesium/syntypes.v b/theories/caesium/syntypes.v
index 621e7cfdf1d7e74364e20dd48834abd78f30b792..27a1d7ad1e8f3ae946a62943bdf8cca2c4b014da 100644
--- a/theories/caesium/syntypes.v
+++ b/theories/caesium/syntypes.v
@@ -264,20 +264,7 @@ Record enum_layout_spec : Set := mk_els
(* This is fixed (and not something chooseable by the layout algorithm), because Rust's MIR already has this type fixed. *)
els_tag_it : IntType;
els_variants : list (string * syn_type);
- (* This is additional information that doesn't affect the layout algorithm, but just the operational behavior of enum operations *)
els_tag_int : list (var_name * Z);
- (* The variant list should have no duplicates *)
- els_variants_nodup :
- NoDup (fmap fst els_variants);
- (* The variant lists should agree *)
- els_tag_int_agree :
- fmap fst els_tag_int = fmap fst els_variants;
- (* the tags should have no duplicates *)
- els_tag_int_nodup:
- NoDup (fmap snd els_tag_int);
- (* the tags should be in range of the integer type for the tags *)
- els_tag_int_wf3 :
- Forall (λ '(_, tag), tag ∈ (els_tag_it : int_type)) els_tag_int;
}.
Definition syn_type_of_els (els : enum_layout_spec) : syn_type :=
@@ -351,16 +338,6 @@ Solve Obligations with done.
More restrictively, in order to make [NonNull::dangling] work, the alignment also needs to be a valid address. *)
Definition ly_align_in_bounds (ly : layout) :=
min_alloc_start ≤ ly_align ly ≤ max_alloc_end.
-Lemma ly_align_in_bounds_1 ly :
- ly_align_log ly = 0%nat → ly_align_in_bounds ly.
-Proof.
- rewrite /ly_align_in_bounds/ly_align => ->.
- unfold_size_constants. simpl; nia.
-Qed.
-
-(* check that enum tags are in range of the tag integer type *)
-Definition enum_check_tags_in_range (it : IntType) (tags : list (var_name * Z)) : bool :=
- bool_decide (Forall (λ '(_, tag), tag ∈ it) tags).
(** Use a layout algorithm recursively on a layout spec. *)
(* NOTE on size limits from https://doc.rust-lang.org/stable/reference/types/numeric.html#machine-dependent-integer-types:
diff --git a/theories/caesium/tactics.v b/theories/caesium/tactics.v
index ea7a15c8927d3c10f7b81a31a379b6974c3ad173..bcfcbab154504583f474be1c681424f7cf60b0d7 100644
--- a/theories/caesium/tactics.v
+++ b/theories/caesium/tactics.v
@@ -15,7 +15,7 @@ Inductive expr :=
| CheckUnOp (op : un_op) (ot : op_type) (e : expr)
| CheckBinOp (op : bin_op) (ot1 ot2 : op_type) (e1 e2 : expr)
| CopyAllocId (ot1 : op_type) (e1 e2 : expr)
-| Deref (o : order) (ot : op_type) (e : expr)
+| Deref (o : order) (ot : op_type) (memcast : bool) (e : expr)
| CAS (ot : op_type) (e1 e2 e3 : expr)
| Call (f : expr) (eκs : list string) (args : list expr)
| Concat (es : list expr)
@@ -26,7 +26,7 @@ Inductive expr :=
(* new constructors *)
| LogicalAnd (ot1 ot2 : op_type) (rit : int_type) (e1 e2 : expr)
| LogicalOr (ot1 ot2 : op_type) (rit : int_type) (e1 e2 : expr)
-| Use (o : order) (ot : op_type) (e : expr)
+| Use (o : order) (ot : op_type) (memcast : bool) (e : expr)
| AddrOf (m : mutability) (e : expr)
| LValue (e : expr)
| GetMember (e : expr) (s : struct_layout_spec) (m : var_name)
@@ -56,7 +56,7 @@ Lemma expr_ind (P : expr → Prop) :
(∀ (op : un_op) (ot : op_type) (e : expr), P e → P (CheckUnOp op ot e)) →
(∀ (op : bin_op) (ot1 ot2 : op_type) (e1 e2 : expr), P e1 → P e2 → P (CheckBinOp op ot1 ot2 e1 e2)) →
(∀ (ot1 : op_type) (e1 e2 : expr), P e1 → P e2 → P (CopyAllocId ot1 e1 e2)) →
- (∀ (o : order) (ot : op_type) (e : expr), P e → P (Deref o ot e)) →
+ (∀ (o : order) (ot : op_type) (mc : bool) (e : expr), P e → P (Deref o ot mc e)) →
(∀ (ot : op_type) (e1 e2 e3 : expr), P e1 → P e2 → P e3 → P (CAS ot e1 e2 e3)) →
(∀ (f : expr) (eκs : list string) (args : list expr), P f → Forall P args → P (Call f eκs args)) →
(∀ (es : list expr), Forall P es → P (Concat es)) →
@@ -66,7 +66,7 @@ Lemma expr_ind (P : expr → Prop) :
(P StuckE) →
(∀ (ot1 ot2 : op_type) (rit : int_type) (e1 e2 : expr), P e1 → P e2 → P (LogicalAnd ot1 ot2 rit e1 e2)) →
(∀ (ot1 ot2 : op_type) (rit : int_type) (e1 e2 : expr), P e1 → P e2 → P (LogicalOr ot1 ot2 rit e1 e2)) →
- (∀ (o : order) (ot : op_type) (e : expr), P e → P (Use o ot e)) →
+ (∀ (o : order) (ot : op_type) (mc : bool) (e : expr), P e → P (Use o ot mc e)) →
(∀ (m : mutability) (e : expr), P e → P (AddrOf m e)) →
(∀ (e : expr), P e → P (LValue e)) →
(∀ (e : expr) (s : struct_layout_spec) (m : var_name), P e → P (GetMember e s m)) →
@@ -111,7 +111,7 @@ Fixpoint to_expr `{!LayoutAlg} (e : expr) : lang.expr :=
| CheckUnOp op ot e => lang.CheckUnOp op ot (to_expr e)
| CheckBinOp op ot1 ot2 e1 e2 => lang.CheckBinOp op ot1 ot2 (to_expr e1) (to_expr e2)
| CopyAllocId ot1 e1 e2 => lang.CopyAllocId ot1 (to_expr e1) (to_expr e2)
- | Deref o ot e => lang.Deref o ot (to_expr e)
+ | Deref o ot mc e => lang.Deref o ot mc (to_expr e)
| CAS ot e1 e2 e3 => lang.CAS ot (to_expr e1) (to_expr e2) (to_expr e3)
| Call f eκs args => notation.CallE (to_expr f) eκs (to_expr <$> args)
| Concat es => lang.Concat (to_expr <$> es)
@@ -121,7 +121,7 @@ Fixpoint to_expr `{!LayoutAlg} (e : expr) : lang.expr :=
| StuckE => lang.StuckE
| LogicalAnd ot1 ot2 rit e1 e2 => notation.LogicalAnd ot1 ot2 rit (to_expr e1) (to_expr e2)
| LogicalOr ot1 ot2 rit e1 e2 => notation.LogicalOr ot1 ot2 rit (to_expr e1) (to_expr e2)
- | Use o ot e => notation.Use o ot (to_expr e)
+ | Use o ot mc e => notation.Use o ot mc (to_expr e)
| AddrOf m e => notation.Raw m (to_expr e)
| LValue e => notation.LValue (to_expr e)
| AnnotExpr n a e => notation.AnnotExpr n a (to_expr e)
@@ -183,8 +183,8 @@ Ltac of_expr e :=
let e1 := of_expr e1 in
let e2 := of_expr e2 in
constr:(LogicalOr ot1 ot2 rit e1 e2)
- | notation.Use ?o ?ot ?e =>
- let e := of_expr e in constr:(Use o ot e)
+ | notation.Use ?o ?ot ?mc ?e =>
+ let e := of_expr e in constr:(Use o ot mc e)
| lang.Val ?x => constr:(Val x)
| lang.Var ?x => constr:(Var x)
| lang.UnOp ?op ?ot ?e =>
@@ -197,8 +197,8 @@ Ltac of_expr e :=
let e1 := of_expr e1 in let e2 := of_expr e2 in constr:(CheckBinOp op ot1 ot2 e1 e2)
| lang.CopyAllocId ?ot1 ?e1 ?e2 =>
let e1 := of_expr e1 in let e2 := of_expr e2 in constr:(CopyAllocId ot1 e1 e2)
- | lang.Deref ?o ?ot ?e =>
- let e := of_expr e in constr:(Deref o ot e)
+ | lang.Deref ?o ?ot ?mc ?e =>
+ let e := of_expr e in constr:(Deref o ot mc e)
| lang.CAS ?ot ?e1 ?e2 ?e3 =>
let e1 := of_expr e1 in let e2 := of_expr e2 in let e3 := of_expr e3 in constr:(CAS ot e1 e2 e3)
| notation.CallE ?f ?eκs ?args =>
@@ -239,7 +239,7 @@ Inductive ectx_item :=
| CheckBinOpRCtx (op : bin_op) (ot1 ot2 : op_type) (v1 : val)
| CopyAllocIdLCtx (ot1 : op_type) (e2 : expr)
| CopyAllocIdRCtx (ot1 : op_type) (v1 : val)
-| DerefCtx (o : order) (l : op_type)
+| DerefCtx (o : order) (l : op_type) (mc : bool)
| CASLCtx (ot : op_type) (e2 e3 : expr)
| CASMCtx (ot : op_type) (v1 : val) (e3 : expr)
| CASRCtx (ot : op_type) (v1 v2 : val)
@@ -251,7 +251,7 @@ Inductive ectx_item :=
| AllocRCtx (v_size : val)
| SkipECtx
(* new constructors *)
-| UseCtx (o : order) (ot : op_type)
+| UseCtx (o : order) (ot : op_type) (mc : bool)
| AddrOfCtx (m : mutability)
| LValueCtx
| AnnotExprCtx (n : nat) {A} (a : A)
@@ -276,7 +276,7 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
| CheckBinOpRCtx op ot1 ot2 v1 => CheckBinOp op ot1 ot2 (Val v1) e
| CopyAllocIdLCtx ot1 e2 => CopyAllocId ot1 e e2
| CopyAllocIdRCtx ot1 v1 => CopyAllocId ot1 (Val v1) e
- | DerefCtx o l => Deref o l e
+ | DerefCtx o l mc => Deref o l mc e
| CASLCtx ot e2 e3 => CAS ot e e2 e3
| CASMCtx ot v1 e3 => CAS ot (Val v1) e e3
| CASRCtx ot v1 v2 => CAS ot (Val v1) (Val v2) e
@@ -287,7 +287,7 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
| AllocLCtx e_align => Alloc e e_align
| AllocRCtx v_size => Alloc (Val v_size) e
| SkipECtx => SkipE e
- | UseCtx o l => Use o l e
+ | UseCtx o l mc => Use o l mc e
| AddrOfCtx m => AddrOf m e
| LValueCtx => LValue e
| AnnotExprCtx n a => AnnotExpr n a e
@@ -359,10 +359,10 @@ Fixpoint find_expr_fill (e : expr) (bind_val : bool) : option (list ectx_item *
| SkipE e1 =>
if find_expr_fill e1 bind_val is Some (Ks, e') then
Some (Ks ++ [SkipECtx], e') else Some ([], e)
- | Deref o ly e1 => if find_expr_fill e1 bind_val is Some (Ks, e') then
- Some (Ks ++ [DerefCtx o ly], e') else Some ([], e)
- | Use o ly e1 => if find_expr_fill e1 bind_val is Some (Ks, e') then
- Some (Ks ++ [UseCtx o ly], e') else Some ([], e)
+ | Deref o ly mc e1 => if find_expr_fill e1 bind_val is Some (Ks, e') then
+ Some (Ks ++ [DerefCtx o ly mc], e') else Some ([], e)
+ | Use o ly mc e1 => if find_expr_fill e1 bind_val is Some (Ks, e') then
+ Some (Ks ++ [UseCtx o ly mc], e') else Some ([], e)
| AddrOf m e1 => if find_expr_fill e1 bind_val is Some (Ks, e') then
Some (Ks ++ [AddrOfCtx m], e') else Some ([], e)
| LValue e1 => if find_expr_fill e1 bind_val is Some (Ks, e') then
@@ -396,7 +396,7 @@ Qed.
Lemma ectx_item_correct `{!LayoutAlg} Ks:
∃ Ks', ∀ e, to_rtexpr (to_expr (fill Ks e)) = ectxi_language.fill Ks' (to_rtexpr (to_expr e)).
Proof.
- elim/rev_ind: Ks. by exists [].
+ elim/rev_ind: Ks; [by exists []|].
move => K Ks [Ks' IH].
eexists (Ks' ++ (ExprCtx <$> ?[K])) => ?. rewrite fill_app ectxi_language.fill_app /= -IH.
only [K]: (destruct K; [
@@ -408,7 +408,7 @@ Proof.
apply: [lang.CheckBinOpRCtx _ _ _ _]|
apply: [lang.CopyAllocIdLCtx _ _]|
apply: [lang.CopyAllocIdRCtx _ _]|
- apply: [lang.DerefCtx _ _]|
+ apply: [lang.DerefCtx _ _ _]|
apply: [lang.CASLCtx _ _ _]|
apply: [lang.CASMCtx _ _ _]|
apply: [lang.CASRCtx _ _ _]|
@@ -419,7 +419,7 @@ Proof.
apply: [lang.AllocLCtx _]|
apply: [lang.AllocRCtx _]|
apply: [lang.SkipECtx]|
- apply: [lang.SkipECtx; lang.DerefCtx _ _]|
+ apply: [lang.SkipECtx; lang.DerefCtx _ _ _]|
apply: [lang.SkipECtx]|
apply: []|
apply: (replicate n lang.SkipECtx)|
@@ -526,11 +526,11 @@ Ltac of_stmt s :=
| notation.LocInfo ?a ?s =>
let s := of_stmt s in
constr:(LocInfoS a s)
- | notation.Assert ?ot ?e ?s =>
+ | (assert{?ot}: ?e ; ?s)%E =>
let e := of_expr e in
let s := of_stmt s in
constr:(Assert ot e s)
- | lang.IfS ?ot ?e ?s1 ?s2 =>
+ | (if{?ot}: ?e then ?s1 else ?s2)%E =>
let e := of_expr e in
let s1 := of_stmt s1 in
let s2 := of_stmt s2 in
@@ -653,6 +653,7 @@ Definition list_find_fast {A} (P : A → Prop) `{!∀ x, Decision (P x)} :=
| x :: l => if decide (P x) then Some x else go l
end.
Global Instance: Params (@list_find_fast) 3 := {}.
+
Fixpoint subst_l (xs : list (var_name * val)) (e : expr) : expr :=
match e with
| Var y => if list_find_fast (λ x, x.1 = y) xs is Some (_, v) then Val v else Var y
@@ -663,7 +664,7 @@ Fixpoint subst_l (xs : list (var_name * val)) (e : expr) : expr :=
| CheckUnOp op ot e => CheckUnOp op ot (subst_l xs e)
| CheckBinOp op ot1 ot2 e1 e2 => CheckBinOp op ot1 ot2 (subst_l xs e1) (subst_l xs e2)
| CopyAllocId ot1 e1 e2 => CopyAllocId ot1 (subst_l xs e1) (subst_l xs e2)
- | Deref o l e => Deref o l (subst_l xs e)
+ | Deref o l mc e => Deref o l mc (subst_l xs e)
| CAS ot e1 e2 e3 => CAS ot (subst_l xs e1) (subst_l xs e2) (subst_l xs e3)
| Call f eκs args => Call (subst_l xs f) eκs (subst_l xs <$> args)
| Concat es => Concat (subst_l xs <$> es)
@@ -673,7 +674,7 @@ Fixpoint subst_l (xs : list (var_name * val)) (e : expr) : expr :=
| StuckE => StuckE
| LogicalAnd ot1 ot2 rit e1 e2 => LogicalAnd ot1 ot2 rit (subst_l xs e1) (subst_l xs e2)
| LogicalOr ot1 ot2 rit e1 e2 => LogicalOr ot1 ot2 rit (subst_l xs e1) (subst_l xs e2)
- | Use o ot e => Use o ot (subst_l xs e)
+ | Use o ot mc e => Use o ot mc (subst_l xs e)
| AddrOf m e => AddrOf m (subst_l xs e)
| LValue e => LValue (subst_l xs e)
| AnnotExpr n a e => AnnotExpr n a (subst_l xs e)
diff --git a/theories/caesium/time.v b/theories/caesium/time.v
index 2357521d05c1fee66fb9b8e10823824d3b5c268f..2f8807acd0d91149e2ef54b48d955dee491b290f 100644
--- a/theories/caesium/time.v
+++ b/theories/caesium/time.v
@@ -9,8 +9,8 @@ Set Default Proof Using "Type".
Import uPred.
Class timeGS Σ := TimeGS {
- time_mono_nat_inG :> inG Σ mono_natR;
- time_nat_inG :> inG Σ (authR natUR);
+ time_mono_nat_inG :: inG Σ mono_natR;
+ time_nat_inG :: inG Σ (authR natUR);
time_global_name : gname;
time_persistent_name : gname;
time_additive_name : gname;
@@ -18,8 +18,8 @@ Class timeGS Σ := TimeGS {
#[export] Hint Mode timeGS - : typeclass_instances.
Class timeGpreS Σ := TimePreGS {
- time_preG_mono_nat_inG :> inG Σ mono_natR;
- time_preG_nat_inG :> inG Σ (authR natUR);
+ time_preG_mono_nat_inG :: inG Σ mono_natR;
+ time_preG_nat_inG :: inG Σ (authR natUR);
}.
#[export] Hint Mode timeGpreS - : typeclass_instances.
@@ -72,18 +72,19 @@ Section time.
Lemma time_interp_step n :
time_interp n ==∗ time_interp (S n).
- Proof. eapply own_update, mono_nat_update. lia. Qed.
+ Proof. rewrite -own_update; first auto. eapply mono_nat_update. lia. Qed.
Lemma persistent_time_receipt_mono n m :
(n ≤ m)%nat → ptime m -∗ ptime n.
Proof.
- intros ?. unfold persistent_time_receipt. by apply own_mono, mono_nat_lb_mono.
+ intros ?. unfold persistent_time_receipt.
+ rewrite own_mono; first auto. by apply mono_nat_lb_mono.
Qed.
Lemma additive_time_receipt_mono n m :
(n ≤ m)%nat → atime m -∗ atime n.
Proof.
intros ?. unfold additive_time_receipt.
- by apply own_mono, auth_frag_mono, nat_included.
+ rewrite own_mono; first auto. by apply auth_frag_mono, nat_included.
Qed.
Lemma persistent_time_receipt_sep n m : ptime (n `max` m) ⊣⊢ ptime n ∗ ptime m.
@@ -91,12 +92,16 @@ Section time.
Lemma additive_time_receipt_sep n m : atime (n + m) ⊣⊢ atime n ∗ atime m.
Proof. by rewrite /additive_time_receipt -nat_op auth_frag_op own_op. Qed.
+ Global Instance persistent_time_receipt_combine_sep n m : CombineSepAs ptime n ptime m ptime (n `max` m).
+ Proof. rewrite /CombineSepAs. by rewrite persistent_time_receipt_sep. Qed.
Global Instance persistent_time_receipt_from_sep n m : FromSep ptime (n `max` m) ptime n ptime m.
Proof. rewrite /FromSep. by rewrite persistent_time_receipt_sep. Qed.
Global Instance persistent_time_receipt_into_sep n m : IntoSep ptime (n `max` m) ptime n ptime m.
Proof. rewrite /IntoSep. by rewrite persistent_time_receipt_sep. Qed.
Global Instance additive_time_receipt_from_sep n m : FromSep atime (n + m) atime n atime m.
Proof. rewrite /FromSep. by rewrite additive_time_receipt_sep. Qed.
+ Global Instance additive_time_receipt_combine_sep n m : CombineSepAs atime n atime m atime (n + m).
+ Proof. rewrite /CombineSepAs. by rewrite additive_time_receipt_sep. Qed.
Global Instance additive_time_receipt_into_sep n m : IntoSep atime (n + m) atime n atime m.
Proof. rewrite /IntoSep. by rewrite additive_time_receipt_sep. Qed.
diff --git a/theories/caesium/val.v b/theories/caesium/val.v
index 775934e91230d00ed89f35e33b3f68598a3f5880..55f19b5e23769b4fab9f5df6847f0369f06cee92 100644
--- a/theories/caesium/val.v
+++ b/theories/caesium/val.v
@@ -173,8 +173,8 @@ Lemma val_to_of_Z_go z (sz : nat) p:
Proof.
rewrite /bits_per_byte.
elim: sz z => /=. 1: rewrite /Z.of_nat; move => ??; f_equal; lia.
- move => sz IH z [? Hlt]. rewrite IH /byte_modulus /= -?Z_div_mod_eq //.
- split. apply Z_div_pos => //. apply Zdiv_lt_upper_bound => //.
+ move => sz IH z [? Hlt]. rewrite IH /byte_modulus /= -?Z_div_mod_eq_full //.
+ split; [by apply Z_div_pos|]. apply Zdiv_lt_upper_bound => //.
rewrite Nat2Z.inj_succ -Zmult_succ_l_reverse Z.pow_add_r // in Hlt.
lia.
Qed.
@@ -233,7 +233,7 @@ Proof.
+ move => [??] [] ?. simplify_eq.
assert (2 ^ (bytes_per_int it * bits_per_byte) =
2 * 2 ^ (bytes_per_int it * bits_per_byte - 1)) as Heq.
- { rewrite Z.sub_1_r. rewrite Z_pow_pred_r => //. rewrite /bits_per_byte.
+ { rewrite Z.sub_1_r. rewrite Z.pow_pred_r => //. rewrite /bits_per_byte.
have ? := bytes_per_int_gt_0 it. lia. }
rewrite Heq. lia.
+ move => [??] [] ?. lia.
diff --git a/theories/lithium/Z_bitblast.v b/theories/lithium/Z_bitblast.v
index d4128547d10ead2cd336fd9f09ee6357b0e48504..f3247b45096ccfff36ed232dc089615b1a06a3c9 100644
--- a/theories/lithium/Z_bitblast.v
+++ b/theories/lithium/Z_bitblast.v
@@ -244,7 +244,7 @@ Lemma bitblast_id_bounded z z' n :
Bitblast z n (bool_decide (0 ≤ n < z') && BITBLAST_TESTBIT z n).
Proof.
move => [Hb]. constructor.
- move: (Hb) => /Z_bounded_iff_bits_nonneg' Hn.
+ move: (Hb) => /Z.bounded_iff_bits_nonneg' Hn.
case_bool_decide => //=.
destruct (decide (0 ≤ n)); [|rewrite Z.testbit_neg_r //; lia].
apply Hn; try lia.
@@ -381,7 +381,7 @@ Proof.
move => [->] [<-]. constructor.
case_bool_decide => /=. { rewrite Z.pow_neg_r ?bool_decide_false /= ?orb_false_r; [done|lia..]. }
destruct (decide (0 ≤ n)). 2: { rewrite !Z.testbit_neg_r ?andb_false_r //; lia. }
- rewrite -Z.land_ones; [|lia]. rewrite Z.land_spec Z_ones_spec; [|lia..].
+ rewrite -Z.land_ones; [|lia]. rewrite Z.land_spec Z.ones_spec; [|lia..].
by rewrite andb_comm.
Qed.
Global Hint Resolve bitblast_mod | 10 : bitblast.
@@ -558,7 +558,7 @@ Goal ∀ z, 0 ≤ z < 2 ^ 64 →
Proof.
move => z ?. split.
- move => Hx. split.
- + apply Z_bounded_iff_bits_nonneg; [lia..|] => n ?. bitblast.
+ + apply Z.bounded_iff_bits_nonneg; [lia..|] => n ?. bitblast.
by bitblast Hx with n.
+ bitblast as n. by bitblast Hx with n.
- move => [H1 H2]. bitblast as n. by bitblast H2 with n.
diff --git a/theories/lithium/all.v b/theories/lithium/all.v
new file mode 100644
index 0000000000000000000000000000000000000000..11cab27ec34ef2486619c2e709366f27a01942d5
--- /dev/null
+++ b/theories/lithium/all.v
@@ -0,0 +1,4 @@
+From lithium Require Export definitions simpl_classes simpl_instances proof_state interpreter normalize solvers syntax instances.
+
+(** This file reexports all files from Lithium except [hooks.v] such
+that the definitions from [hooks.v] don't accidentally override the redefinitions. *)
diff --git a/theories/lithium/base.v b/theories/lithium/base.v
index 9393a0121caa487e70dde44ead9d18de1c2fca33..7cf9cbeac85a4bff4c9a0eadbf67aa089875103a 100644
--- a/theories/lithium/base.v
+++ b/theories/lithium/base.v
@@ -7,7 +7,7 @@ From iris.program_logic Require Import weakestpre.
From iris.bi Require Import bi.
From iris.proofmode Require Import proofmode.
From stdpp Require Import natmap.
-From lithium Require Import Z_bitblast.
+From stdpp.unstable Require Import bitblast.
From RecordUpdate Require Export RecordSet.
Export RecordSetNotations.
@@ -22,6 +22,8 @@ Export Set Warnings "+deprecated-hint-without-locality".
Export Set Warnings "+deprecated-hint-rewrite-without-locality".
Export Set Warnings "+deprecated-typeclasses-transparency-without-locality".
+Export Set Default Goal Selector "!".
+
(* ensure that set from RecordUpdate simplifies when it is applied to a concrete value *)
Global Arguments set _ _ _ _ _ !_ /.
@@ -41,6 +43,7 @@ Global Arguments Pos.shiftl : simpl never.
Global Arguments Pos.shiftr : simpl never.
Global Opaque Z.shiftl Z.shiftr.
+(* TODO: upstream to stdpp? *)
Notation "'[@{' A '}' x ; y ; .. ; z ]" := (@cons A x (@cons A y .. (@cons A z (@nil A)) ..)) (only parsing) : list_scope.
Notation "'[@{' A '}' x ]" := (@cons A x nil) (only parsing) : list_scope.
Notation "'[@{' A '}' ]" := (@nil A) (only parsing) : list_scope.
@@ -111,6 +114,11 @@ Ltac evar_safe_vm_compute :=
vm_compute;
apply H.
+(* see https://github.com/coq/coq/issues/15768#issuecomment-1380773542 *)
+(* TODO: This must be called as [unfold_opaque @x]. Is there a way to
+get rid of the @? *)
+Tactic Notation "unfold_opaque" constr(c) := with_strategy 0 [c] (unfold c).
+
(*
The following tactics are currently not used.
@@ -182,6 +190,19 @@ Global Existing Instance tc_one_is_some3_left.
Global Existing Instance tc_one_is_some3_middle.
Global Existing Instance tc_one_is_some3_right.
+Class IsVar {A} (x : A) : Prop := is_var: True.
+Global Hint Extern 0 (IsVar ?x) => (is_var x; exact: I) : typeclass_instances.
+
+Class TCDone (P : Prop) : Prop := done_proof : P.
+Global Hint Extern 1 (TCDone ?P) => (change P; done) : typeclass_instances.
+
+(** [AssumeInj] is a hint that automation should treat f as if it were
+injective, even though the injectivity might not be provable. *)
+Class AssumeInj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop := assume_inj : True.
+Global Instance assume_inj_inj A B R S (f : A → B) `{!Inj R S f} : AssumeInj R S f.
+Proof. done. Qed.
+
+
Definition exists_dec_unique {A} (x : A) (P : _ → Prop) : (∀ y, P y → P x) → Decision (P x) → Decision (∃ y, P y).
Proof.
intros Hx Hdec.
@@ -232,7 +253,7 @@ Proof. by intros ?? ->%leibniz_equiv. Qed.
(** * list *)
Lemma zip_fmap_r {A B C} (l1 : list A) (l2 : list B) (f : B → C) :
zip l1 (f <$> l2) = (λ x, (x.1, f x.2)) <$> zip l1 l2.
-Proof. rewrite zip_with_fmap_r zip_with_zip. by apply: list_fmap_ext => // [[]]. Qed.
+Proof. rewrite zip_with_fmap_r zip_with_zip. by apply: list_fmap_ext => // ? []. Qed.
Lemma zip_with_nil_inv' {A B C : Type} (f : A → B → C) (l1 : list A) (l2 : list B) :
length l1 = length l2 → zip_with f l1 l2 = [] → l1 = [] ∧ l2 = [].
@@ -280,12 +301,10 @@ Lemma list_elem_of_insert2' {A} (l : list A) i (x1 x2 x3 : A) :
l !! i = Some x3 → x1 ∈ l → x1 ≠x3 → x1 ∈ <[i:=x2]> l.
Proof. move => ???. efeed pose proof (list_elem_of_insert2 (A:=A)) as Hi; naive_solver. Qed.
-
Lemma list_fmap_ext' {A B} f (g : A → B) (l1 l2 : list A) :
(∀ x, x ∈ l1 → f x = g x) → l1 = l2 → f <$> l1 = g <$> l2.
Proof. intros ? <-. induction l1; f_equal/=; set_solver. Qed.
-
Lemma imap_fst_NoDup {A B C} l (f : nat → A → B) (g : nat → C):
Inj eq eq g →
NoDup (imap (λ i o, (g i, f i o)) l).*1.
@@ -297,8 +316,8 @@ Global Instance set_unfold_imap A B f (l : list A) (x : B):
SetUnfoldElemOf x (imap f l) (∃ i y, x = f i y ∧ l !! i = Some y).
Proof.
constructor.
- elim: l f => /=. set_solver. set_unfold. move => ? ? IH f.
- rewrite IH {IH}. split. case.
+ elim: l f => /=; [set_solver|]. set_unfold. move => ? ? IH f.
+ rewrite IH {IH}. split; [case|].
- move => ->. set_solver.
- move => [n [v [-> ?]]]. exists (S n), v => /=. set_solver.
- move => [[|n] /= [v [-> ?]]]; simplify_eq; [by left | right].
@@ -334,9 +353,10 @@ Lemma length_filter_insert {A} P `{!∀ x, Decision (P x)} (l : list A) i x x':
length (filter P (<[i:=x]>l)) =
(length (filter P l) + (if bool_decide (P x) then 1 else 0) - (if bool_decide (P x') then 1 else 0))%nat.
Proof.
- elim: i l. move => [] //=??[->]. rewrite !filter_cons. by repeat (case_decide; case_bool_decide) => //=; lia.
- move => i IH [|? l]//=?. rewrite !filter_cons. case_decide => //=; rewrite IH // -minus_Sn_m //.
- repeat case_bool_decide => //; try lia. feed pose proof (length_filter_gt P l x') => //; try lia.
+ elim: i l.
+ - move => [] //=??[->]. rewrite !filter_cons. by repeat (case_decide; case_bool_decide) => //=; lia.
+ - move => i IH [|? l]//=?. rewrite !filter_cons. case_decide => //=; rewrite IH // Nat.sub_succ_l //.
+ repeat case_bool_decide => //; try lia. feed pose proof (length_filter_gt P l x') => //; try lia.
by apply: elem_of_list_lookup_2.
Qed.
@@ -352,7 +372,7 @@ Lemma omap_app {A B} (f : A → option B) (s1 s2 : list A):
Proof. elim: s1 => //. csimpl => ?? ->. case_match; naive_solver. Qed.
Lemma sum_list_with_take {A} f (l : list A) i:
(sum_list_with f (take i l) ≤ sum_list_with f l)%nat.
-Proof. elim: i l => /=. lia. move => ? IH [|? l2] => //=. move: (IH l2). lia. Qed.
+Proof. elim: i l => /=; [lia|]. move => ? IH [|? l2] => //=. move: (IH l2). lia. Qed.
Lemma omap_length_eq {A B C} (f : A → option B) (g : A → option C) (l : list A):
(∀ i x, l !! i = Some x → const () <$> (f x) = const () <$> (g x)) →
@@ -410,9 +430,25 @@ Proof.
move => Hs Hi Hj HR Hneq. elim: Hs j i Hj Hi => // z {}l _ IH /Forall_forall Hall.
case => /=.
- case; first naive_solver. move => n [?]/= /(elem_of_list_lookup_2 _ _ _)?; subst. naive_solver.
- - move => n. case; first lia. move => n2 /= ??. apply lt_n_S. naive_solver.
+ - move => n. case; first lia. move => n2 /= ??. apply->Nat.succ_lt_mono. naive_solver.
Qed.
+(* TODO: Is it possible to make this lemma more general and add it as an instance? *)
+Lemma list_fmap_Forall2_proper {A B} (R : relation B) :
+ Proper (pointwise_relation A R ==> (=) ==> Forall2 R) fmap.
+Proof.
+ move => ?? Hf ?? ->. apply Forall2_fmap.
+ apply Forall_Forall2_diag, Forall_true => *.
+ eapply Hf.
+Qed.
+(* TODO: Can one make this an instance? *)
+Lemma default_proper {A} (R : relation A) :
+ Proper (R ==> option_Forall2 R ==> R) default.
+Proof. move => ?? ? [?|] [?|] //= Hopt; by inversion Hopt. Qed.
+
+Global Instance head_proper {A} (R : relation A): Proper (Forall2 R ==> option_Forall2 R) head.
+Proof. move => ?? [] * /=; by constructor. Qed.
+
(** * vec *)
Lemma vec_cast {A} n (v : vec A n) m:
n = m → ∃ v' : vec A m, vec_to_list v = vec_to_list v'.
@@ -588,11 +624,11 @@ Lemma big_sepL_impl' {B} Φ (Ψ : _ → B → _) (l1 : list A) (l2 : list B) :
Proof.
iIntros (Hlen) "Hl #Himpl".
iInduction l1 as [|x1 l1] "IH" forall (Φ Ψ l2 Hlen); destruct l2 => //=; simpl in *.
- iDestruct "Hl" as "[Hx1 Hl]". iSplitL "Hx1". by iApply "Himpl".
+ iDestruct "Hl" as "[Hx1 Hl]". iSplitL "Hx1"; [by iApply "Himpl"|].
iApply ("IH" $! (Φ ∘ S) (Ψ ∘ S) l2 _ with "[] Hl").
iIntros "!>" (k y1 y2 ?) "Hl2 /= ?".
- by iApply ("Himpl" with "[] [Hl2]").
- Unshelve. lia.
+ by iApply ("Himpl" with "[] [Hl2]").
+ Unshelve. lia.
Qed.
End sep_list.
@@ -634,7 +670,7 @@ Definition factor2 (n : nat) (def : nat) : nat :=
default def (factor2' n).
Definition keep_factor2 (n : nat) (def : nat) : nat :=
- default def (pow 2 <$> factor2' n).
+ default def (Nat.pow 2 <$> factor2' n).
Lemma Pos_pow_add_r a b c:
(a ^ (b + c) = a ^ b * a ^ c)%positive.
@@ -670,13 +706,13 @@ Lemma Zdivide_nat_pow a b c:
((b ≤ c)%nat → ((a ^ b)%nat | (a ^ c)%nat))%Z.
Proof.
move => ?. apply: (Zdivide_mult_l _ (a^(c - b))%nat).
- by rewrite -Nat2Z.inj_mul -Nat.pow_add_r le_plus_minus_r.
+ by rewrite -Nat2Z.inj_mul -Nat.pow_add_r Nat.add_comm Nat.sub_add.
Qed.
Lemma Pos_factor2_divide p :
((2 ^ Pos_factor2 p)%nat | Z.pos p)%Z.
Proof.
- elim: p => //=. by move => *; apply Z.divide_1_l.
+ elim: p => //=. 1: by move => *; apply Z.divide_1_l.
move => p IH. rewrite -plus_n_O Pos2Z.inj_xO Nat2Z.inj_add Z.add_diag. by apply Z.mul_divide_mono_l.
Qed.
@@ -784,8 +820,8 @@ Proof. by destruct n. Qed.
(* Qed. *)
Lemma divide_mult_2 n1 n2 : divide 2 (n1 * n2) → divide 2 n1 ∨ divide 2 n2.
- move => /Nat2Z_divide. rewrite Nat2Z.inj_mul. move => /(prime_mult _ prime_2).
- move => [H|H]; [left | right]; apply Z2Nat_divide in H; try lia.
+ move => /Nat2Z.divide. rewrite Nat2Z.inj_mul. move => /(prime_mult _ prime_2).
+ move => [H|H]; [left | right]; apply Z2Nat.divide in H; try lia.
- rewrite Nat2Z.id in H. assert (Z.to_nat 2 = 2) as Heq by lia. by rewrite Heq in H.
- rewrite Nat2Z.id in H. assert (Z.to_nat 2 = 2) as Heq by lia. by rewrite Heq in H.
Qed.
@@ -795,16 +831,16 @@ Lemma is_power_of_two_mult n1 n2:
Proof.
rewrite /is_power_of_two. split.
- move => [m Hm]. move: n1 n2 Hm. elim: m.
- + move => /= ?? /mult_is_one [->->]. split; by exists 0.
+ + move => /= ?? /Nat.eq_mul_1 [->->]. split; by exists 0.
+ move => n IH n1 n2 H. rewrite Nat.pow_succ_r' in H.
assert (divide 2 (n1 * n2)) as Hdiv. { exists (2 ^ n). lia. }
apply divide_mult_2 in Hdiv as [[k ->]|[k ->]].
* assert (k * n2 = 2 ^ n) as Hkn2 by lia.
apply IH in Hkn2 as [[m ->] Hn2]. split => //.
- exists (S m). by rewrite mult_comm -Nat.pow_succ_r'.
+ exists (S m). by rewrite Nat.mul_comm -Nat.pow_succ_r'.
* assert (n1 * k = 2 ^ n) as Hn1k by lia.
apply IH in Hn1k as [Hn1 [m ->]]. split => //.
- exists (S m). by rewrite mult_comm -Nat.pow_succ_r'.
+ exists (S m). by rewrite Nat.mul_comm -Nat.pow_succ_r'.
- move => [[m1 ->] [m2 ->]]. exists (m1 + m2). by rewrite Nat.pow_add_r.
Qed.
@@ -812,7 +848,7 @@ Lemma Z_distr_mul_sub_1 a b:
(a * b - b = (a - 1) * b)%Z.
Proof. nia. Qed.
-Lemma mult_le_compat_r_1 m p:
+Lemma mul_le_mono_r_1 m p:
(1 ≤ m)%nat → (p ≤ m * p)%nat.
Proof. nia. Qed.
@@ -900,7 +936,7 @@ Qed.
Lemma bitblast_lunot bits z n b:
Bitblast z n b →
Bitblast (Z_lunot bits z) n
-((bool_decide ((bits < 0 ≤ n)%Z) || (bool_decide ((0 ≤ bits)%Z) && bool_decide ((0 ≤ n < bits)%Z))) && negb b).
+ ((bool_decide ((bits < 0 ≤ n)%Z) || (bool_decide ((0 ≤ bits)%Z) && bool_decide ((0 ≤ n < bits)%Z))) && negb b).
Proof.
move => [<-]. constructor.
case_bool_decide.
@@ -950,3 +986,227 @@ Proof.
- move => Hb i ?. by bitblast Hb with i.
- move => Hf. bitblast. by apply Hf.
Qed.
+
+(** bitblast for pos *)
+Lemma bitblast_pos_xO p n b :
+ Bitblast (Z.pos p) (n - 1) b →
+ Bitblast (Z.pos p~0) n b.
+Proof.
+ move => [<-]. constructor.
+ destruct (decide (0 ≤ n)%Z). 2: { rewrite !Z.testbit_neg_r //; lia. }
+ destruct (decide (n = 0)%Z). { subst. done. }
+ destruct n; try lia.
+ rewrite !Z_testbit_pos_testbit /=; [|lia..].
+ f_equal. lia.
+Qed.
+(* lower priority than rule for constants *)
+Global Hint Resolve bitblast_pos_xO | 15 : bitblast.
+
+Lemma bitblast_pos_xI p n b :
+ Bitblast (Z.pos p) (n - 1) b →
+ Bitblast (Z.pos p~1) n (bool_decide (n = 0) || b).
+Proof.
+ move => [<-]. constructor.
+ destruct (decide (0 ≤ n)%Z).
+ 2: { rewrite bool_decide_false; [|lia]. rewrite !Z.testbit_neg_r //; lia. }
+ case_bool_decide. { subst. done. }
+ destruct n; try lia.
+ rewrite !Z_testbit_pos_testbit /=; [|lia..].
+ f_equal. lia.
+Qed.
+(* lower priority than rule for constants *)
+Global Hint Resolve bitblast_pos_xI | 15 : bitblast.
+
+(** rep
+
+ The [rep] tactic is an alternative to the [repeat] and [do] tactics
+ that supports left-biased depth-first branching with optional
+ backtracking on failure. *)
+Module Rep.
+ Import Ltac2.
+ Import Ltac2.Printf.
+
+ (* Exception to signal how many more steps should be backtracked*)
+ Ltac2 Type exn ::= [ RepBacktrack (int) ].
+
+ (* calls [tac] [n] times (n = None means infinite) on the first goal
+ under focus, stops on failure of [tac] and then backtracks [nback]
+ steps. *)
+ Ltac2 rec rep (n : int option) (nback : int) (tac : (unit -> unit)) : int :=
+ (* if there are no goals left, we are done *)
+ match Control.case (fun _ => Control.focus 1 1 (fun _ => ())) with
+ | Err _ => 0
+ | Val _ =>
+ (* check if we should do another repetition *)
+ let do_rep := match n with | None => true | Some n => Int.gt n 0 end in
+ match do_rep with
+ | false => 0
+ | true =>
+ (* backtracking point *)
+ let res := Control.case (fun _ =>
+ (* run tac on the first goal *)
+ let tac_res := Control.focus 1 1 (fun _ => Control.case tac) in
+ match tac_res with
+ | Err _ =>
+ (* if tac failed, either start the backtracking or return 0 *)
+ match Int.gt nback 0 with
+ | true => Control.zero (RepBacktrack nback)
+ | false => 0
+ end
+ | Val _ =>
+ (* compute new n and recurse *)
+ let new_n :=
+ match n with | None => None | Some n => Some (Int.sub n 1) end in
+ let n_steps := rep new_n nback tac in
+ Int.add n_steps 1
+ end) in
+ match res with
+ | Err e =>
+ match e with
+ | RepBacktrack n =>
+ (* if we catch a RepBacktrack, either rethrow it with
+ one less or return 0 *)
+ match Int.gt n 0 with
+ | true => Control.zero (RepBacktrack (Int.sub n 1))
+ | false => 0
+ end
+ | _ => Control.zero e
+ end
+ | Val (r, _) => r
+ end
+ end
+ end.
+
+ Ltac2 print_steps (n : int) :=
+ printf "Did %i steps." n.
+
+ Ltac2 rec pos_to_ltac2_int (n : constr) : int :=
+ lazy_match! n with
+ | xH => 1
+ | xO ?n => Int.mul (pos_to_ltac2_int n) 2
+ | xI ?n => Int.add (Int.mul (pos_to_ltac2_int n) 2) 1
+ end.
+
+ Ltac2 rec z_to_ltac2_int (n : constr) : int :=
+ lazy_match! n with
+ | Z0 => 0
+ | Z.pos ?n => pos_to_ltac2_int n
+ | Z.neg ?n => Int.neg (pos_to_ltac2_int n)
+ end.
+
+ (* TODO: use a mutable record field, see Janno's message *)
+
+ (* Calls tac on a new subgoal of type Z and converts the resulting Z
+ to an int. *)
+ Ltac2 int_from_z_subgoal (tac : unit -> unit) : int :=
+ let x := Control.focus 1 1 (fun _ =>
+ let x := open_constr:(_ : Z) in
+ match Constr.Unsafe.kind x with
+ | Constr.Unsafe.Cast x _ _ =>
+ match Constr.Unsafe.kind x with
+ | Constr.Unsafe.Evar e _ =>
+ Control.new_goal e;
+ x
+ | _ => Control.throw Assertion_failure
+ end
+ | _ => Control.throw Assertion_failure
+ end) in
+ (* new goal has index 2 because it was added after goal number 1 *)
+ Control.focus 2 2 (fun _ =>
+ tac ();
+ (* check that the goal is closed *)
+ Control.enter (fun _ => Control.throw Assertion_failure));
+ Control.focus 1 1 (fun _ =>
+ let x := Std.eval_vm None x in
+ z_to_ltac2_int x).
+
+ (* Necessary because Some and None cannot be used in ltac2: quotations. *)
+ Ltac2 some (n : int) : int option := Some n.
+ Ltac2 none : int option := None.
+End Rep.
+
+(** rep repeatedly applies tac to the goal in a depth-first manner. In
+particular, if tac generates multiple subgoals, the process continues
+with the first subgoal and only looks at the second subgoal if the
+first subgoal (and all goals spawed from it) are solved. If [tac]
+fails, the complete process stops (unlike [repeat] which continues
+with other subgoals).
+
+[rep n tac] iterates this process at most n times.
+[rep <- n tac] backtracks n steps on failure. *)
+Tactic Notation "rep" tactic3(tac) :=
+ let r := ltac2:(tac |-
+ Rep.print_steps (Rep.rep Rep.none 0 (fun _ => Ltac1.run tac))) in
+ r tac.
+
+(* rep is carefully written such that all goals are passed to Ltac2
+and rep can apply tac in a depth-first manner to only the first goal.
+In particular, the behavior of [all: rep 10 tac.] is equivalent to
+[all: rep 5 tac. all: rep 5 tac.], even if the first call spawns new
+subgoals. (See also the tests.) *)
+Tactic Notation "rep" int(n) tactic3(tac) :=
+ let ntac := do n (refine (1 + _)%Z); refine 0%Z in
+ let r := ltac2:(ntac tac |-
+ let n := Rep.int_from_z_subgoal (fun _ => Ltac1.run ntac) in
+ Rep.print_steps (Rep.rep (Rep.some n) 0 (fun _ => Ltac1.run tac))) in
+ r ntac tac.
+
+Tactic Notation "rep" "<-" int(n) tactic3(tac) :=
+ let ntac := do n (refine (1 + _)%Z); refine 0%Z in
+ let r := ltac2:(ntac tac |-
+ let n := Rep.int_from_z_subgoal (fun _ => Ltac1.run ntac) in
+ Rep.print_steps (Rep.rep (Rep.none) n (fun _ => Ltac1.run tac))) in
+ r ntac tac.
+
+Module RepTest.
+ Definition DELAY (P : Prop) : Prop := P.
+
+ Ltac DELAY_test_tac :=
+ first [
+ lazymatch goal with | |- DELAY ?P => change P end |
+ exact eq_refl |
+ split
+ ].
+
+ Goal ∃ x, Nat.iter 10 DELAY (x = 1) ∧ Nat.iter 6 DELAY (x = 2). simpl. eexists.
+ all: rep DELAY_test_tac.
+ 1: lazymatch goal with | |- 1 = 2 => idtac | |- _ => fail "unexpected goal" end.
+ Abort.
+
+ Goal ∃ x, Nat.iter 10 DELAY (x = 1) ∧ Nat.iter 6 DELAY (x = 2). simpl. eexists.
+ all: rep 5 DELAY_test_tac.
+ 1: lazymatch goal with | |- DELAY (DELAY (DELAY (DELAY (DELAY (DELAY (_ = 1)))))) => idtac | |- _ => fail "unexpected goal" end.
+ 2: lazymatch goal with | |- DELAY (DELAY (DELAY (DELAY (DELAY (DELAY (_ = 2)))))) => idtac | |- _ => fail "unexpected goal" end.
+ (* This should only apply tac to the first subgoal. *)
+ all: rep 5 DELAY_test_tac.
+ 1: lazymatch goal with | |- DELAY (_ = 1) => idtac | |- _ => fail "unexpected goal" end.
+ 2: lazymatch goal with | |- DELAY (DELAY (DELAY (DELAY (DELAY (DELAY (_ = 2)))))) => idtac | |- _ => fail "unexpected goal" end.
+ (* This finishes the first subgoal and use the remaining steps on
+ the second subgoal. *)
+ all: rep 5 DELAY_test_tac.
+ 1: lazymatch goal with | |- DELAY (DELAY (DELAY (1 = 2))) => idtac | |- _ => fail "unexpected goal" end.
+ Abort.
+
+ Goal ∃ x, Nat.iter 10 DELAY (x = 1) ∧ Nat.iter 6 DELAY (x = 2). simpl. eexists.
+ repeat DELAY_test_tac.
+ (* Same as rep above. *)
+ Abort.
+
+ Goal ∃ x, Nat.iter 10 DELAY (x = 1) ∧ Nat.iter 6 DELAY (x = 2). simpl. eexists.
+ do 5? (DELAY_test_tac).
+ (* Notice the difference to [rep] above: [do] also applies the
+ steps to the second subgoal. *)
+ Abort.
+
+ Goal ∃ x, Nat.iter 10 DELAY (x ≤ 1) ∧ Nat.iter 6 DELAY (x = 2). simpl. eexists.
+ rep <-3 DELAY_test_tac.
+ 1: lazymatch goal with | |- DELAY (DELAY (DELAY (_ ≤ 1))) => idtac | |- _ => fail "unexpected goal" end.
+ 2: lazymatch goal with | |- DELAY (DELAY (DELAY (DELAY (DELAY (DELAY (_ = 2)))))) => idtac | |- _ => fail "unexpected goal" end.
+ Abort.
+
+ Goal ∃ x, Nat.iter 10 DELAY (x ≤ 1) ∧ Nat.iter 6 DELAY (x = 2). simpl. eexists.
+ repeat DELAY_test_tac.
+ (* Notice the difference to [rep] above: [repeat] continues with
+ the second subgoal on failure. *)
+ Abort.
+End RepTest.
diff --git a/theories/lithium/benchmarks/liWand.v b/theories/lithium/benchmarks/liWand.v
index ba329b99a20399fe1f0640879d7c691a49931949..ba95b6b6cf519539a006618570370b23f428a7cc 100644
--- a/theories/lithium/benchmarks/liWand.v
+++ b/theories/lithium/benchmarks/liWand.v
@@ -1,7 +1,7 @@
Require Import iris.base_logic.lib.iprop.
Require Import iris.proofmode.proofmode.
Require Import lithium.base.
-Require Import lithium.tactics.
+Require Import lithium.all.
Axiom falso : False.
Goal ∀ Σ (P : nat → iProp Σ),
@@ -10,7 +10,7 @@ Goal ∀ Σ (P : nat → iProp Σ),
intros Σ P. iStartProof.
(* Set Ltac Profiling. *)
(* Reset Ltac Profile. *)
- time "liWand" repeat (liEnforceInvariant; liWand).
+ time "liWand" repeat (liEnsureInvariant; liWand).
(* Show Ltac Profile. *)
destruct falso.
Time Qed.
diff --git a/theories/lithium/classes.v b/theories/lithium/classes.v
deleted file mode 100644
index 38c571cba4265b6b6ef4f256a5e2eae1a8aef96b..0000000000000000000000000000000000000000
--- a/theories/lithium/classes.v
+++ /dev/null
@@ -1,309 +0,0 @@
-(** Main typeclasses of Lithium *)
-From iris.base_logic.lib Require Export iprop.
-From iris.proofmode Require Export tactics.
-From lithium Require Export base infrastructure.
-
-(** * [iProp_to_Prop] *)
-Record iProp_to_Prop {Σ} (P : iProp Σ) : Type := i2p {
- i2p_P :> iProp Σ;
- i2p_proof : i2p_P -∗ P;
-}.
-Arguments i2p {_ _ _} _.
-Arguments i2p_P {_ _} _.
-Arguments i2p_proof {_ _} _.
-
-(** * [find_in_context] *)
-(** ** Definition *)
-Record find_in_context_info {Σ} : Type := {
- fic_A : Type;
- fic_Prop : fic_A → iProp Σ;
-}.
-(* The nat n is necessary to allow different options. *)
-Definition find_in_context {Σ} (fic : find_in_context_info) (T : fic.(fic_A) → iProp Σ) : iProp Σ :=
- (∃ b, fic.(fic_Prop) b ∗ T b).
-Class FindInContext {Σ} (fic : find_in_context_info) (key : Set) : Type :=
- find_in_context_proof T: iProp_to_Prop (Σ:=Σ) (find_in_context fic T)
-.
-Global Hint Mode FindInContext + + - : typeclass_instances.
-Inductive FICSyntactic : Set :=.
-
-(** ** Instances *)
-Definition FindDirect {Σ A} (P : A → iProp Σ) := {| fic_A := A; fic_Prop := P; |}.
-Global Typeclasses Opaque FindDirect.
-
-Lemma find_in_context_direct {Σ B} P (T : B → iProp Σ):
- (∃ x : B, P x ∗ T x) -∗
- find_in_context (FindDirect P) T.
-Proof. done. Qed.
-Global Instance find_in_context_direct_inst {Σ B} (P : _ → iProp Σ) :
- FindInContext (FindDirect P) FICSyntactic | 1 :=
- λ T : B → _, i2p (find_in_context_direct P T).
-
-(** ** [FindHypEqual] *)
-Class FindHypEqual {Σ} (key : Type) (Q P P' : iProp Σ) := find_hyp_equal_equal: P = P'.
-Global Hint Mode FindHypEqual + + + ! - : typeclass_instances.
-
-(** * [find_related_in_context] *)
-(** ** Definition *)
-Record find_related_in_context_info {Σ} : Type := {
- fric_A : Type;
- fric_Prop : fric_A → iProp Σ;
- fric_Cert : fric_A → Prop;
-}.
-Definition find_related_in_context {Σ} (fric : find_related_in_context_info) (T : fric.(fric_A) → iProp Σ) : iProp Σ :=
- (∃ b, fric.(fric_Prop) b ∗ ⌜fric.(fric_Cert) b⌠∗ T b).
-Class FindRelatedInContext {Σ} (fric : find_related_in_context_info) (key : Set) : Type :=
- find_related_in_context_proof T: iProp_to_Prop (Σ:=Σ) (find_related_in_context fric T)
-.
-Global Hint Mode FindRelatedInContext + + - : typeclass_instances.
-
-(** * [destruct_hint] *)
-Inductive destruct_hint_info :=
-| DHintInfo
-| DHintDestruct (A : Type) (x : A)
-| DHintDecide (P : Prop) `{!Decision P}.
-Definition destruct_hint {Σ B} (hint : destruct_hint_info) (info : B) (T : iProp Σ) : iProp Σ := T.
-Global Typeclasses Opaque destruct_hint.
-Arguments destruct_hint : simpl never.
-
-(** * [tactic_hint] *)
-Class TacticHint {Σ A} (t : (A → iProp Σ) → iProp Σ) := {
- tactic_hint_P : (A → iProp Σ) → iProp Σ;
- tactic_hint_proof T : tactic_hint_P T -∗ t T;
-}.
-Arguments tactic_hint_proof {_ _ _} _ _.
-Arguments tactic_hint_P {_ _ _} _ _.
-
-Definition tactic_hint {Σ A} (t : (A → iProp Σ) → iProp Σ) (T : A → iProp Σ) : iProp Σ :=
- t T.
-Arguments tactic_hint : simpl never.
-
-(** ** [vm_compute_hint] *)
-Definition vm_compute_hint {Σ A B} (f : A → option B) (x : A) (T : B → iProp Σ) : iProp Σ :=
- ∃ y, ⌜f x = Some y⌠∗ T y.
-Arguments vm_compute_hint : simpl never.
-Global Typeclasses Opaque vm_compute_hint.
-
-Program Definition vm_compute_hint_hint {Σ A B} (f : A → option B) x a :
- f a = Some x →
- TacticHint (vm_compute_hint (Σ:=Σ) f a) := λ H, {|
- tactic_hint_P T := T x;
-|}.
-Next Obligation. move => ????????. iIntros "HT". iExists _. iFrame. iPureIntro. naive_solver. Qed.
-
-Global Hint Extern 10 (TacticHint (vm_compute_hint _ _)) =>
- eapply vm_compute_hint_hint; evar_safe_vm_compute : typeclass_instances.
-
-(** * [RelatedTo] *)
-Class RelatedTo {Σ} (pat : iProp Σ) : Type := {
- rt_fic : find_in_context_info (Σ:=Σ);
-}.
-Global Hint Mode RelatedTo + + : typeclass_instances.
-Arguments rt_fic {_ _} _.
-
-(** * [IntroPersistent] *)
-(** ** Definition *)
-Class IntroPersistent {Σ} (P P' : iProp Σ) := {
- ip_persistent : P -∗ □ P'
-}.
-Global Hint Mode IntroPersistent + + - : typeclass_instances.
-(** ** Instances *)
-Global Instance intro_persistent_intuit Σ (P : iProp Σ) : IntroPersistent (□ P) P.
-Proof. constructor. iIntros "$". Qed.
-
-(** * [accu] *)
-Definition accu {Σ} (f : iProp Σ → iProp Σ) : iProp Σ :=
- ∃ P, P ∗ □ f P.
-Arguments accu : simpl never.
-Global Typeclasses Opaque accu.
-
-
-(** * Simplification *)
-(** ** Definition *)
-(* n:
- None: no simplification
- Some 0: simplification which is always safe
- Some n: lower n: should be done before higher n (when compared with simplifyGoal) *)
-Definition simplify_hyp {Σ} (P : iProp Σ) (T : iProp Σ) : iProp Σ :=
- P -∗ T.
-Class SimplifyHyp {Σ} (P : iProp Σ) (n : option N) : Type :=
- simplify_hyp_proof T : iProp_to_Prop (simplify_hyp P T).
-
-Definition simplify_goal {Σ} (P : iProp Σ) (T : iProp Σ → iProp Σ) : iProp Σ :=
- (∃ P2, (P2 -∗ P) ∗ T P2).
-Class SimplifyGoal {Σ} (P : iProp Σ) (n : option N) : Type :=
- simplify_goal_proof T : iProp_to_Prop (simplify_goal P T).
-
-Global Hint Mode SimplifyHyp + + - : typeclass_instances.
-Global Hint Mode SimplifyGoal + ! - : typeclass_instances.
-
-(** ** Instances *)
-Lemma simplify_hyp_id {Σ} (P : iProp Σ) T:
- T -∗ simplify_hyp P T.
-Proof. iIntros "HT Hl". iFrame. Qed.
-Global Instance simplify_hyp_id_inst {Σ} (P : iProp Σ):
- SimplifyHyp P None | 100 :=
- λ T, i2p (simplify_hyp_id P T).
-
-Lemma simplify_goal_id {Σ} (P : iProp Σ) T:
- T P -∗ simplify_goal P T.
-Proof. iIntros "HT". iExists _. iFrame. by iIntros "?". Qed.
-Global Instance simplify_goal_id_inst {Σ} (P : iProp Σ):
- SimplifyGoal P None | 100 :=
- λ T, i2p (simplify_goal_id P T).
-
-(* TODO: Is the following useful? *)
-(* Lemma simplify_persistent_pure_goal {Σ} (Φ : Prop) T: *)
-(* T ⌜Φ⌠-∗ simplify_goal (Σ := Σ) (â–¡ ⌜ΦâŒ) T. *)
-(* Proof. iIntros "HT". iExists _. iFrame. by iIntros (?). Qed. *)
-(* Global Instance simplify_persistent_pure_goal_id {Σ} (Φ : Prop): *)
-(* SimplifyGoal (Σ:=Σ) (â–¡ ⌜ΦâŒ) (Some 0%N) := *)
-(* λ T, i2p (simplify_persistent_pure_goal Φ T). *)
-
-(* Lemma simplify_persistent_pure_hyp {Σ} (Φ : Prop) T: *)
-(* (⌜Φ⌠-∗ T) -∗ simplify_hyp (Σ := Σ) (â–¡ ⌜ΦâŒ) T. *)
-(* Proof. iIntros "HT" (?). by iApply "HT". Qed. *)
-(* Global Instance simplify_persistent_pure_hyp_inst {Σ} (Φ : Prop): *)
-(* SimplifyHyp (Σ:=Σ) (â–¡ ⌜ΦâŒ) (Some 0%N) := *)
-(* λ T, i2p (simplify_persistent_pure_hyp Φ T). *)
-
-(* Lemma simplify_persistent_sep_hyp {Σ} (P Q : iProp Σ) T: *)
-(* (□ P -∗ □ Q -∗ T) -∗ simplify_hyp (Σ := Σ) (□ (P ∗ Q)) T. *)
-(* Proof. iIntros "HT [HP HQ]". iApply ("HT" with "HP HQ"). Qed. *)
-(* Global Instance simplify_persistent_sep_hyp_inst {Σ} (P Q : iProp Σ): *)
-(* SimplifyHyp (Σ:=Σ) (□ (P ∗ Q)) (Some 0%N) := *)
-(* λ T, i2p (simplify_persistent_sep_hyp P Q T). *)
-
-(** * Subsumption *)
-(** ** Definition *)
-Definition subsume {Σ} (P1 P2 T : iProp Σ) : iProp Σ :=
- P1 -∗ P2 ∗ T.
-Class Subsume {Σ} (P1 P2 : iProp Σ) : Type :=
- subsume_proof T : iProp_to_Prop (subsume P1 P2 T).
-Definition subsume_list {Σ} A (ig : list nat) (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) : iProp Σ :=
- ([∗ list] i↦x∈l1, if bool_decide (i ∈ ig) then True%I else f i x) -∗
- ⌜length l1 = length l2⌠∗ ([∗ list] i↦x∈l2, if bool_decide (i ∈ ig) then True%I else f i x) ∗ T.
-Class SubsumeList {Σ} A (ig : list nat) (l1 l2 : list A) (f : nat → A → iProp Σ) : Type :=
- subsume_list_proof T : iProp_to_Prop (subsume_list A ig l1 l2 f T).
-
-Global Hint Mode Subsume + + ! : typeclass_instances.
-Global Hint Mode SubsumeList + + + + + ! : typeclass_instances.
-
-(** ** Instances *)
-Lemma subsume_id {Σ} (P : iProp Σ) T:
- T -∗ subsume P P T.
-Proof. iIntros "$ $". Qed.
-Global Instance subsume_id_inst {Σ} (P : iProp Σ) : Subsume P P | 1 := λ T, i2p (subsume_id P T).
-
-Lemma subsume_simplify {Σ} (P1 P2 : iProp Σ) T o1 o2 {SH : SimplifyHyp P1 o1} {SG : SimplifyGoal P2 o2}:
- let GH := (SH (P2 ∗ T)%I).(i2p_P) in
- let GG := (SG (λ P, P1 -∗ P ∗ T)%I).(i2p_P) in
- let G :=
- match o1, o2 with
- | Some n1, Some n2 => if (n2 ?= n1)%N is Lt then GG else GH
- | Some n1, _ => GH
- | _, _ => GG
- end in
- G -∗ subsume P1 P2 T.
-Proof.
- iIntros "Hs Hl".
- destruct o1 as [n1|], o2 as [n2|] => //. case_match.
- 1,3,4: by iDestruct (i2p_proof with "Hs Hl") as "Hsub".
- all: iDestruct (i2p_proof with "Hs") as (P) "[HP HT]".
- all: iDestruct ("HT" with "Hl") as "[HP' $]".
- all: by iApply "HP".
-Qed.
-Global Instance subsume_simplify_inst {Σ} (P1 P2 : iProp Σ) o1 o2 `{!SimplifyHyp P1 o1} `{!SimplifyGoal P2 o2} `{!TCOneIsSome o1 o2} :
- Subsume P1 P2 | 1000 :=
- λ T, i2p (subsume_simplify P1 P2 T o1 o2).
-
-Lemma subsume_list_eq {Σ} A ig (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
- ⌜list_subequiv ig l1 l2⌠∗ T -∗ subsume_list A ig l1 l2 f T.
-Proof.
- iDestruct 1 as (Hequiv) "$". iIntros "Hl".
- have [Hlen _]:= Hequiv 0. iSplit; first done.
- iInduction l1 as [|x l1] "IH" forall (f ig l2 Hlen Hequiv); destruct l2 => //=.
- iDestruct "Hl" as "[Hx Hl]". move: Hlen => /= [?].
- iSplitL "Hx".
- - case_bool_decide as Hb => //. have [_ /= Heq]:= Hequiv 0. by move: (Heq Hb) => [->].
- - iDestruct ("IH" $! (f ∘ S) (pred <$> (filter (λ x, x ≠0%nat) ig)) l2 with "[//] [%] [Hl]") as "Hl". {
- move => i. split => // Hin. move: (Hequiv (S i)) => [_ /= {}Hequiv]. apply: Hequiv.
- contradict Hin. apply elem_of_list_fmap. eexists (S i). split => //.
- by apply elem_of_list_filter.
- }
- + iApply (big_sepL_impl with "Hl"). iIntros "!>" (k ??) "Hl".
- case_bool_decide as Hb1; case_bool_decide as Hb2 => //.
- contradict Hb2. apply elem_of_list_fmap. eexists (S k). split => //.
- by apply elem_of_list_filter.
- + iApply (big_sepL_impl with "Hl"). iIntros "!>" (k ??) "Hl".
- case_bool_decide as Hb1; case_bool_decide as Hb2 => //.
- contradict Hb2. move: Hb1 => /elem_of_list_fmap[[|?][? /elem_of_list_filter [??]]] //.
- by simplify_eq/=.
-Qed.
-Global Instance subsume_list_eq_inst {Σ} A ig l1 l2 f:
- SubsumeList A ig l1 l2 f | 1000 :=
- λ T : iProp Σ, i2p (subsume_list_eq A ig l1 l2 f T).
-
-Lemma subsume_list_insert_in_ig {Σ} A ig i x (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) `{!CanSolve (i ∈ ig)} :
- subsume_list A ig l1 l2 f T -∗
- subsume_list A ig (<[i := x]>l1) l2 f T.
-Proof.
- unfold CanSolve in *. iIntros "Hsub Hl".
- rewrite insert_length. iApply "Hsub".
- destruct (decide (i < length l1)%nat). 2: { by rewrite list_insert_ge; [|lia]. }
- iDestruct (big_sepL_insert_acc with "Hl") as "[_ Hl]". { by apply: list_lookup_insert. }
- have [//|y ?]:= lookup_lt_is_Some_2 l1 i.
- iDestruct ("Hl" $! y with "[]") as "Hl". { by case_decide. }
- by rewrite list_insert_insert list_insert_id.
-Qed.
-Global Instance subsume_list_insert_in_ig_inst {Σ} A ig i x (l1 l2 : list A) (f : nat → A → iProp Σ) `{!CanSolve (i ∈ ig)} :
- SubsumeList A ig (<[i := x]>l1) l2 f :=
- λ T, i2p (subsume_list_insert_in_ig A ig i x l1 l2 f T).
-
-Lemma subsume_list_insert_not_in_ig {Σ} A ig i x (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) `{!CanSolve (i ∉ ig)} :
- ⌜i < length l1âŒ%nat ∗ subsume_list A (i :: ig) l1 l2 f (∀ x2,
- ⌜l2 !! i = Some x2⌠-∗ subsume (f i x) (f i x2) T) -∗
- subsume_list A ig (<[i := x]>l1) l2 f T.
-Proof.
- unfold CanSolve in *. iIntros "[% Hsub] Hl". rewrite big_sepL_insert // insert_length.
- iDestruct "Hl" as "[Hx Hl]". case_bool_decide => //.
- iDestruct ("Hsub" with "[Hl]") as "[% [Hl HT]]". {
- iApply (big_sepL_impl with "Hl"). iIntros "!>" (???) "?".
- repeat case_decide => //; set_solver.
- }
- iSplit => //.
- have [//|y ?]:= lookup_lt_is_Some_2 l2 i. { lia. }
- iDestruct ("HT" with "[//] Hx") as "[Hf $]".
- rewrite -{2}(list_insert_id l2 i y) // big_sepL_insert; [|lia]. case_bool_decide => //. iFrame.
- iApply (big_sepL_impl with "Hl"). iIntros "!>" (???) "?".
- repeat case_decide => //; set_solver.
-Qed.
-Global Instance subsume_list_insert_not_in_ig_inst {Σ} A ig i x (l1 l2 : list A) (f : nat → A → iProp Σ) `{!CanSolve (i ∉ ig)} :
- SubsumeList A ig (<[i := x]>l1) l2 f :=
- λ T, i2p (subsume_list_insert_not_in_ig A ig i x l1 l2 f T).
-
-Lemma subsume_list_trivial_eq {Σ} A ig (l : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
- T -∗ subsume_list A ig l l f T.
-Proof. by iIntros "$ $". Qed.
-Global Instance subsume_list_trivial_eq_inst {Σ} A ig l f:
- SubsumeList A ig l l f | 5 :=
- λ T : iProp Σ, i2p (subsume_list_trivial_eq A ig l f T).
-
-Lemma subsume_list_cons_l {Σ} A ig (x1 : A) (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
- (⌜0 ∉ ig⌠∗ ∃ x2 l2', ⌜l2 = x2 :: l2'⌠∗
- subsume (f 0%nat x1) (f 0%nat x2) (subsume_list A (pred <$> ig) l1 l2' (λ i, f (S i)) T)) -∗
- subsume_list A ig (x1 :: l1) l2 f T.
-Proof.
- iIntros "[% Hs]". iDestruct "Hs" as (???) "Hs". subst.
- rewrite /subsume_list !big_sepL_cons /=.
- case_bool_decide => //. iIntros "[H0 H]".
- iDestruct ("Hs" with "H0") as "[$ Hs]".
- iDestruct ("Hs" with "[H]") as (->) "[H $]"; [|iSplit => //].
- all: iApply (big_sepL_impl with "H"); iIntros "!#" (???) "?".
- all: case_bool_decide as Hx1 => //; case_bool_decide as Hx2 => //; contradict Hx2.
- - set_unfold. eexists _. split; [|done]. done.
- - by move: Hx1 => /(elem_of_list_fmap_2 _ _ _)[[|?]//=[->?]].
-Qed.
-Global Instance subsume_list_cons_inst {Σ} A ig x1 l1 l2 f:
- SubsumeList A ig (x1 :: l1) l2 f | 40 :=
- λ T : iProp Σ, i2p (subsume_list_cons_l A ig x1 l1 l2 f T).
diff --git a/theories/lithium/definitions.v b/theories/lithium/definitions.v
new file mode 100644
index 0000000000000000000000000000000000000000..ce0084fcf0530fd7bfe58a21f4fc4cd4bf599747
--- /dev/null
+++ b/theories/lithium/definitions.v
@@ -0,0 +1,138 @@
+From iris.base_logic.lib Require Export iprop.
+From iris.proofmode Require Export tactics.
+From lithium Require Export base pure_definitions.
+
+(** Definitions that are used by the Lithium automation. *)
+
+(** * [iProp_to_Prop] *)
+#[projections(primitive)]
+Record iProp_to_Prop {Σ} (P : iProp Σ) : Type := i2p {
+ i2p_P :> iProp Σ;
+ i2p_proof : i2p_P ⊢ P;
+}.
+Arguments i2p {_ _ _} _.
+Arguments i2p_P {_ _} _.
+Arguments i2p_proof {_ _} _.
+
+(** * Checking if a hyp in the context
+ The implementation can be found in interpreter.v *)
+Class CheckOwnInContext {Σ} (P : iProp Σ) : Prop := { check_own_in_context : True }.
+
+(** * [find_in_context] *)
+Record find_in_context_info {Σ} : Type := {
+ fic_A : Type;
+ fic_Prop : fic_A → iProp Σ;
+}.
+(* The nat n is necessary to allow different options, they are tried starting from 0. *)
+Definition find_in_context {Σ} (fic : find_in_context_info) (T : fic.(fic_A) → iProp Σ) : iProp Σ :=
+ (∃ b, fic.(fic_Prop) b ∗ T b).
+Class FindInContext {Σ} (fic : find_in_context_info) (key : Set) : Type :=
+ find_in_context_proof T: iProp_to_Prop (Σ:=Σ) (find_in_context fic T)
+.
+Global Hint Mode FindInContext + + - : typeclass_instances.
+Inductive FICSyntactic : Set :=.
+
+(** The instance for searching with [FindDirect] is in [instances.v]. *)
+Definition FindDirect {Σ A} (P : A → iProp Σ) := {| fic_A := A; fic_Prop := P; |}.
+Global Typeclasses Opaque FindDirect.
+
+(** ** [FindHypEqual] *)
+(** [FindHypEqual] is called with find_in_context key [key], an
+hypothesis [Q] and a desired pattern [P], and then the instance
+(usually a tactic) should try to generate a new pattern [P'] equal to
+[P] that can be later unified with [Q]. *)
+Class FindHypEqual {Σ} (key : Type) (Q P P' : iProp Σ) := find_hyp_equal_equal: P = P'.
+Global Hint Mode FindHypEqual + + + ! - : typeclass_instances.
+
+(** * [RelatedTo] *)
+Class RelatedTo {Σ} (pat : iProp Σ) : Type := {
+ rt_fic : find_in_context_info (Σ:=Σ);
+}.
+Global Hint Mode RelatedTo + + : typeclass_instances.
+Arguments rt_fic {_ _} _.
+
+(** * [IntroPersistent] *)
+(** ** Definition *)
+Class IntroPersistent {Σ} (P P' : iProp Σ) := {
+ ip_persistent : P ⊢ □ P'
+}.
+Global Hint Mode IntroPersistent + + - : typeclass_instances.
+(** ** Instances *)
+Global Instance intro_persistent_intuit Σ (P : iProp Σ) : IntroPersistent (□ P) P.
+Proof. constructor. iIntros "$". Qed.
+
+(** * Simplification *)
+(* n:
+ None: no simplification
+ Some 0: simplification which is always safe
+ Some n: lower n: should be done before higher n (when compared with simplifyGoal) *)
+Definition simplify_hyp {Σ} (P : iProp Σ) (T : iProp Σ) : iProp Σ :=
+ P -∗ T.
+Class SimplifyHyp {Σ} (P : iProp Σ) (n : option N) : Type :=
+ simplify_hyp_proof T : iProp_to_Prop (simplify_hyp P T).
+
+Definition simplify_goal {Σ} (P : iProp Σ) (T : iProp Σ) : iProp Σ :=
+ (P ∗ T).
+Class SimplifyGoal {Σ} (P : iProp Σ) (n : option N) : Type :=
+ simplify_goal_proof T : iProp_to_Prop (simplify_goal P T).
+
+Global Hint Mode SimplifyHyp + + - : typeclass_instances.
+Global Hint Mode SimplifyGoal + ! - : typeclass_instances.
+
+(** * Subsumption *)
+Definition subsume {Σ} (P1 P2 T : iProp Σ) : iProp Σ :=
+ P1 -∗ P2 ∗ T.
+Class Subsume {Σ} (P1 P2 : iProp Σ) : Type :=
+ subsume_proof T : iProp_to_Prop (subsume P1 P2 T).
+Definition subsume_list {Σ} A (ig : list nat) (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) : iProp Σ :=
+ ([∗ list] i↦x∈l1, if bool_decide (i ∈ ig) then True%I else f i x) -∗
+ ⌜length l1 = length l2⌠∗ ([∗ list] i↦x∈l2, if bool_decide (i ∈ ig) then True%I else f i x) ∗ T.
+Class SubsumeList {Σ} A (ig : list nat) (l1 l2 : list A) (f : nat → A → iProp Σ) : Type :=
+ subsume_list_proof T : iProp_to_Prop (subsume_list A ig l1 l2 f T).
+
+Global Hint Mode Subsume + + ! : typeclass_instances.
+Global Hint Mode SubsumeList + + + + + ! : typeclass_instances.
+
+(** * case distinction *)
+Definition case_if {Σ} (P : Prop) (T1 T2 : iProp Σ) : iProp Σ :=
+ (⌜P⌠-∗ T1) ∧ (⌜¬ P⌠-∗ T2).
+
+Definition case_destruct {Σ} {A} (a : A) (T : A → bool → iProp Σ) : iProp Σ :=
+ ∃ b, T a b.
+
+(** * [li_tactic] *)
+Class LiTactic {Σ A} (t : (A → iProp Σ) → iProp Σ) := {
+ li_tactic_P : (A → iProp Σ) → iProp Σ;
+ li_tactic_proof T : li_tactic_P T ⊢ t T;
+}.
+Arguments li_tactic_proof {_ _ _} _ _.
+Arguments li_tactic_P {_ _ _} _ _.
+
+Definition li_tactic {Σ A} (t : (A → iProp Σ) → iProp Σ) (T : A → iProp Σ) : iProp Σ :=
+ t T.
+Arguments li_tactic : simpl never.
+
+(** ** [li_vm_compute] *)
+Definition li_vm_compute {Σ A B} (f : A → option B) (x : A) (T : B → iProp Σ) : iProp Σ :=
+ ∃ y, ⌜f x = Some y⌠∗ T y.
+Arguments li_vm_compute : simpl never.
+Global Typeclasses Opaque li_vm_compute.
+
+Program Definition li_vm_compute_hint {Σ A B} (f : A → option B) x a :
+ f a = Some x →
+ LiTactic (li_vm_compute (Σ:=Σ) f a) := λ H, {|
+ li_tactic_P T := T x;
+|}.
+Next Obligation. move => ????????. iIntros "HT". iExists _. iFrame. iPureIntro. naive_solver. Qed.
+
+Global Hint Extern 10 (LiTactic (li_vm_compute _ _)) =>
+ eapply li_vm_compute_hint; evar_safe_vm_compute : typeclass_instances.
+
+(** * [accu] *)
+Definition accu {Σ} (f : iProp Σ → iProp Σ) : iProp Σ :=
+ ∃ P, P ∗ □ f P.
+Arguments accu : simpl never.
+Global Typeclasses Opaque accu.
+
+(** * trace *)
+Definition li_trace {Σ A} (t : A) (T : iProp Σ) : iProp Σ := T.
diff --git a/theories/lithium/hooks.v b/theories/lithium/hooks.v
new file mode 100644
index 0000000000000000000000000000000000000000..60e14287175fc9796cdb66d7934d40a011294ae8
--- /dev/null
+++ b/theories/lithium/hooks.v
@@ -0,0 +1,78 @@
+From lithium Require Export base.
+
+(** This file collects all Ltac hooks that Lithium provides. *)
+
+(** [can_solve_hook] is expected to provide a general purpose solver
+for pure sideconditions. It should try hard to solve the goal. *)
+Ltac can_solve_hook := fail "No can_solve_hook provided!".
+
+(** [normalize_hook] is expected to provide a tactic that should be
+used for rewriting based normalization of goals. See also
+[normalize.v]. *)
+Ltac normalize_hook := fail "No normalize_hook provided!".
+
+(** There can be some goals where one should not call injection on an
+hypothesis that is introduced. The [check_injection_hook] hook is called
+before injection and allows the client to customize this. *)
+Ltac check_injection_hook := idtac.
+
+(** [enrich_context_hook] can be used to add additional facts to the
+context during [solve_goal]. *)
+Ltac enrich_context_hook := idtac.
+
+(** [solve_goal_prepare_hook] resp.
+[solve_goal_normalized_prepare_hook] are called by [solve_goal] before
+resp. after [normalize_and_simpl_goal]. *)
+Ltac solve_goal_prepare_hook := idtac.
+Ltac solve_goal_normalized_prepare_hook := idtac.
+(** [reduce_closed_Z_hook] is called by [solve_goal] to reduce
+constant expressions on [Z]. *)
+Ltac reduce_closed_Z_hook := idtac.
+(** [solve_goal_final_hook] is called by [solve_goal] to finally
+solve the goal. *)
+Ltac solve_goal_final_hook := idtac.
+
+(** [li_pm_reduce_hook] is an extension point for custom reduction for
+IPM terms. *)
+Ltac li_pm_reduce_hook H := H.
+
+(** [unfold_instantiated_evar_hook] is called when evar [H] was instantiated. *)
+Ltac unfold_instantiated_evar_hook H := idtac.
+
+(** [solve_protected_eq_hook] can be used to unfold definitions before
+solving equalities for instantiating evars. *)
+Ltac solve_protected_eq_hook := idtac.
+
+(** [after_intro_hook] is executed after introducing a pure Coq assumption. *)
+Ltac after_intro_hook := idtac.
+
+(** [generate_i2p_instance_to_tc_hook] is used to infer the
+typeclasses from the lemmas for the [instance] notation for declaring
+typeclass instances. *)
+Ltac generate_i2p_instance_to_tc_hook arg c :=
+ fail "No generate_i2p_instance_to_tc_hook provided.".
+
+(** [liUnfoldLetGoal_hook] allows unfolding custom definitions when
+unfolding let-bindings in the goal. *)
+Ltac liUnfoldLetGoal_hook H := idtac.
+
+(** [liExtensible_to_i2p_hook] can be used to add custom
+judgements to [liExtensible]. *)
+Ltac liExtensible_to_i2p_hook P bind cont :=
+ fail "No liExtensible_to_i2p_hook provided!".
+
+(** [liExtensible_hook] is called after each successful [liExtensible]. *)
+Ltac liExtensible_hook := idtac.
+
+(** [liExist_hook] can be used to override the behavior of [liExist]
+for specific types. *)
+Ltac liExist_hook A protect := fail "No liExist_hook provided!".
+
+(** [liTrace_hook] is called on each liTrace. *)
+Ltac liTrace_hook info := idtac.
+
+(** [liToSyntax_hook] is called by [liToSyntax] to (heurisitically)
+convert the goal to the Lithium syntax. If one overrides
+[liToSyntax_hook] with [fail], conversion to the syntax is disabled. *)
+Ltac liToSyntax_hook :=
+ idtac.
diff --git a/theories/lithium/instances.v b/theories/lithium/instances.v
new file mode 100644
index 0000000000000000000000000000000000000000..155213466821bb47ef7960c0f31eae404e64ab55
--- /dev/null
+++ b/theories/lithium/instances.v
@@ -0,0 +1,150 @@
+From lithium Require Export base.
+From lithium Require Import syntax definitions proof_state.
+
+(** This file collects the default instances for the definitions in
+[definitions.v]. Note that these instances must be in a separate file
+since the instances are defined using the notation from
+[proof_state.v]. *)
+
+(** * [find_in_context] *)
+Lemma find_in_context_direct {Σ B} P (T : B → iProp Σ):
+ find_in_context (FindDirect P) T :- pattern: x, P x; return T x.
+Proof. done. Qed.
+Definition find_in_context_direct_inst := [instance @find_in_context_direct with FICSyntactic].
+Global Existing Instance find_in_context_direct_inst | 1.
+
+(** * Simplification *)
+Lemma simplify_hyp_id {Σ} (P T : iProp Σ) :
+ simplify_hyp P T :- return T.
+Proof. iIntros "HT Hl". iFrame. Qed.
+Definition simplify_hyp_id_inst Σ (P : iProp Σ) :=
+ [instance simplify_hyp_id P as SimplifyHyp P None].
+Global Existing Instance simplify_hyp_id_inst | 100.
+
+Lemma simplify_goal_id {Σ} (P : iProp Σ) T :
+ simplify_goal P T :- exhale P; return T.
+Proof. iIntros "$". Qed.
+Definition simplify_goal_id_inst Σ (P : iProp Σ) :=
+ [instance simplify_goal_id P as SimplifyGoal P None].
+Global Existing Instance simplify_goal_id_inst | 100.
+
+(** * Subsumption *)
+(** ** [subsume] *)
+Lemma subsume_id {Σ} (P : iProp Σ) T:
+ subsume P P T :- return T.
+Proof. iIntros "$ $". Qed.
+Definition subsume_id_inst := [instance @subsume_id].
+Global Existing Instance subsume_id_inst | 1.
+
+Lemma subsume_simplify {Σ} (P1 P2 : iProp Σ) o1 o2 T :
+ ∀ {SH : SimplifyHyp P1 o1} {SG : SimplifyGoal P2 o2} `{!TCOneIsSome o1 o2},
+ let GH := (SH (P2 ∗ T)%I).(i2p_P) in
+ let GG := (P1 -∗ (SG T).(i2p_P))%I in
+ let G :=
+ match o1, o2 with
+ | Some n1, Some n2 => if (n2 ?= n1)%N is Lt then GG else GH
+ | Some n1, _ => GH
+ | _, _ => GG
+ end in
+ subsume P1 P2 T :- return G.
+Proof.
+ iIntros (???) "/= Hs Hl".
+ destruct o1 as [n1|], o2 as [n2|] => //. 1: case_match.
+ 1,3,4: by iDestruct (i2p_proof with "Hs Hl") as "Hsub".
+ all: iDestruct ("Hs" with "Hl") as "HSG".
+ all: iDestruct (i2p_proof with "HSG") as "$".
+Qed.
+Definition subsume_simplify_inst := [instance @subsume_simplify].
+Global Existing Instance subsume_simplify_inst | 1000.
+
+(** ** [subsume_list] *)
+Lemma subsume_list_eq {Σ} A ig (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
+ subsume_list A ig l1 l2 f T :- exhale ⌜list_subequiv ig l1 l2âŒ; return T.
+Proof.
+ iDestruct 1 as (Hequiv) "$". iIntros "Hl".
+ have [Hlen _]:= Hequiv 0. iSplit; first done.
+ iInduction l1 as [|x l1] "IH" forall (f ig l2 Hlen Hequiv); destruct l2 => //=.
+ iDestruct "Hl" as "[Hx Hl]". move: Hlen => /= [?].
+ iSplitL "Hx".
+ - case_bool_decide as Hb => //. have [_ /= Heq]:= Hequiv 0. by move: (Heq Hb) => [->].
+ - iDestruct ("IH" $! (f ∘ S) (pred <$> (filter (λ x, x ≠0%nat) ig)) l2 with "[//] [%] [Hl]") as "Hl". {
+ move => i. split => // Hin. move: (Hequiv (S i)) => [_ /= {}Hequiv]. apply: Hequiv.
+ contradict Hin. apply elem_of_list_fmap. eexists (S i). split => //.
+ by apply elem_of_list_filter.
+ }
+ + iApply (big_sepL_impl with "Hl"). iIntros "!>" (k ??) "Hl".
+ case_bool_decide as Hb1; case_bool_decide as Hb2 => //.
+ contradict Hb2. apply elem_of_list_fmap. eexists (S k). split => //.
+ by apply elem_of_list_filter.
+ + iApply (big_sepL_impl with "Hl"). iIntros "!>" (k ??) "Hl".
+ case_bool_decide as Hb1; case_bool_decide as Hb2 => //.
+ contradict Hb2. move: Hb1 => /elem_of_list_fmap[[|?][? /elem_of_list_filter [??]]] //.
+ by simplify_eq/=.
+Qed.
+Definition subsume_list_eq_inst := [instance @subsume_list_eq].
+Global Existing Instance subsume_list_eq_inst | 1000.
+
+Lemma subsume_list_insert_in_ig {Σ} A ig i x (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
+ subsume_list A ig (<[i := x]>l1) l2 f T where `{!CanSolve (i ∈ ig)} :-
+ return subsume_list A ig l1 l2 f T.
+Proof.
+ unfold CanSolve => ?. iIntros "Hsub Hl".
+ rewrite insert_length. iApply "Hsub".
+ destruct (decide (i < length l1)%nat). 2: { by rewrite list_insert_ge; [|lia]. }
+ iDestruct (big_sepL_insert_acc with "Hl") as "[_ Hl]". { by apply: list_lookup_insert. }
+ have [//|y ?]:= lookup_lt_is_Some_2 l1 i.
+ iDestruct ("Hl" $! y with "[]") as "Hl". { by case_decide. }
+ by rewrite list_insert_insert list_insert_id.
+Qed.
+Definition subsume_list_insert_in_ig_inst := [instance @subsume_list_insert_in_ig].
+Global Existing Instance subsume_list_insert_in_ig_inst.
+
+Lemma subsume_list_insert_not_in_ig {Σ} A ig i x (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
+ subsume_list A ig (<[i := x]>l1) l2 f T where `{!CanSolve (i ∉ ig)} :-
+ exhale ⌜i < length l1âŒ%nat;
+ {subsume_list A (i :: ig) l1 l2 f};
+ ∀ x2, inhale ⌜l2 !! i = Some x2âŒ;
+ (f i x) :> (f i x2);
+ return T.
+Proof.
+ unfold CanSolve. iIntros (?) "[% Hsub] Hl". rewrite big_sepL_insert // insert_length.
+ iDestruct "Hl" as "[Hx Hl]". case_bool_decide => //.
+ iDestruct ("Hsub" with "[Hl]") as "[% [Hl HT]]". {
+ iApply (big_sepL_impl with "Hl"). iIntros "!>" (???) "?".
+ repeat case_decide => //; set_solver.
+ }
+ iSplit => //.
+ have [//|y ?]:= lookup_lt_is_Some_2 l2 i. { lia. }
+ iDestruct ("HT" with "[//] Hx") as "[Hf $]".
+ rewrite -{2}(list_insert_id l2 i y) // big_sepL_insert; [|lia]. case_bool_decide => //. iFrame.
+ iApply (big_sepL_impl with "Hl"). iIntros "!>" (???) "?".
+ repeat case_decide => //; set_solver.
+Qed.
+Definition subsume_list_insert_not_in_ig_inst := [instance @subsume_list_insert_not_in_ig].
+Global Existing Instance subsume_list_insert_not_in_ig_inst.
+
+Lemma subsume_list_trivial_eq {Σ} A ig (l : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
+ subsume_list A ig l l f T :- return T.
+Proof. by iIntros "$ $". Qed.
+Definition subsume_list_trivial_eq_inst := [instance @subsume_list_trivial_eq].
+Global Existing Instance subsume_list_trivial_eq_inst | 5.
+
+Lemma subsume_list_cons_l {Σ} A ig (x1 : A) (l1 l2 : list A) (f : nat → A → iProp Σ) (T : iProp Σ) :
+ subsume_list A ig (x1 :: l1) l2 f T :-
+ exhale ⌜0 ∉ igâŒ;
+ ∃ x2 l2', exhale ⌜l2 = x2 :: l2'âŒ;
+ (f 0%nat x1) :> (f 0%nat x2);
+ {subsume_list A (pred <$> ig) l1 l2' (λ i, f (S i)) T}.
+Proof.
+ iIntros "[% Hs]". iDestruct "Hs" as (???) "Hs". subst.
+ rewrite /subsume_list !big_sepL_cons /=.
+ case_bool_decide => //. iIntros "[H0 H]".
+ iDestruct ("Hs" with "H0") as "[$ Hs]".
+ iDestruct ("Hs" with "[H]") as (->) "[H $]"; [|iSplit => //].
+ all: iApply (big_sepL_impl with "H"); iIntros "!#" (???) "?".
+ all: case_bool_decide as Hx1 => //; case_bool_decide as Hx2 => //; contradict Hx2.
+ - set_unfold. eexists _. split; [|done]. done.
+ - by move: Hx1 => /(elem_of_list_fmap_2 _ _ _)[[|?]//=[->?]].
+Qed.
+Definition subsume_list_cons_l_inst := [instance @subsume_list_cons_l].
+Global Existing Instance subsume_list_cons_l_inst | 40.
diff --git a/theories/lithium/interpreter.v b/theories/lithium/interpreter.v
index 69cea30bf338820e1c4f85ffa430c7fd95eec626..88d940b7a0942eaf47d98bbc2aa068b3acf26487 100644
--- a/theories/lithium/interpreter.v
+++ b/theories/lithium/interpreter.v
@@ -1,23 +1,69 @@
From iris.proofmode Require Import coq_tactics reduction.
-From lithium Require Import base infrastructure classes simpl_classes tactics_extend.
+From lithium Require Export base.
+From lithium Require Import hooks definitions simpl_classes normalize proof_state solvers syntax.
+Set Default Proof Using "Type".
-(** * Definitions of markers for controling the state *)
-Notation "'HIDDEN'" := (Envs _ _ _) (only printing).
+(** This file contains the main Lithium interpreter. *)
-Definition LET_ID {A} (x : A) : A := x.
-Arguments LET_ID : simpl never.
-Notation "'HIDDEN'" := (LET_ID _) (only printing).
-Strategy expand [LET_ID].
+(** * General proof state management tactics *)
+Tactic Notation "liInst" hyp(H) open_constr(c) :=
+ instantiate_protected H c.
-Definition EVAR_ID {A} (x : A) : A := x.
-Arguments EVAR_ID : simpl never.
-Strategy expand [EVAR_ID].
+Ltac liShow := li_unfold_lets_in_context; try liToSyntaxGoal.
-Definition SHELVED_SIDECOND (P : Prop) : Prop := P.
-Arguments SHELVED_SIDECOND : simpl never.
-Strategy expand [SHELVED_SIDECOND].
+Ltac liSimpl :=
+ (* simpl inserts a cast even if it does not do anything
+ (see https://coq.zulipchat.com/#narrow/stream/237656-Coq-devs.20.26.20plugin.20devs/topic/exact_no_check.2C.20repeated.20casts.20in.20proof.20terms/near/259371220 ) *)
+ try progress simpl.
+
+Ltac liUnfoldLetGoal :=
+ let do_unfold P :=
+ let H := get_head P in
+ is_var H;
+ unfold LET_ID in H;
+ liUnfoldLetGoal_hook H;
+ (* This unfold inserts a cast but that is not too bad for
+ performance since the goal is small at this point. *)
+ unfold H;
+ try clear H
+ in
+ lazymatch goal with
+ | |- envs_entails _ (?P ∗ _) => do_unfold P
+ | |- envs_entails _ ?P => do_unfold P
+ end.
+
+Ltac liUnfoldSyntax :=
+ lazymatch goal with
+ | |- envs_entails _ (li.all _) => liFromSyntax
+ | |- envs_entails _ (li.exist _) => liFromSyntax
+ | |- envs_entails _ (li.done) => liFromSyntax
+ | |- envs_entails _ (li.false) => liFromSyntax
+ | |- envs_entails _ (li.and _ _) => liFromSyntax
+ | |- envs_entails _ (li.and_map _ _) => liFromSyntax
+ | |- envs_entails _ (li.case_if _ _ _) => liFromSyntax
+ | |- envs_entails _ (li.ret) => liFromSyntax
+ | |- envs_entails _ (li.bind0 _ _) => liFromSyntax
+ | |- envs_entails _ (li.bind1 _ _) => liFromSyntax
+ | |- envs_entails _ (li.bind2 _ _) => liFromSyntax
+ | |- envs_entails _ (li.bind3 _ _) => liFromSyntax
+ | |- envs_entails _ (li.bind4 _ _) => liFromSyntax
+ | |- envs_entails _ (li.bind5 _ _) => liFromSyntax
+ end.
+
+Ltac liEnsureInvariant :=
+ unfold_instantiated_evars; try let_bind_envs; try liUnfoldSyntax.
-(** * Lemmas used by tactics *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_fast_apply {Δ} {P1 P2 : iProp Σ} :
+ (P1 ⊢ P2) → envs_entails Δ P1 → envs_entails Δ P2.
+ Proof. by rewrite envs_entails_unseal => -> HP. Qed.
+End coq_tactics.
+
+(** * Main lithium tactics *)
+
+(** ** [liExtensible] *)
Section coq_tactics.
Context {Σ : gFunctors}.
@@ -26,520 +72,138 @@ Section coq_tactics.
https://coq-speed.mpi-sws.org/d/1QE_dqjiz/coq-compare?orgId=1&var-project=refinedc&var-branch1=master&var-commit1=05a3e8862ae4ab0041af67d1c02c552f99c4f35c&var-config1=build-coq.8.14.0-timing&var-branch2=master&var-commit2=998704f2a571385c65edfdd36332f6c3d014ec59&var-config2=build-coq.8.14.0-timing&var-metric=instructions&var-group=().*
TODO: investigate this more
*)
- Lemma tac_fast_apply {Δ} {P1 P2 : iProp Σ} :
- (P1 -∗ P2) → envs_entails Δ P1 → envs_entails Δ P2.
- Proof. by rewrite envs_entails_unseal => -> HP. Qed.
-
- Lemma tac_fast_apply_below_sep {Δ} {P1 P2 T : iProp Σ} :
- (P1 -∗ P2) → envs_entails Δ (P1 ∗ T) → envs_entails Δ (P2 ∗ T).
- Proof. by rewrite envs_entails_unseal => -> HP. Qed.
-
Lemma tac_apply_i2p {Δ} {P : iProp Σ} (P' : iProp_to_Prop P) :
envs_entails Δ P'.(i2p_P) → envs_entails Δ P.
- Proof. rewrite envs_entails_unseal. etrans; [done|]. apply i2p_proof. Qed.
-
- Lemma tac_apply_i2p_below_sep {Δ} {P T : iProp Σ} (P' : iProp_to_Prop P) :
- envs_entails Δ (P'.(i2p_P) ∗ T) → envs_entails Δ (P ∗ T).
- Proof. rewrite envs_entails_unseal. etrans; [done|]. apply bi.sep_mono_l. apply i2p_proof. Qed.
-
- Lemma tac_protected_eq_app {A} (f : A → Prop) a :
- f a → f (protected a).
- Proof. by rewrite protected_eq. Qed.
-
- Lemma tac_protected_eq_app_rev {A} (f : A → Prop) a :
- f (protected a) → f a.
- Proof. by rewrite protected_eq. Qed.
-
- Lemma tac_tactic_hint {A} Δ t (th : TacticHint t) (Q : A → iProp Σ):
- envs_entails Δ (th.(tactic_hint_P) Q) →
- envs_entails Δ (tactic_hint t Q).
- Proof. rewrite envs_entails_unseal => ?. etrans; [done|]. apply tactic_hint_proof. Qed.
+ Proof. apply tac_fast_apply. apply i2p_proof. Qed.
+End coq_tactics.
- Lemma tac_exist_prod A B (P : _ → Prop):
- (∃ x1 x2, P (x1, x2)) → @ex (A * B) P.
- Proof. move => [?[??]]. eauto. Qed.
+Ltac liExtensible_to_i2p P bind cont :=
+ lazymatch P with
+ | subsume ?P1 ?P2 ?T =>
+ bind T ltac:(fun H => uconstr:(subsume P1 P2 H));
+ cont uconstr:(((_ : Subsume _ _) _))
+ | subsume_list ?A ?ig ?l1 ?l2 ?f ?T =>
+ bind T ltac:(fun H => uconstr:(subsume_list A ig l1 l2 f H));
+ cont uconstr:(((_ : SubsumeList _ _ _ _ _) _))
+ | _ => liExtensible_to_i2p_hook P bind cont
+ end.
+Ltac liExtensible :=
+ lazymatch goal with
+ | |- envs_entails ?Δ ?P =>
+ liExtensible_to_i2p P
+ ltac:(fun T tac => li_let_bind T (fun H => let X := tac H in constr:(envs_entails Δ X)))
+ ltac:(fun converted =>
+ simple notypeclasses refine (tac_apply_i2p converted _); [solve [refine _] |];
+ liExtensible_hook)
+ end.
- Lemma tac_exist_sigT A f (P : _ → Prop):
- (∃ (a : A) (x : f a), P (existT a x)) → @ex (sigT f) P.
- Proof. move => [?[??]]. eauto. Qed.
+(** ** [liTrue] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
- Lemma tac_find_in_context {Δ} {fic} {T : _ → iProp Σ} key (F : FindInContext fic key) :
- envs_entails Δ (F T).(i2p_P) → envs_entails Δ (find_in_context fic T).
- Proof. rewrite envs_entails_unseal. etrans; [done|]. apply i2p_proof. Qed.
+ Lemma tac_true Δ :
+ envs_entails Δ (True%I : iProp Σ).
+ Proof. rewrite envs_entails_unseal. by iIntros "_". Qed.
+End coq_tactics.
- Lemma tac_find_hyp_equal key (Q P P' R : iProp Σ) Δ `{!FindHypEqual key Q P P'}:
- envs_entails Δ (P' ∗ R) →
- envs_entails Δ (P ∗ R).
- Proof. by revert select (FindHypEqual _ _ _ _) => ->. Qed.
+Ltac liTrue :=
+ lazymatch goal with
+ | |- envs_entails _ True => notypeclasses refine (tac_true _)
+ end.
- Lemma tac_find_hyp Δ i p R (P : iProp Σ) :
- envs_lookup i Δ = Some (p, P) →
- envs_entails (envs_delete false i p Δ) R → envs_entails Δ (P ∗ R).
- Proof.
- rewrite envs_entails_unseal. intros ? HQ.
- rewrite (envs_lookup_sound' _ false) // bi.intuitionistically_if_elim.
- by apply bi.sep_mono_r.
- Qed.
+(** ** [liFalse] *)
+Ltac liFalse :=
+ lazymatch goal with
+ | |- envs_entails _ False => exfalso; shelve_sidecond
+ | |- False => shelve_sidecond
+ end.
- Lemma tac_do_exist A Δ (P : A → iProp Σ) :
- (∃ x, envs_entails Δ (P x)) → envs_entails Δ (∃ x : A, P x).
- Proof.
- rewrite envs_entails_unseal. intros [x HP]. by rewrite -(bi.exist_intro x).
- Qed.
+(** ** [liForall] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
Lemma tac_do_forall A Δ (P : A → iProp Σ) :
(∀ x, envs_entails Δ (P x)) → envs_entails Δ (∀ x : A, P x).
Proof.
rewrite envs_entails_unseal. intros HP. by apply bi.forall_intro.
Qed.
+
Lemma tac_do_exist_wand A Δ (P : A → iProp Σ) Q :
(∀ x, envs_entails Δ (P x -∗ Q)) → envs_entails Δ ((∃ x : A, P x) -∗ Q).
Proof.
rewrite envs_entails_unseal. iIntros (HP) "Henv". iDestruct 1 as (x) "HP".
by iApply (HP with "Henv HP").
Qed.
-
- Lemma tac_do_intro_pure Δ (P : Prop) (Q : iProp Σ) :
- (P → envs_entails Δ Q) → envs_entails Δ (⌜P⌠-∗ Q).
- Proof.
- rewrite envs_entails_unseal => HP. iIntros "HΔ %". by iApply HP.
- Qed.
-
- Lemma tac_do_intro_pure_and Δ (P : Prop) (Q : iProp Σ) :
- (P ∧ (envs_entails Δ Q)) → envs_entails Δ (⌜P⌠∗ Q).
- Proof.
- rewrite envs_entails_unseal => [[HP HΔ]].
- iIntros "HΔ". iSplit => //. by iApply HΔ.
- Qed.
-
- Lemma tac_do_intro_intuit_sep Δ (P Q : iProp Σ) :
- envs_entails (envs_clear_spatial Δ) (P ∗ True) → envs_entails Δ Q → envs_entails Δ (□ P ∗ Q).
- Proof.
- rewrite envs_entails_unseal => HP HQ. iIntros "Henv".
- iSplit.
- - iDestruct (envs_clear_spatial_sound with "Henv") as "[#Henv _]".
- iModIntro. iDestruct (HP with "Henv") as "[$ _]".
- - by iApply HQ.
- Qed.
-
- Lemma tac_do_simplify_hyp (P : iProp Σ) (SH: SimplifyHyp P (Some 0%N)) Δ T :
- envs_entails Δ (SH T).(i2p_P) →
- envs_entails Δ (P -∗ T).
- Proof.
- rewrite envs_entails_unseal => HP. iIntros "Henv Hl".
- iDestruct (HP with "Henv") as "HP".
- iDestruct (i2p_proof with "HP Hl") as "$".
- Qed.
-
- Lemma tac_do_intro i n' (P : iProp Σ) n Γs Γp T :
- env_lookup i Γs = None →
- env_lookup i Γp = None →
- envs_entails (Envs Γp (Esnoc Γs i P) n') T →
- envs_entails (Envs Γp Γs n) (P -∗ T).
- Proof.
- rewrite envs_entails_unseal => Hs Hp HP. iIntros "Henv Hl".
- rewrite (envs_app_sound (Envs Γp Γs n) (Envs Γp (Esnoc Γs i P) n) false (Esnoc Enil i P)) //; simplify_option_eq => //.
- iApply HP. iApply "Henv". iFrame.
- Qed.
-
- Lemma tac_do_intro_intuit i n' (P P' : iProp Σ) T n Γs Γp (Hpers : IntroPersistent P P') :
- env_lookup i Γs = None →
- env_lookup i Γp = None →
- envs_entails (Envs (Esnoc Γp i P') Γs n') T →
- envs_entails (Envs Γp Γs n) (P -∗ T).
- Proof.
- rewrite envs_entails_unseal => Hs Hp HP. iIntros "Henv HP".
- iDestruct (@ip_persistent _ _ _ Hpers with "HP") as "#HP'".
- rewrite (envs_app_sound (Envs Γp Γs n) (Envs (Esnoc Γp i P') Γs n) true (Esnoc Enil i P')) //; simplify_option_eq => //.
- iApply HP. iApply "Henv".
- iModIntro. by iSplit.
- Qed.
-
- Lemma tac_true Δ :
- envs_entails Δ (True%I : iProp Σ).
- Proof. rewrite envs_entails_unseal. by iIntros "_". Qed.
-
- Lemma tac_sep_true Δ (P : iProp Σ) :
- envs_entails Δ P → envs_entails Δ (True ∗ P).
- Proof. apply tac_fast_apply. by apply bi.True_sep_2. Qed.
-
- Lemma tac_sep_emp Δ (P : iProp Σ) :
- envs_entails Δ P → envs_entails Δ (emp ∗ P).
- Proof. apply tac_fast_apply. by apply bi.emp_sep_1. Qed.
-
- Lemma tac_wand_emp Δ (P : iProp Σ) :
- envs_entails Δ P → envs_entails Δ (emp -∗ P).
- Proof. apply tac_fast_apply. by iIntros "$". Qed.
-
- Lemma tac_sep_sep_assoc Δ (P Q R : iProp Σ) :
- envs_entails Δ (P ∗ Q ∗ R) → envs_entails Δ ((P ∗ Q) ∗ R).
- Proof. apply tac_fast_apply. iIntros "($&$&$)". Qed.
-
- Lemma tac_wand_sep_assoc Δ (P Q R : iProp Σ) :
- envs_entails Δ (P -∗ Q -∗ R) → envs_entails Δ ((P ∗ Q) -∗ R).
- Proof. by rewrite bi.wand_curry. Qed.
-
- Lemma tac_sep_exist_assoc {A} Δ (Φ : A → iProp Σ) (Q : iProp Σ):
- envs_entails Δ (∃ a : A, Φ a ∗ Q) → envs_entails Δ ((∃ a : A, Φ a) ∗ Q).
- Proof. by rewrite bi.sep_exist_r. Qed.
-
- Lemma tac_do_simplify_goal (n : N) (P : iProp Σ) T {SG : SimplifyGoal P (Some n)} :
- (SG (λ P, P ∗ T)%I).(i2p_P) -∗ P ∗ T.
- Proof. iIntros "HP". iDestruct (i2p_proof with "HP") as (?) "(H&?&$)". by iApply "H". Qed.
-
- Lemma tac_intro_subsume_related P T {Hrel : RelatedTo P}:
- find_in_context Hrel.(rt_fic) (λ x, subsume (Σ:=Σ) (Hrel.(rt_fic).(fic_Prop) x) P T) -∗ P ∗ T.
- Proof. iDestruct 1 as (x) "[HP HT]". by iApply "HT". Qed.
-
- Lemma tac_remove_inuit (P T : iProp Σ) `{!Persistent P} :
- P ∗ T -∗ □ P ∗ T.
- Proof. by iIntros "[#? $]". Qed.
-
- Lemma tac_do_accu Δ (f : iProp Σ → iProp Σ):
- envs_entails (envs_clear_spatial Δ) (f (env_to_prop (env_spatial Δ))) →
- envs_entails Δ (accu f).
- Proof.
- rewrite envs_entails_unseal => Henv. iIntros "Henv".
- iDestruct (envs_clear_spatial_sound with "Henv") as "[#Henv Hs]". iExists (env_to_prop (env_spatial Δ)).
- rewrite -env_to_prop_sound. iFrame. iModIntro. by iApply (Henv with "Henv").
- Qed.
-
- Lemma tac_do_split Δ (P1 P2 : iProp Σ):
- envs_entails Δ P1 → envs_entails Δ P2 →
- envs_entails Δ (P1 ∧ P2).
- Proof. rewrite envs_entails_unseal => HP1 HP2. by apply bi.and_intro. Qed.
-
- Lemma tac_split_big_sepM {K A} `{!EqDecision K} `{!Countable K} (m : gmap K A) i x Φ (P : iProp Σ):
- m !! i = None →
- (Φ i x -∗ ([∗ map] k ↦x∈m, Φ k x) -∗ P) -∗
- ([∗ map] k ↦x∈<[i := x]>m, Φ k x) -∗ P.
- Proof.
- move => Hin. rewrite big_sepM_insert //.
- iIntros "HP [? Hm]". by iApply ("HP" with "[$]").
- Qed.
-
- Lemma tac_big_andM_insert {A B} `{Countable A} (m : gmap A B) i n (Φ : _ → _→ iProp Σ) :
- ⌜m !! i = None⌠∗ (Φ i n ∧ [∧ map] k↦v∈m, Φ k v) -∗
- [∧ map] k↦v∈<[i:=n]>m, Φ k v.
- Proof. iIntros "[% HT]". by rewrite big_andM_insert. Qed.
-
- Lemma tac_big_andM_empty {A B} `{Countable A} (Φ : _ → _→ iProp Σ) :
- True -∗ [∧ map] k↦v∈(∅ : gmap A B), Φ k v.
- Proof. iIntros "_". by rewrite big_andM_empty. Qed.
-
End coq_tactics.
-(** * Optimization: Introduce let-bindings for environment *)
-(** Extension point for custom reduction *)
-Ltac li_pm_reduce_tac H := H.
-Ltac li_pm_reduce_val v :=
- let v := li_pm_reduce_tac v in
- let v := reduction.pm_eval v in v.
-Ltac li_pm_reduce :=
- match goal with
- | H := Envs _ _ _ |- ?u =>
- let u := eval cbv [H] in u in
- let u := li_pm_reduce_val u in
- change u
- | |- ?u =>
- let u := li_pm_reduce_val u in
- change u
- end.
-Ltac li_pm_reflexivity := li_pm_reduce; exact eq_refl.
-
-Local Tactic Notation "liChangeState" hyp(H) constr(Δ) :=
- match Δ with
- | @Envs ?PROP _ _ ?n =>
- let H' := fresh "IPM_JANNO" in
- pose (H' := Δ);
- clear H;
- rename H' into H
- end.
-
-Ltac liEnforceInvariant :=
- lazymatch goal with
- | |- @envs_entails ?PROP ?Δ ?P =>
- let with_H tac :=
- match goal with
- | [ H := Envs _ _ _ |- _] =>
- lazymatch Δ with H => tac H | _ => unify Δ (H); tac H end
- | [ H := Envs _ _ _ |- _] =>
- liChangeState H Δ; tac H
- | _ =>
- match Δ with
- | Envs _ _ ?c =>
- let H := fresh "IPM_JANNO" in
- pose (H := Δ);
- hnf in (value of H);
- tac H
- end
- end in
- with_H ltac:(fun H =>
- change_no_check (envs_entails H P)
- )
- end.
-
-(*
-Ltac liFresh :=
- lazymatch goal with
- | [ H := Envs _ _ ?n |- _ ] =>
- let do_incr :=
- lazymatch goal with
- | H := @Envs ?PROP ?p1 ?p2 ?c |- envs_entails ?H' ?Q =>
- match H' with | H =>
- let c' := eval vm_compute in (Pos.succ c) in
- let H2 := fresh "IPM_INTERNAL" in
- pose (H2 := @Envs PROP p1 p2 c');
- change_no_check (@envs_entails PROP H2 Q);
- clear H; rename H2 into H
- end
- end in
- constr:(IAnon n)
- end.
- *)
-
-Tactic Notation "li_let_bind" constr(T) tactic3(tac) :=
- try (assert_fails (is_var T);
- let H := fresh "GOAL" in
- pose H := (LET_ID T);
- let G := tac H in
- change_no_check G).
-
-(* unfold_let_goal_tac lets users unfold custom definitions. *)
-Ltac unfold_let_goal_tac H := idtac.
-Ltac liUnfoldLetGoal :=
- let do_unfold P :=
- let H := get_head P in
- is_var H;
- unfold LET_ID in H;
- unfold_let_goal_tac H;
- (* This unfold inserts a cast but that is not too bad for
- performance since the goal is small at this point. *)
- unfold H;
- try clear H
+Ltac liForall :=
+ (* n tells us how many quantifiers we should introduce with this name *)
+ let rec do_intro n name :=
+ lazymatch n with
+ | S ?n' =>
+ lazymatch goal with
+ (* relying on the fact that unification variables cannot contain
+ dependent variables to distinguish between dependent and non dependent forall *)
+ | |- ?P -> ?Q =>
+ lazymatch type of P with
+ | Prop => fail "implication, not forall"
+ | _ => (* just some unused variable, discard *) move => _
+ end
+ | |- forall _ : ?A, _ =>
+ (* When changing this, also change [prepare_initial_coq_context] in automation.v *)
+ lazymatch A with
+ | (prod _ _) => case; do_intro (S (S O)) name
+ | unit => case
+ | _ =>
+ first [
+ (* We match again since having e in the context when
+ calling fresh can mess up names. *)
+ lazymatch goal with
+ | |- forall e : ?A, @?P e =>
+ let sn := open_constr:(_ : nat) in
+ let p := constr:(_ : SimplForall A sn P _) in
+ refine (@simpl_forall_proof _ _ _ _ p _);
+ do_intro sn name
+ end
+ | let H := fresh name in intro H
+ ]
+ end
+ end;
+ do_intro n' name
+ | O => idtac
+ end
in
lazymatch goal with
- | |- envs_entails _ (?P ∗ _) => do_unfold P
- | |- envs_entails _ ?P => do_unfold P
- end.
-
-Ltac liUnfoldLetsContaining H :=
- repeat match goal with
- | Hx := context [ H ] |- _ =>
- unfold LET_ID in Hx;
- unfold Hx in *;
- clear Hx
- end.
-
-Ltac liUnfoldLetsInContext :=
- repeat match goal with
- | H := LET_ID _ |- _ => unfold LET_ID in H; unfold H; clear H
- | H := Envs _ _ _ |- _ => unfold H; clear H
- end.
-
-(** * Management of evars *)
-Ltac liUnfoldAllEvars :=
- repeat rewrite protected_eq;
- repeat match goal with
- | He := EVAR_ID _ |- _ => unfold He, EVAR_ID; clear He
- end.
-
-Ltac create_protected_evar A :=
- (* necessary, otherwise pattern might not find all occurences later, see also instantiate protected *)
- let A := eval cbn in A in
- let Hevar := fresh "Hevar" in
- (* see https://stackoverflow.com/a/46178884*)
- let c :=
- match goal with
- | _ =>
- let x := fresh "x" in
- unshelve evar (x : A); [ liUnfoldLetsInContext; liUnfoldAllEvars; shelve |];
- pose (Hevar := EVAR_ID x : A); unfold x in Hevar; clear x
- end in
- Hevar.
-
-Ltac unfold_instantiated_evar_hook H := idtac.
-
-Ltac unfold_instantiated_evar H :=
- liUnfoldLetsContaining H;
- unfold_instantiated_evar_hook H;
- revert H;
- repeat match goal with
- | |- let _ := EVAR_ID ?body in _ =>
- match goal with
- | He := EVAR_ID ?var |- _ => is_evar var;
- lazymatch body with
- | context [ var ] => pattern var;
- lazymatch goal with
- | |- ?G ?E =>
- change (G He);
- simple refine (tac_protected_eq_app_rev _ _ _);
- cbv beta
- end
- end
- end
- end;
- (* This is copied from the end of instantiate_protected *)
- let tmp := fresh "tmp" in
- intros tmp;
- pattern (protected tmp);
- simple refine (tac_protected_eq_app _ _ _);
- unfold tmp, EVAR_ID; clear tmp.
-
-(*
- H should be (protected Hevar) where Hevar is the letbinding of an evar
- tac_with should be something like
- ltac:(fun H => instantiate (1:= (protected (EVAR_ID _) + protected (EVAR_ID _))%nat) in (Value of H)
- it should use instantiate (1:= ...) in (Value of H) to instantiate the first evar in the supplied parameter which will be Hevar
- It can use _ to create new evars, but they should be surrounded by [protected (EVAR_ID _)] such that instantiate_protected can find them and create the right let bindings afterwards.
-*)
-Ltac instantiate_protected H' tac_with :=
- lazymatch H' with
- | protected ?H =>
- liUnfoldLetsContaining H;
- unfold EVAR_ID in H;
- (* we have to be vary careful how we instantiate the evar, as it
- may not rely on things introduced later (even let bindings),
- otherwise unification fails *)
- tac_with H;
- revert H;
- repeat lazymatch goal with
- | |- let _ := ?body in _ =>
- lazymatch body with
- | context [EVAR_ID ?x] =>
- let Hevar := fresh "Hevar" in
- set (Hevar := (EVAR_ID x));
- (* necessary, otherwise pattern might not find all occurences later, see also create_protected_evar *)
- cbn in (type of Hevar)
- end
- end;
- (* This is copied from the end of unfold_instantiated_evar *)
- let tmp := fresh "tmp" in
- intros tmp;
- pattern (protected tmp);
- simple refine (tac_protected_eq_app _ _ _);
- unfold tmp, EVAR_ID; clear tmp
- end.
-Tactic Notation "liInst" hyp(H) open_constr(c) :=
- instantiate_protected (protected H) ltac:(fun H => instantiate (1:=c) in (value of H)).
-
-Ltac unfold_instantiated_evars :=
- repeat match goal with
- | H := EVAR_ID ?x |- _ => assert_fails (is_evar x); unfold_instantiated_evar H
- end.
-
-Create HintDb solve_protected_eq_db discriminated.
-Global Hint Constants Opaque : solve_protected_eq_db.
-
-Ltac solve_protected_eq_unfold_tac := idtac.
-Ltac solve_protected_eq :=
- (* intros because it is less aggressive than move => * *)
- intros;
- solve_protected_eq_unfold_tac;
- liUnfoldLetsInContext;
- liUnfoldAllEvars;
- lazymatch goal with |- ?a = ?b => unify a b with solve_protected_eq_db end;
- exact: eq_refl.
-
-Ltac liEnforceInvariantAndUnfoldInstantiatedEvars :=
- unfold_instantiated_evars; try liEnforceInvariant.
-
-(** * Checking if the context contains ownership of a certain assertion
-
- Note that this implementation requires that liEnforceInvariant has been called
- previously when there was a envs_entails goal.
- *)
-Ltac liCheckOwnInContext P :=
- let rec go Hs :=
- lazymatch Hs with
- | Esnoc ?Hs2 ?id ?Q =>
- first [ unify Q P with typeclass_instances | go Hs2 ]
- end in
- match goal with
- | H := Envs ?Δi ?Δs _ |- _ =>
- first [ go Δs | go Δi ]
- end.
-Global Hint Extern 1 (CheckOwnInContext ?P) => (liCheckOwnInContext P; constructor; exact: I) : typeclass_instances.
-
-(** * Main lithium tactics *)
-Ltac convert_to_i2p_tac P bind cont := fail "No convert_to_i2p_tac provided!".
-Ltac convert_to_i2p P bind cont :=
- lazymatch P with
- | subsume ?P1 ?P2 ?T =>
- bind T ltac:(fun H => uconstr:(subsume P1 P2 H));
- cont uconstr:(((_ : Subsume _ _) _))
- | subsume_list ?A ?ig ?l1 ?l2 ?f ?T =>
- bind T ltac:(fun H => uconstr:(subsume_list A ig l1 l2 f H));
- cont uconstr:(((_ : SubsumeList _ _ _ _ _) _))
- | _ => convert_to_i2p_tac P bind cont
+ | |- envs_entails _ (bi_forall (λ name, _)) =>
+ notypeclasses refine (tac_do_forall _ _ _ _); do_intro (S O) name
+ | |- envs_entails _ (bi_wand (bi_exist (λ name, _)) _) =>
+ notypeclasses refine (tac_do_exist_wand _ _ _ _ _); do_intro (S O) name
+ | |- (∃ name, _) → _ =>
+ case; do_intro (S O) name
+ | |- forall name, _ =>
+ do_intro (S O) name
+ | _ => fail "liForall: unknown goal"
end.
-Ltac extensible_judgment_hook := idtac.
-Ltac pre_extensible_judgment_hook := idtac.
-Ltac liExtensibleJudgement :=
- lazymatch goal with
- | |- envs_entails ?Δ ?P =>
- (*pre_extensible_judgment_hook;*)
- (*convert_to_i2p P ltac:(fun converted =>*)
- convert_to_i2p P ltac:(fun T tac => li_let_bind T (fun H => let X := tac H in constr:(envs_entails Δ X)))
- ltac:(fun converted =>
- simple notypeclasses refine (tac_apply_i2p converted _); [solve [refine _] |]; extensible_judgment_hook
- )end.
-Ltac liSimpl :=
- (* simpl inserts a cast even if it does not do anything (see https://coq.zulipchat.com/#narrow/stream/237656-Coq-devs.20.26.20plugin.20devs/topic/exact_no_check.2C.20repeated.20casts.20in.20proof.20terms/near/259371220
- TODO: maybe the try progress can be removed after https://github.com/coq/coq/pull/15104 is merged? *)
- try progress simpl.
+(** ** [liExist] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
-Ltac liShow := liUnfoldLetsInContext.
+ Lemma tac_do_exist A Δ (P : A → iProp Σ) :
+ (∃ x, envs_entails Δ (P x)) → envs_entails Δ (∃ x : A, P x).
+ Proof.
+ rewrite envs_entails_unseal. intros [x HP]. by rewrite -(bi.exist_intro x).
+ Qed.
-Ltac liFindHyp key :=
- let rec go P Hs :=
- lazymatch Hs with
- | Esnoc ?Hs2 ?id ?Q =>
- first [
- lazymatch key with
- | FICSyntactic =>
- (* we first try to unify using the opaquenes hints of
- typeclass_instances. Directly doing exact: eq_refl
- sometimes takes 30 seconds to fail (e.g. when trying
- to unify GetMemberLoc for the same struct but with
- different names. ) TODO: investigate if constr_eq
- could help even more
- https://coq.inria.fr/distrib/current/refman/proof-engine/tactics.html#coq:tacn.constr-eq*)
- unify Q P with typeclass_instances
- | _ =>
- notypeclasses refine (tac_find_hyp_equal key Q _ _ _ _ _); [solve [refine _] | ];
- lazymatch goal with
- | |- envs_entails _ (?P' ∗ _) =>
- unify Q P' with typeclass_instances
- end
- end;
- notypeclasses refine (tac_find_hyp _ id _ _ _ _ _); [li_pm_reflexivity | li_pm_reduce]
- | go P Hs2 ]
- end in
- lazymatch goal with
- | |- envs_entails _ (?P ∗ _) =>
- (* we don't want to try to unify if the goal contains protected
- evars as this can take very long to fail *)
- lazymatch P with
- | context [protected _] => fail "cannot find hyp if it contains protected"
- | _ => idtac
- end;
- let P := li_pm_reduce_val P in
- let run_go P Hs Hi := first [ go P Hs | go P Hi] in
- lazymatch goal with
- | |- envs_entails (Envs ?Hi ?Hs _) _ => run_go P Hs Hi
- | H := (Envs ?Hi ?Hs _) |- _ => run_go P Hs Hi
- end
- end.
+ Lemma tac_exist_prod A B (P : _ → Prop):
+ (∃ x1 x2, P (x1, x2)) → @ex (A * B) P.
+ Proof. move => [?[??]]. eauto. Qed.
-Ltac liFindHypOrTrue key :=
- first [
- notypeclasses refine (tac_sep_true _ _ _)
- | progress liFindHyp key
- ].
+ Lemma tac_exist_sigT A f (P : _ → Prop):
+ (∃ (a : A) (x : f a), P (existT a x)) → @ex (sigT f) P.
+ Proof. move => [?[??]]. eauto. Qed.
+End coq_tactics.
-Ltac custom_exist_tac A protect := fail "No custom_exist_tac provided.".
Ltac liExist protect :=
lazymatch goal with
| |- envs_entails _ (bi_exist _) => notypeclasses refine (tac_do_exist _ _ _ _)
@@ -548,15 +212,14 @@ Ltac liExist protect :=
lazymatch goal with
| |- @ex ?A ?P =>
first [
- custom_exist_tac A protect
+ liExist_hook A protect
| lazymatch A with
| TCForall2 _ _ _ => eexists _
- (* | Type => eexists _ *)
| @eq ?B ?x _ => exists (@eq_refl B x)
| prod _ _ => apply: tac_exist_prod
| sigT _ => apply: tac_exist_sigT
| unit => exists tt
- | ?A =>
+ | _ =>
first [
let p := constr:(_ : SimplExist A P _) in
refine (@simpl_exist_proof _ _ _ p _)
@@ -567,9 +230,118 @@ Ltac liExist protect :=
end
]
end ]
- | _ => fail "do_exist: unknown goal"
+ | _ => fail "liExist: unknown goal"
+ end.
+
+Tactic Notation "liExist" constr(c) := liExist c.
+Tactic Notation "liExist" := liExist true.
+
+(** ** [liImpl] *)
+Ltac liImpl :=
+ (* We pass false since [(∃ name, _) → _] is handled by [liForall]. *)
+ normalize_and_simpl_impl false.
+
+(** ** [liSideCond] *)
+Ltac liSideCond :=
+ lazymatch goal with
+ | |- ?P ∧ ?Q =>
+ lazymatch P with
+ | shelve_hint _ => split; [ unfold shelve_hint; shelve_sidecond |]
+ | _ => first [
+ lazymatch P with
+ | context [protected _] => fail
+ | _ => split; [splitting_fast_done|]
+ end
+ | progress normalize_goal_and
+ | lazymatch P with
+ | context [protected _] => first [
+ split; [ solve_protected_eq |]; unfold_instantiated_evars
+ | notypeclasses refine (@simpl_and_unsafe P _ _ Q _); [solve [refine _] |]
+ (* no simpl here because there is liSimpl after each tactic *)
+ ]
+ (* We use done instead of fast_done here because solving more
+ sideconditions here is a bigger performance win than the overhead
+ of done. *)
+ | _ => split; [ first [ done | shelve_sidecond ] | ]
+ end
+ ]
+ end
+ | _ => fail "liSideCond: unknown goal"
+ end.
+
+(** ** [liFindInContext] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_sep_true Δ (P : iProp Σ) :
+ envs_entails Δ P → envs_entails Δ (True ∗ P).
+ Proof. rewrite envs_entails_unseal => ->. by apply bi.True_sep_2. Qed.
+
+ Lemma tac_find_hyp_equal key (Q P P' R : iProp Σ) Δ `{!FindHypEqual key Q P P'}:
+ envs_entails Δ (P' ∗ R) →
+ envs_entails Δ (P ∗ R).
+ Proof. by revert select (FindHypEqual _ _ _ _) => ->. Qed.
+
+ Lemma tac_find_hyp Δ i p R (P : iProp Σ) :
+ envs_lookup i Δ = Some (p, P) →
+ envs_entails (envs_delete false i p Δ) R → envs_entails Δ (P ∗ R).
+ Proof.
+ rewrite envs_entails_unseal. intros ? HQ.
+ rewrite (envs_lookup_sound' _ false) // bi.intuitionistically_if_elim.
+ by apply bi.sep_mono_r.
+ Qed.
+
+ Lemma tac_find_in_context {Δ} {fic} {T : _ → iProp Σ} key (F : FindInContext fic key) :
+ envs_entails Δ (F T).(i2p_P) → envs_entails Δ (find_in_context fic T).
+ Proof. rewrite envs_entails_unseal. etrans; [done|]. apply i2p_proof. Qed.
+End coq_tactics.
+
+Ltac liFindHyp key :=
+ let rec go P Hs :=
+ lazymatch Hs with
+ | Esnoc ?Hs2 ?id ?Q => first [
+ lazymatch key with
+ | FICSyntactic =>
+ (* We try to unify using the opaquenes hints of
+ typeclass_instances. Directly doing exact: eq_refl
+ sometimes takes 30 seconds to fail (e.g. when trying
+ to unify GetMemberLoc for the same struct but with
+ different names.) TODO: investigate if constr_eq
+ could help even more
+ https://coq.inria.fr/distrib/current/refman/proof-engine/tactics.html#coq:tacn.constr-eq*)
+ unify Q P with typeclass_instances
+ | _ =>
+ notypeclasses refine (tac_find_hyp_equal key Q _ _ _ _ _); [solve [refine _]|];
+ lazymatch goal with
+ | |- envs_entails _ (?P' ∗ _) =>
+ unify Q P' with typeclass_instances
+ end
+ end;
+ notypeclasses refine (tac_find_hyp _ id _ _ _ _ _); [li_pm_reflexivity | li_pm_reduce]
+ | go P Hs2 ]
+ end in
+ lazymatch goal with
+ | |- envs_entails _ (?P ∗ _) =>
+ (* we don't want to try to unify if the goal contains protected
+ evars as this can take very long to fail *)
+ lazymatch P with
+ | context [protected _] => fail "cannot find hyp if it contains protected"
+ | _ => idtac
+ end;
+ let P := li_pm_reduce_val P in
+ let run_go P Hs Hi := first [go P Hs | go P Hi] in
+ lazymatch goal with
+ | |- envs_entails (Envs ?Hi ?Hs _) _ => run_go P Hs Hi
+ | H := (Envs ?Hi ?Hs _) |- _ => run_go P Hs Hi
+ end
end.
+Ltac liFindHypOrTrue key :=
+ first [
+ notypeclasses refine (tac_sep_true _ _ _)
+ | progress liFindHyp key
+ ].
+
Ltac liFindInContext :=
lazymatch goal with
| |- envs_entails _ (find_in_context ?fic ?T) =>
@@ -582,192 +354,43 @@ Ltac liFindInContext :=
[ shelve | typeclasses eauto | simpl; repeat liExist false; liFindHypOrTrue key ])
end.
-Ltac liTrue :=
- lazymatch goal with
- | |- envs_entails _ True => notypeclasses refine (tac_true _)
- end.
-
-Ltac li_shelve_sidecond :=
- idtac;
- lazymatch goal with
- | |- ?G => change_no_check (SHELVED_SIDECOND G); shelve
- end.
-
-Ltac li_unshelve_sidecond :=
- idtac;
- lazymatch goal with
- | |- SHELVED_SIDECOND ?G => change_no_check G
- | |- _ => shelve
- end.
-
-Ltac liFalse :=
- lazymatch goal with
- | |- envs_entails _ False => exfalso; li_shelve_sidecond
- | |- False => li_shelve_sidecond
- end.
-
-Ltac after_intro_hook := idtac.
-
-Ltac liImpl :=
- lazymatch goal with
- (* relying on the fact that unification variables cannot contain
- dependent variables to distinguish between dependent and non dependent forall *)
- | |- ?P -> ?Q =>
- lazymatch type of P with
- | Prop => first [
- (* first check if the hyp is trivial *)
- assert_is_trivial P; intros _
- |
- progress normalize_goal_impl; simpl
- |
- (*
- one could also try getting rid of the equality in the goal with something like the
- following, but it does not seem to be much faster:
- let inst := eval unfold li_this_is_a_dummy_definition in (_ : SimplImplUnsafe _ P _) in
- lazymatch (type of inst) with
- | SimplImplUnsafe false _ _ =>
- *)
- apply: apply_simpl_impl; simpl;
- match goal with
- | |- true = true -> _ => move => _
- | |- false = false -> ?P → _ => move => _;
- match P with
- | ∃ _, _ => fail 1 "handled by do_forall"
- | _ = _ =>
- check_injection_tac;
- let Hi := fresh "Hi" in move => Hi; injection Hi; clear Hi
- | _ => assert_is_not_trivial P; intros ?; subst; after_intro_hook
- | _ => move => _
- end
- end
- ]
- (* just some unused variable, forget it *)
- | _ => move => _
- end
- end.
-
-Ltac liForall :=
- (* n tells us how many quantifiers we should introduce with this name *)
- let rec do_intro n name :=
- lazymatch n with
- | S ?n' =>
- lazymatch goal with
- (* relying on the fact that unification variables cannot contain
- dependent variables to distinguish between dependent and non dependent forall *)
- | |- ?P -> ?Q =>
- lazymatch type of P with
- | Prop => fail "implication, not forall"
- | _ => (* just some unused variable, discard *) move => _
- end
- | |- forall _ : ?A, _ =>
- (* When changing this, also change [prepare_initial_coq_context] in automation.v *)
- lazymatch A with
- | (prod _ _) => case; do_intro (S (S O)) name
- | unit => case
- | _ =>
- first [
- (* We match again since having e in the context when calling fresh can mess up names. *)
- lazymatch goal with
- | |- forall e : ?A, @?P e =>
- let sn := open_constr:(_ : nat) in
- let p := constr:(_ : SimplForall A sn P _) in
- refine (@simpl_forall_proof _ _ _ _ p _);
- do_intro sn name
- end
- | let H := fresh name in intro H
- ]
- end
- end; do_intro n' name
- | O => idtac
- end
- in
- lazymatch goal with
- | |- envs_entails _ (bi_forall (λ name, _)) => notypeclasses refine (tac_do_forall _ _ _ _); do_intro (S O) name
- | |- envs_entails _ (bi_wand (bi_exist (λ name, _)) _) =>
- notypeclasses refine (tac_do_exist_wand _ _ _ _ _); do_intro (S O) name
- | |- (∃ name, _) → _ => case; do_intro (S O) name
- | |- forall name, _ => do_intro (S O) name
- | _ => fail "do_forall: unknown goal"
- end.
+(** ** [liSep] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
-(* This tactic checks if destructing x would lead to multiple
-non-trivial subgoals. The main reason for it is that we don't want to
-destruct constructors like true as this would not be useful. *)
-Ltac non_trivial_destruct x :=
- first [
- have : (const False x); [ clear; case_eq x; intros => //; (*
- check if there is only one goal remaining *) [ idtac ]; fail 1 "trivial destruct" |]
- | idtac
- ].
+ Lemma tac_sep_sep_assoc Δ (P Q R : iProp Σ) :
+ envs_entails Δ (P ∗ Q ∗ R) → envs_entails Δ ((P ∗ Q) ∗ R).
+ Proof. apply tac_fast_apply. iIntros "($&$&$)". Qed.
-Ltac record_destruct_hint hint info := idtac.
-Ltac liDestructHint :=
- lazymatch goal with
- | |- @envs_entails ?PROP ?Δ (destruct_hint ?hint ?info ?T) =>
- change_no_check (@envs_entails PROP Δ T);
- lazymatch hint with
- | DHintInfo =>
- record_destruct_hint hint info
- | DHintDestruct _ (@bool_decide ?P ?b) =>
- let H := fresh "H" in destruct_decide (@bool_decide_reflect P b) as H; revert H; [
- record_destruct_hint hint (info, true) |
- record_destruct_hint hint (info, false) ]
- | DHintDestruct _ ?x =>
- tryif (non_trivial_destruct x) then
- case_eq x; repeat liForall;
- lazymatch goal with
- | |- _ = ?res → _ =>
- record_destruct_hint hint (info, res)
- end
- else (
- idtac
- )
- | @DHintDecide ?P ?b =>
- let H := fresh "H" in destruct_decide (@decide P b) as H; revert H; [
- record_destruct_hint hint (info, true) |
- record_destruct_hint hint (info, false) ]
- end
- end; repeat (liForall || liImpl); try by [exfalso; can_solve_tac].
+ Lemma tac_sep_emp Δ (P : iProp Σ) :
+ envs_entails Δ P → envs_entails Δ (emp ∗ P).
+ Proof. apply tac_fast_apply. by apply bi.emp_sep_1. Qed.
-Ltac liTacticHint :=
- lazymatch goal with
- | |- envs_entails _ (tactic_hint _ _) =>
- simple notypeclasses refine (tac_tactic_hint _ _ _ _ _); [ solve [refine _] |]
- end.
+ Lemma tac_sep_exist_assoc {A} Δ (Φ : A → iProp Σ) (Q : iProp Σ):
+ envs_entails Δ (∃ a : A, Φ a ∗ Q) → envs_entails Δ ((∃ a : A, Φ a) ∗ Q).
+ Proof. by rewrite bi.sep_exist_r. Qed.
-Ltac liAccu :=
- lazymatch goal with
- | |- envs_entails _ (accu _) =>
- notypeclasses refine (tac_do_accu _ _ _); li_pm_reduce
- end.
+ Lemma tac_do_intro_pure_and Δ (P : Prop) (Q : iProp Σ) :
+ (P ∧ (envs_entails Δ Q)) → envs_entails Δ (⌜P⌠∗ Q).
+ Proof.
+ rewrite envs_entails_unseal => [[HP HΔ]].
+ iIntros "HΔ". iSplit => //. by iApply HΔ.
+ Qed.
-Ltac liSideCond :=
- lazymatch goal with
- | |- ?P ∧ ?Q =>
- lazymatch P with
- | shelve_hint _ => split; [ unfold shelve_hint; li_shelve_sidecond |]
- | _ => first [
- lazymatch P with
- | context [protected _] => fail
- | _ => split; [splitting_fast_done|]
- end |
- progress normalize_goal_and |
- lazymatch P with
- | context [protected _] => first [
- split; [ solve_protected_eq |]; unfold_instantiated_evars
- | notypeclasses refine (apply_simpl_and _ _ _ _ _); [ solve [refine _] |]; simpl;
- lazymatch goal with
- | |- true = true -> _ => move => _
- | _ => fail "could not simplify goal with evar"
- end
- ]
- (* We use done instead of fast_done here because solving more
- sideconditions here is a bigger performance win than the overhead
- of done. *)
- | _ => split; [ first [ done | li_shelve_sidecond ] | ]
- end ] end
- | _ => fail "do_side_cond: unknown goal"
- end.
+ Lemma tac_do_intro_intuit_sep Δ (P Q : iProp Σ) :
+ envs_entails Δ (□ (P ∗ True) ∧ Q) → envs_entails Δ (□ P ∗ Q).
+ Proof. apply tac_fast_apply. iIntros "[#[$ _] $]". Qed.
+
+ Lemma tac_do_simplify_goal Δ (n : N) (P : iProp Σ) T {SG : SimplifyGoal P (Some n)} :
+ envs_entails Δ (SG T).(i2p_P) → envs_entails Δ (P ∗ T).
+ Proof. apply tac_fast_apply. iIntros "HP". by iApply (i2p_proof with "HP"). Qed.
+
+ Lemma tac_intro_subsume_related Δ P T {Hrel : RelatedTo P}:
+ envs_entails Δ (find_in_context Hrel.(rt_fic) (λ x,
+ subsume (Σ:=Σ) (Hrel.(rt_fic).(fic_Prop) x) P T)) →
+ envs_entails Δ (P ∗ T).
+ Proof. apply tac_fast_apply. iDestruct 1 as (x) "[HP HT]". by iApply "HT". Qed.
+End coq_tactics.
Ltac liSep :=
lazymatch goal with
@@ -778,79 +401,274 @@ Ltac liSep :=
| bi_exist _ => notypeclasses refine (tac_sep_exist_assoc _ _ _ _)
| bi_emp => notypeclasses refine (tac_sep_emp _ _ _)
| (⌜_âŒ)%I => notypeclasses refine (tac_do_intro_pure_and _ _ _ _)
- (* TODO: Is this really the right thing to do? *)
- | (â–¡ ?P)%I => notypeclasses refine (tac_do_intro_intuit_sep _ _ _ _ _); [li_pm_reduce|]
+ | (â–¡ ?P)%I => notypeclasses refine (tac_do_intro_intuit_sep _ _ _ _)
| match ?x with _ => _ end => fail "should not have match in sep"
| ?P => first [
- convert_to_i2p P
- ltac:(fun T tac => li_let_bind T (fun H => let X := tac H in constr:(envs_entails Δ (X ∗ Q))))
- ltac:(fun converted =>
- simple notypeclasses refine (tac_apply_i2p_below_sep converted _); [solve[refine _] |])
- | progress liFindHyp FICSyntactic
- | simple notypeclasses refine (tac_fast_apply (tac_do_simplify_goal 0%N _ _) _); [solve [refine _] |]
- | simple notypeclasses refine (tac_fast_apply (tac_intro_subsume_related _ _) _); [solve [refine _] |];
+ progress liFindHyp FICSyntactic
+ | simple notypeclasses refine (tac_do_simplify_goal _ 0%N _ _ _); [solve [refine _] |]
+ | simple notypeclasses refine (tac_intro_subsume_related _ _ _ _); [solve [refine _] |];
simpl; liFindInContext
- | simple notypeclasses refine (tac_fast_apply (tac_do_simplify_goal _ _ _) _); [| solve [refine _] |]
+ | simple notypeclasses refine (tac_do_simplify_goal _ _ _ _ _); [| solve [refine _] |]
| fail "do_sep: unknown sidecondition" P
]
end
end.
+(** ** [liWand] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_do_intro_pure Δ (P : Prop) (Q : iProp Σ) :
+ (P → envs_entails Δ Q) → envs_entails Δ (⌜P⌠-∗ Q).
+ Proof.
+ rewrite envs_entails_unseal => HP. iIntros "HΔ %". by iApply HP.
+ Qed.
+
+ Lemma tac_do_simplify_hyp (P : iProp Σ) (SH: SimplifyHyp P (Some 0%N)) Δ T :
+ envs_entails Δ (SH T).(i2p_P) →
+ envs_entails Δ (P -∗ T).
+ Proof.
+ rewrite envs_entails_unseal => HP. iIntros "Henv Hl".
+ iDestruct (HP with "Henv") as "HP".
+ iDestruct (i2p_proof with "HP Hl") as "$".
+ Qed.
+
+ Lemma tac_do_intro i n' (P : iProp Σ) n Γs Γp T :
+ env_lookup i Γs = None →
+ env_lookup i Γp = None →
+ envs_entails (Envs Γp (Esnoc Γs i P) n') T →
+ envs_entails (Envs Γp Γs n) (P -∗ T).
+ Proof.
+ rewrite envs_entails_unseal => Hs Hp HP. iIntros "Henv Hl".
+ rewrite (envs_app_sound (Envs Γp Γs n) (Envs Γp (Esnoc Γs i P) n) false (Esnoc Enil i P)) //; simplify_option_eq => //.
+ iApply HP. iApply "Henv". iFrame.
+ Qed.
+
+ Lemma tac_do_intro_intuit i n' (P P' : iProp Σ) T n Γs Γp (Hpers : IntroPersistent P P') :
+ env_lookup i Γs = None →
+ env_lookup i Γp = None →
+ envs_entails (Envs (Esnoc Γp i P') Γs n') T →
+ envs_entails (Envs Γp Γs n) (P -∗ T).
+ Proof.
+ rewrite envs_entails_unseal => Hs Hp HP. iIntros "Henv HP".
+ iDestruct (@ip_persistent _ _ _ Hpers with "HP") as "#HP'".
+ rewrite (envs_app_sound (Envs Γp Γs n) (Envs (Esnoc Γp i P') Γs n) true (Esnoc Enil i P')) //; simplify_option_eq => //.
+ iApply HP. iApply "Henv".
+ iModIntro. by iSplit.
+ Qed.
+
+ Lemma tac_wand_sep_assoc Δ (P Q R : iProp Σ) :
+ envs_entails Δ (P -∗ Q -∗ R) → envs_entails Δ ((P ∗ Q) -∗ R).
+ Proof. by rewrite bi.wand_curry. Qed.
+
+ Lemma tac_wand_emp Δ (P : iProp Σ) :
+ envs_entails Δ P → envs_entails Δ (emp -∗ P).
+ Proof. apply tac_fast_apply. by iIntros "$". Qed.
+End coq_tactics.
+
Ltac liWand :=
let wand_intro P :=
first [
- let SH := constr:(_ : SimplifyHyp P (Some 0%N)) in
- simple notypeclasses refine (tac_do_simplify_hyp P SH _ _ _)
- |
- let P' := open_constr:(_) in
- let ip := constr:(_ : IntroPersistent P P') in
- let n := lazymatch goal with | [ H := Envs _ _ ?n |- _ ] => constr:(n) end in
- let H := constr:(IAnon n) in
- let n' := eval vm_compute in (Pos.succ n) in
- simple notypeclasses refine (tac_do_intro_intuit H n' P P' _ _ _ _ ip _ _ _); [reduction.pm_reflexivity..|]
- |
- let n := lazymatch goal with | [ H := Envs _ _ ?n |- _ ] => constr:(n) end in
- let H := constr:(IAnon n) in
- let n' := eval vm_compute in (Pos.succ n) in
- simple notypeclasses refine (tac_do_intro H n' P _ _ _ _ _ _ _); [reduction.pm_reflexivity..|]
- ] in
+ let SH := constr:(_ : SimplifyHyp P (Some 0%N)) in
+ simple notypeclasses refine (tac_do_simplify_hyp P SH _ _ _)
+ | let P' := open_constr:(_) in
+ let ip := constr:(_ : IntroPersistent P P') in
+ let n := lazymatch goal with | [ H := Envs _ _ ?n |- _ ] => n end in
+ let H := constr:(IAnon n) in
+ let n' := eval vm_compute in (Pos.succ n) in
+ simple notypeclasses refine (tac_do_intro_intuit H n' P P' _ _ _ _ ip _ _ _); [li_pm_reflexivity..|]
+ | let n := lazymatch goal with | [ H := Envs _ _ ?n |- _ ] => n end in
+ let H := constr:(IAnon n) in
+ let n' := eval vm_compute in (Pos.succ n) in
+ simple notypeclasses refine (tac_do_intro H n' P _ _ _ _ _ _ _); [li_pm_reflexivity..|]
+ ] in
lazymatch goal with
| |- envs_entails ?Δ (bi_wand ?P ?T) =>
lazymatch P with
| bi_sep _ _ =>
li_let_bind T (fun H => constr:(envs_entails Δ (bi_wand P H)));
notypeclasses refine (tac_wand_sep_assoc _ _ _ _ _)
- | bi_exist _ => fail "handled by do_forall"
+ | bi_exist _ => fail "handled by liForall"
| bi_emp => notypeclasses refine (tac_wand_emp _ _ _)
| bi_pure _ => notypeclasses refine (tac_do_intro_pure _ _ _ _)
- | match ?x with _ => _ end => fail "should not have match in wand "
+ | match ?x with _ => _ end => fail "should not have match in wand"
| _ => wand_intro P
end
end.
+(** ** [liAnd] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_do_split Δ (P1 P2 : iProp Σ):
+ envs_entails Δ P1 →
+ envs_entails Δ P2 →
+ envs_entails Δ (P1 ∧ P2).
+ Proof. rewrite envs_entails_unseal => HP1 HP2. by apply bi.and_intro. Qed.
+
+ Lemma tac_big_andM_insert Δ {A B} `{Countable A} (m : gmap A B) i n (Φ : _ → _→ iProp Σ) :
+ envs_entails Δ (⌜m !! i = None⌠∗ (Φ i n ∧ [∧ map] k↦v∈m, Φ k v)) →
+ envs_entails Δ ([∧ map] k↦v∈<[i:=n]>m, Φ k v).
+ Proof. apply tac_fast_apply. iIntros "[% HT]". by rewrite big_andM_insert. Qed.
+
+ Lemma tac_big_andM_empty Δ {A B} `{Countable A} (Φ : _ → _→ iProp Σ) :
+ envs_entails Δ ([∧ map] k↦v∈(∅ : gmap A B), Φ k v).
+ Proof. rewrite envs_entails_unseal. iIntros "_". by rewrite big_andM_empty. Qed.
+End coq_tactics.
+
Ltac liAnd :=
lazymatch goal with
| |- envs_entails _ (bi_and ?P _) =>
notypeclasses refine (tac_do_split _ _ _ _ _)
| |- envs_entails _ ([∧ map] _↦_∈<[_:=_]>_, _) =>
- notypeclasses refine (tac_fast_apply (tac_big_andM_insert _ _ _ _) _)
+ notypeclasses refine (tac_big_andM_insert _ _ _ _ _ _)
| |- envs_entails _ ([∧ map] _↦_∈∅, _) =>
- notypeclasses refine (tac_fast_apply (tac_big_andM_empty _) _)
+ notypeclasses refine (tac_big_andM_empty _ _)
+ end.
+
+(** ** [liPersistent] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_persistent Δ (P : iProp Σ) :
+ envs_entails (envs_clear_spatial Δ) P → envs_entails Δ (□ P).
+ Proof.
+ rewrite envs_entails_unseal => HP. iIntros "Henv".
+ iDestruct (envs_clear_spatial_sound with "Henv") as "[#Henv _]".
+ iModIntro. iApply (HP with "Henv").
+ Qed.
+End coq_tactics.
+
+Ltac liPersistent :=
+ lazymatch goal with
+ | |- envs_entails ?Δ (bi_intuitionistically ?P) =>
+ notypeclasses refine (tac_persistent _ _ _); li_pm_reduce
+ end.
+
+(** ** [liCase] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_case_if Δ (P : Prop) T1 T2 :
+ (P → envs_entails Δ T1) →
+ (¬ P → envs_entails Δ T2) →
+ envs_entails Δ (@case_if Σ P T1 T2).
+ Proof.
+ rewrite envs_entails_unseal => HT1 HT2.
+ iIntros "Henvs". iSplit; iIntros (?).
+ - by iApply HT1.
+ - by iApply HT2.
+ Qed.
+
+ Lemma tac_case_destruct_bool_decide Δ (P : Prop) `{!Decision P} T:
+ (P → envs_entails Δ (T true true)) →
+ (¬ P → envs_entails Δ (T false true)) →
+ envs_entails Δ (@case_destruct Σ bool (bool_decide P) T).
+ Proof.
+ rewrite envs_entails_unseal => HP HnotP.
+ iIntros "Henvs". iExists true. case_bool_decide.
+ - by iApply HP.
+ - by iApply HnotP.
+ Qed.
+
+ Lemma tac_case_destruct {A} (b : bool) Δ a T:
+ envs_entails Δ (T a b) →
+ envs_entails Δ (@case_destruct Σ A a T).
+ Proof. apply tac_fast_apply. iIntros "?". iExists _. iFrame. Qed.
+End coq_tactics.
+
+(* This tactic checks if destructing x would lead to multiple
+non-trivial subgoals. The main reason for it is that we don't want to
+destruct constructors like true as this would not be useful. *)
+Ltac non_trivial_destruct x :=
+ first [
+ have : (const False x); [ clear; case_eq x; intros => //; (*
+ check if there is only one goal remaining *) [ idtac ]; fail 1 "trivial destruct" |]
+ | idtac
+ ].
+
+Ltac liCase :=
+ lazymatch goal with
+ | |- @envs_entails ?PROP ?Δ (case_if ?P ?T1 ?T2) =>
+ notypeclasses refine (tac_case_if _ _ _ _ _ _)
+ | |- @envs_entails ?PROP ?Δ (case_destruct (@bool_decide ?P ?b) ?T) =>
+ notypeclasses refine (tac_case_destruct_bool_decide _ _ _ _ _)
+ (* notypeclasses refine (tac_case_destruct true _ _ _ _); *)
+ (* let H := fresh "H" in destruct_decide (@bool_decide_reflect P b) as H; revert H *)
+ | |- @envs_entails ?PROP ?Δ (case_destruct ?x ?T) =>
+ tryif (non_trivial_destruct x) then
+ notypeclasses refine (tac_case_destruct true _ _ _ _);
+ case_eq x
+ else (
+ notypeclasses refine (tac_case_destruct false _ _ _ _)
+ )
+ end;
+ (* It is important that we prune branches this way because this way
+ we don't need to do normalization and simplification of hypothesis
+ that we introduce twice, which has a big impact on performance. *)
+ repeat (liForall || liImpl); try by [exfalso; can_solve].
+
+(** ** [liTactic] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_li_tactic {A} Δ t (th : LiTactic t) (Q : A → iProp Σ):
+ envs_entails Δ (th.(li_tactic_P) Q) →
+ envs_entails Δ (li_tactic t Q).
+ Proof. rewrite envs_entails_unseal => ?. etrans; [done|]. apply li_tactic_proof. Qed.
+End coq_tactics.
+
+Ltac liTactic :=
+ lazymatch goal with
+ | |- envs_entails _ (li_tactic _ _) =>
+ simple notypeclasses refine (tac_li_tactic _ _ _ _ _); [ solve [refine _] |]
+ end.
+
+(** ** [liAccu] *)
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_do_accu Δ (f : iProp Σ → iProp Σ):
+ envs_entails (envs_clear_spatial Δ) (f (env_to_prop (env_spatial Δ))) →
+ envs_entails Δ (accu f).
+ Proof.
+ rewrite envs_entails_unseal => Henv. iIntros "Henv".
+ iDestruct (envs_clear_spatial_sound with "Henv") as "[#Henv Hs]".
+ iExists (env_to_prop (env_spatial Δ)).
+ rewrite -env_to_prop_sound. iFrame. iModIntro. by iApply (Henv with "Henv").
+ Qed.
+End coq_tactics.
+
+Ltac liAccu :=
+ lazymatch goal with
+ | |- envs_entails _ (accu _) =>
+ notypeclasses refine (tac_do_accu _ _ _); li_pm_reduce
+ end.
+
+(** ** [liTrace] *)
+Ltac liTrace :=
+ lazymatch goal with
+ | |- @envs_entails ?PROP ?Δ (li_trace ?info ?T) =>
+ change_no_check (@envs_entails PROP Δ T);
+ liTrace_hook info
end.
+(** ** [liStep] *)
Ltac liStep :=
first [
- liExtensibleJudgement
+ liExtensible
| liSep
| liAnd
| liWand
- | liExist true
+ | liExist
| liImpl
| liForall
| liSideCond
| liFindInContext
- | liDestructHint
- | liTacticHint
+ | liCase
+ | liTrace
+ | liTactic
+ | liPersistent
| liTrue
| liFalse
| liAccu
diff --git a/theories/lithium/lithium.v b/theories/lithium/lithium.v
deleted file mode 100644
index 7944e8a749421c8d30153bd68de9164f966524d1..0000000000000000000000000000000000000000
--- a/theories/lithium/lithium.v
+++ /dev/null
@@ -1 +0,0 @@
-From lithium Require Export classes infrastructure.
diff --git a/theories/lithium/normalize.v b/theories/lithium/normalize.v
index 9aa6387e68e49935fedfeda16159708bbe71b631..751ea5663f8f056eb831e48839e4c2ba2100bc1a 100644
--- a/theories/lithium/normalize.v
+++ b/theories/lithium/normalize.v
@@ -1,4 +1,27 @@
-From lithium Require Import base tactics_extend infrastructure.
+From lithium Require Export base.
+From lithium Require Import hooks pure_definitions.
+
+(** This file provides rewrite-based normalization infrastructure for
+pure sideconditions. *)
+
+(** * General normalization infrastructure *)
+Lemma tac_normalize_goal (P1 P2 : Prop):
+ P2 = P1 → P1 → P2.
+Proof. by move => ->. Qed.
+Lemma tac_normalize_goal_and (P1 P2 T : Prop):
+ P2 = P1 → P1 ∧ T → P2 ∧ T.
+Proof. by move => ->. Qed.
+Lemma tac_normalize_goal_impl (P1 P2 T : Prop):
+ P2 = P1 → (P1 → T) → (P2 → T).
+Proof. by move => ->. Qed.
+
+(* TODO: don't do anything if there is no progress? *)
+Ltac normalize_goal :=
+ notypeclasses refine (tac_normalize_goal _ _ _ _); [normalize_hook|].
+Ltac normalize_goal_and :=
+ notypeclasses refine (tac_normalize_goal_and _ _ _ _ _); [normalize_hook|].
+Ltac normalize_goal_impl :=
+ notypeclasses refine (tac_normalize_goal_impl _ _ _ _ _); [normalize_hook|].
(** * First version of normalization based on [autorewrite] *)
Create HintDb lithium_rewrite discriminated.
@@ -6,8 +29,8 @@ Create HintDb lithium_rewrite discriminated.
Ltac normalize_autorewrite :=
autorewrite with lithium_rewrite; exact: eq_refl.
-#[export] Hint Rewrite @drop_0 @take_ge using can_solve_tac : lithium_rewrite.
-#[export] Hint Rewrite @take_app_le @drop_app_ge using can_solve_tac : lithium_rewrite.
+#[export] Hint Rewrite @drop_0 @take_ge using can_solve : lithium_rewrite.
+#[export] Hint Rewrite @take_app_le @drop_app_ge using can_solve : lithium_rewrite.
#[export] Hint Rewrite @insert_length @app_length @fmap_length @rotate_length @replicate_length @drop_length : lithium_rewrite.
#[export] Hint Rewrite <- @fmap_take @fmap_drop : lithium_rewrite.
#[export] Hint Rewrite @list_insert_fold : lithium_rewrite.
@@ -17,17 +40,17 @@ Ltac normalize_autorewrite :=
#[export] Hint Rewrite <- @app_assoc @cons_middle : lithium_rewrite.
#[export] Hint Rewrite @app_nil_r @rev_involutive : lithium_rewrite.
#[export] Hint Rewrite <- @list_fmap_insert : lithium_rewrite.
-#[export] Hint Rewrite <- minus_n_O plus_n_O minus_n_n : lithium_rewrite.
+#[export] Hint Rewrite Nat.sub_0_r Nat.add_0_r Nat.sub_diag : lithium_rewrite.
#[export] Hint Rewrite Nat2Z.id Nat2Z.inj_add Nat2Z.inj_mul : lithium_rewrite.
-#[export] Hint Rewrite Z2Nat.inj_mul Z2Nat.inj_sub Z2Nat.id using can_solve_tac : lithium_rewrite.
-#[export] Hint Rewrite Nat.succ_pred_pos using can_solve_tac : lithium_rewrite.
+#[export] Hint Rewrite Z2Nat.inj_mul Z2Nat.inj_sub Z2Nat.id using can_solve : lithium_rewrite.
+#[export] Hint Rewrite Nat.succ_pred_pos using can_solve : lithium_rewrite.
#[export] Hint Rewrite Nat.add_assoc Nat.min_id : lithium_rewrite.
-#[export] Hint Rewrite Z.quot_mul using can_solve_tac : lithium_rewrite.
+#[export] Hint Rewrite Z.quot_mul using can_solve : lithium_rewrite.
#[export] Hint Rewrite <-Nat.mul_sub_distr_r Z.mul_add_distr_r Z.mul_sub_distr_r : lithium_rewrite.
#[export] Hint Rewrite @bool_decide_eq_x_x_true @if_bool_decide_eq_branches : lithium_rewrite.
#[export] Hint Rewrite @bool_decide_eq_true_2 @bool_decide_eq_false_2 using fast_done : lithium_rewrite.
#[export] Hint Rewrite bool_to_Z_neq_0_bool_decide bool_to_Z_eq_0_bool_decide : lithium_rewrite.
-#[export] Hint Rewrite keep_factor2_is_power_of_two keep_factor2_min_eq using can_solve_tac : lithium_rewrite.
+#[export] Hint Rewrite keep_factor2_is_power_of_two keep_factor2_min_eq using can_solve : lithium_rewrite.
#[export] Hint Rewrite keep_factor2_min_1 keep_factor2_twice : lithium_rewrite.
Local Definition lookup_insert_gmap A K `{Countable K} := lookup_insert (M := gmap K) (A := A).
@@ -93,7 +116,7 @@ Proof. unfold Normalize in *; subst. by rewrite rev_involutive. Qed.
Global Hint Extern 5 (Normalize _ (rev (rev _)) _) => class_apply normalize_rev_involutive : typeclass_instances.
Lemma normalize_minus_n_O n:
Normalize true (n - 0)%nat n.
-Proof. unfold Normalize in *; subst. by rewrite -minus_n_O. Qed.
+Proof. unfold Normalize in *; subst. by rewrite Nat.sub_0_r. Qed.
Global Hint Extern 5 (Normalize _ (_ - 0)%nat _) => class_apply normalize_minus_n_O : typeclass_instances.
Lemma normalize_rotate_length A n (l : list A) r p `{!Normalize p (length l) r} :
Normalize true (length (rotate n l)) r.
diff --git a/theories/lithium/proof_state.v b/theories/lithium/proof_state.v
new file mode 100644
index 0000000000000000000000000000000000000000..c1c27d301d798b3faafdcd29299c963b17a48b0f
--- /dev/null
+++ b/theories/lithium/proof_state.v
@@ -0,0 +1,353 @@
+From iris.proofmode Require Import coq_tactics reduction.
+From lithium Require Export base.
+From lithium Require Import hooks definitions syntax.
+Set Default Proof Using "Type".
+
+(** This file contains some tactics for proof state management. *)
+
+(** * Management of shelved sideconditions *)
+Definition SHELVED_SIDECOND (P : Prop) : Prop := P.
+Arguments SHELVED_SIDECOND : simpl never.
+Strategy expand [SHELVED_SIDECOND].
+
+Ltac shelve_sidecond :=
+ idtac;
+ lazymatch goal with
+ | |- ?G => change_no_check (SHELVED_SIDECOND G); shelve
+ end.
+
+Ltac unshelve_sidecond :=
+ idtac;
+ lazymatch goal with
+ | |- SHELVED_SIDECOND ?G => change_no_check G
+ | |- _ => shelve
+ end.
+
+(** * Generating typeclass instances *)
+(** [generate_i2p_instance print to_tc c] generates an instance for an
+[iProp_to_Prop]-based typeclass from the lemma c. The parameters not
+part of the arguments of the typeclass must come last in the same
+order as expected by the typeclass. This tactic tries to solve pure
+[Prop] assumptions via [eq_refl]. [to_tc] is a tactic that converts
+the conclusion of the lemma to the corresponding typeclass and is
+called with [arg]. [print] controls whether to output debug printing.
+*)
+Ltac generate_i2p_instance print to_tc arg c :=
+ let do_print t := tryif print then t else idtac in
+ let do_to_tc c :=
+ match c with
+ (* to_tc must be first to allow overriding of the cases below *)
+ | _ => to_tc arg c
+ | subsume ?x1 ?x2 => constr:(Subsume x1 x2)
+ | subsume_list ?x1 ?x2 ?x3 ?x4 ?x5 => constr:(SubsumeList x1 x2 x3 x4 x5)
+ | find_in_context ?x1 => constr:(FindInContext x1 arg)
+ | simplify_hyp ?x1 => constr:(SimplifyHyp x1 (Some arg))
+ | simplify_goal ?x1 => constr:(SimplifyGoal x1 (Some arg))
+ end in
+ let type_c := type of c in
+ let type_c := eval lazy zeta in type_c in
+ do_print ltac:(idtac "current:" c);
+ do_print ltac:(idtac "type:" type_c);
+ (* Try to find the typeclass *)
+ try (
+ let tc := lazymatch type_c with
+ | (∀ _ _ _ _ _ _ _ _ _ _, _ ⊢ ?Q _ _ _ _ _ _ _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _ _ _ _ _ _ _, _ ⊢ ?Q _ _ _ _ _ _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _ _ _ _ _ _, _ ⊢ ?Q _ _ _ _ _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _ _ _ _ _, _ ⊢ ?Q _ _ _ _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _ _ _ _, _ ⊢ ?Q _ _ _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _ _ _, _ ⊢ ?Q _ _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _ _, _ ⊢ ?Q _ _ _ _) => do_to_tc Q
+ | (∀ _ _ _, _ ⊢ ?Q _ _ _) => do_to_tc Q
+ | (∀ _ _, _ ⊢ ?Q _ _) => do_to_tc Q
+ | (∀ _, _ ⊢ ?Q _) => do_to_tc Q
+ end in
+ do_print ltac:(idtac "found typeclass:" tc);
+ notypeclasses refine (_ : tc));
+ (* Try to reorder hypothesis that don't occur in the goal to the
+ front (e.g. TCDone assumptions or similar). Note that this code
+ reverse the order if there are multiple such assumptions. *)
+ let c := match type_c with
+ | (∀ a1 a2 a3 a4 a5 _, _ ⊢ ?G) =>
+ eval lazy beta zeta in (λ b a1 a2 a3 a4 a5, c a1 a2 a3 a4 a5 b)
+ | (∀ a1 a2 a3 a4 _, _ ⊢ ?G) =>
+ eval lazy beta zeta in (λ b a1 a2 a3 a4, c a1 a2 a3 a4 b)
+ | (∀ a1 a2 a3 _, _ ⊢ ?G) =>
+ eval lazy beta zeta in (λ b a1 a2 a3, c a1 a2 a3 b)
+ | (∀ a1 a2 _, _ ⊢ ?G) =>
+ eval lazy beta zeta in (λ b a1 a2, c a1 a2 b)
+ | (∀ a1 _, _ ⊢ ?G) =>
+ eval lazy beta zeta in (λ b a1, c a1 b)
+ | _ => c
+ end in
+ let type_c := type of c in
+ let type_c := eval lazy zeta in type_c in
+ do_print ltac:(idtac "current after reorder:" c);
+ do_print ltac:(idtac "type after reorder:" type_c);
+ lazymatch type_c with
+ | ∀ (a : ?T), @?P a =>
+ (* Check if there is a sidecondition after the continuation, that we
+ can solve with eq_refl. *)
+ tryif (lazymatch type of T with | Prop => let x := constr:(eq_refl : T) in idtac end) then
+ do_print ltac:(idtac "solve with eq_refl:" T);
+ let x := constr:(eq_refl : T) in
+ let y := eval lazy beta zeta in (c x) in
+ generate_i2p_instance print to_tc arg y
+ else
+ lazymatch type of c with
+ | ∀ a, @?P a =>
+ let a := fresh a in
+ notypeclasses refine (λ a, _);
+ let y := eval lazy beta zeta in (c a) in
+ generate_i2p_instance print to_tc arg y
+ end
+ | ?P ⊢ ?G =>
+ (* Finish the instance. *)
+ let Q := liFromSyntaxTerm P in
+ (* Print rule in lithium syntax *)
+(* assert_fails (
+ assert (⊢ Q); [
+ liToSyntax;
+ lazymatch goal with | |- ⊢ ?conv =>
+ let P' := eval unfold li.ret in P in
+ lazymatch conv with
+ | P' => idtac
+ | _ => idtac G ":-" conv
+ end end;
+ fail |] ); *)
+ do_print ltac:(idtac "rule:" Q "⊢" G "term:" c);
+ notypeclasses refine (@i2p _ G Q c)
+ end.
+
+Notation "'[instance' x ]" :=
+ ltac:(generate_i2p_instance ltac:(fail) ltac:(generate_i2p_instance_to_tc_hook)
+ constr:(tt) constr:(x)) (only parsing).
+Notation "'[instance?' x ]" :=
+ ltac:(generate_i2p_instance ltac:(idtac) ltac:(generate_i2p_instance_to_tc_hook)
+ constr:(tt) constr:(x)) (only parsing).
+Notation "'[instance' x 'with' y ]" :=
+ ltac:(generate_i2p_instance ltac:(fail) ltac:(generate_i2p_instance_to_tc_hook)
+ constr:(y) constr:(x)) (only parsing).
+Notation "'[instance?' x 'with' y ]" :=
+ ltac:(generate_i2p_instance ltac:(idtac) ltac:(generate_i2p_instance_to_tc_hook)
+ constr:(y) constr:(x)) (only parsing).
+Notation "'[instance' x 'as' y ]" :=
+ ltac:(generate_i2p_instance ltac:(fail) ltac:(fun _ _ => y)
+ constr:(tt) constr:(x)) (only parsing).
+Notation "'[instance?' x 'as' y ]" :=
+ ltac:(generate_i2p_instance ltac:(idtac) ltac:(fun _ _ => y)
+ constr:(tt) constr:(x)) (only parsing).
+
+(** * Optimization: Introduce let-bindings for environment *)
+Notation "'HIDDEN'" := (Envs _ _ _) (only printing).
+
+Ltac li_pm_reduce_val v :=
+ let v := li_pm_reduce_hook v in
+ let v := reduction.pm_eval v in v.
+Ltac li_pm_reduce :=
+ match goal with
+ | H := Envs _ _ _ |- ?u =>
+ let u := eval cbv [H] in u in
+ let u := li_pm_reduce_val u in
+ change u
+ | |- ?u =>
+ let u := li_pm_reduce_val u in
+ change u
+ end.
+Ltac li_pm_reflexivity := li_pm_reduce; exact eq_refl.
+
+Ltac let_bind_envs :=
+ lazymatch goal with
+ | |- @envs_entails ?PROP ?Δ ?P =>
+ let with_H tac :=
+ match goal with
+ | [ H := Envs _ _ _ |- _] =>
+ (** if we already have a binding, try to reuse it *)
+ lazymatch Δ with H => tac H | _ => unify Δ (H); tac H end
+ | [ H := Envs _ _ _ |- _] =>
+ (** if reusing does not work, create a new let-binding *)
+ lazymatch Δ with
+ | Envs _ _ _ =>
+ let H' := fresh "IPM_JANNO" in
+ pose (H' := Δ);
+ clear H;
+ rename H' into H
+ end;
+ tac H
+ | _ =>
+ (** otherwise, create a new binding *)
+ lazymatch Δ with
+ | Envs _ _ _ =>
+ let H := fresh "IPM_JANNO" in
+ pose (H := Δ);
+ hnf in (value of H);
+ tac H
+ end
+ end in
+ with_H ltac:(fun H => change_no_check (envs_entails H P))
+ end.
+
+(** * Checking if the context contains ownership of a certain assertion *)
+(** Note that this implementation requires that [let_bind_envs] has
+ been called previously when there was a envs_entails goal. *)
+Ltac check_own_in_context P :=
+ let rec go Hs :=
+ lazymatch Hs with
+ | Esnoc ?Hs2 ?id ?Q =>
+ first [ unify Q P with typeclass_instances | go Hs2 ]
+ end in
+ match goal with
+ | H := Envs ?Δi ?Δs _ |- _ =>
+ first [ go Δs | go Δi ]
+ end.
+Global Hint Extern 1 (CheckOwnInContext ?P) => (check_own_in_context P; constructor; exact: I) : typeclass_instances.
+
+(** * Optimization: Introduce let-bindings for subterms of the goal *)
+Definition LET_ID {A} (x : A) : A := x.
+Arguments LET_ID : simpl never.
+Notation "'HIDDEN'" := (LET_ID _) (only printing).
+Strategy expand [LET_ID].
+
+(* These tactics are prefixed with "li_" because they work with
+[LET_ID] and are a bit more specialized than one might expect. *)
+Tactic Notation "li_let_bind" constr(T) tactic3(tac) :=
+ try (assert_fails (is_var T);
+ let H := fresh "GOAL" in
+ pose H := (LET_ID T);
+ let G := tac H in
+ change_no_check G).
+
+Ltac li_unfold_lets_containing H :=
+ repeat match goal with
+ | Hx := context [ H ] |- _ =>
+ unfold LET_ID in Hx;
+ unfold Hx in *;
+ clear Hx
+ end.
+
+Ltac li_unfold_lets_in_context :=
+ repeat match goal with
+ | H := LET_ID _ |- _ => unfold LET_ID in H; unfold H; clear H
+ | H := Envs _ _ _ |- _ => unfold H; clear H
+ end.
+
+(** * Management of evars *)
+Definition EVAR_ID {A} (x : A) : A := x.
+Arguments EVAR_ID : simpl never.
+Strategy expand [EVAR_ID].
+
+Section coq_tactics.
+ Context {Σ : gFunctors}.
+
+ Lemma tac_protected_eq_app {A} (f : A → Prop) a :
+ f a → f (protected a).
+ Proof. by rewrite protected_eq. Qed.
+
+ Lemma tac_protected_eq_app_rev {A} (f : A → Prop) a :
+ f (protected a) → f a.
+ Proof. by rewrite protected_eq. Qed.
+End coq_tactics.
+
+Ltac unfold_all_protected_evars :=
+ repeat rewrite protected_eq;
+ repeat match goal with
+ | He := EVAR_ID _ |- _ => unfold He, EVAR_ID; clear He
+ end.
+
+Ltac create_protected_evar A :=
+ (* necessary, otherwise pattern might not find all occurences later,
+ see also instantiate protected *)
+ let A := eval cbn in A in
+ let Hevar := fresh "Hevar" in
+ (* see https://stackoverflow.com/a/46178884*)
+ let c :=
+ match goal with
+ | _ =>
+ let x := fresh "x" in
+ unshelve evar (x : A); [ li_unfold_lets_in_context; unfold_all_protected_evars; shelve |];
+ pose (Hevar := EVAR_ID x : A); unfold x in Hevar; clear x
+ end in
+ Hevar.
+
+Ltac unfold_instantiated_evar H :=
+ li_unfold_lets_containing H;
+ unfold_instantiated_evar_hook H;
+ revert H;
+ repeat match goal with
+ | |- let _ := EVAR_ID ?body in _ =>
+ match goal with
+ | He := EVAR_ID ?var |- _ => is_evar var;
+ lazymatch body with
+ | context [ var ] => pattern var;
+ lazymatch goal with
+ | |- ?G ?E =>
+ change (G He);
+ simple refine (tac_protected_eq_app_rev _ _ _);
+ cbv beta
+ end
+ end
+ end
+ end;
+ (* This is copied from the end of liInstantiateProtected *)
+ let tmp := fresh "tmp" in
+ intros tmp;
+ pattern (protected tmp);
+ simple refine (tac_protected_eq_app _ _ _);
+ unfold tmp, EVAR_ID; clear tmp.
+
+(*
+ H should be (protected Hevar) where Hevar is the letbinding of an evar
+ tac_with should be something like
+ ltac:(fun H => instantiate (1:= (protected (EVAR_ID _) + protected (EVAR_ID _))%nat) in (Value of H)
+ it should use instantiate (1:= ...) in (Value of H) to instantiate the first evar in the supplied parameter which will be Hevar
+ It can use _ to create new evars, but they should be surrounded by [protected (EVAR_ID _)] such that instantiate_protected can find them and create the right let bindings afterwards.
+*)
+Ltac do_instantiate_protected H' tac_with :=
+ lazymatch H' with
+ | protected ?H =>
+ li_unfold_lets_containing H;
+ unfold EVAR_ID in H;
+ (* we have to be vary careful how we instantiate the evar, as it
+ may not rely on things introduced later (even let bindings),
+ otherwise unification fails *)
+ tac_with H;
+ revert H;
+ repeat lazymatch goal with
+ | |- let _ := ?body in _ =>
+ lazymatch body with
+ | context [EVAR_ID ?x] =>
+ let Hevar := fresh "Hevar" in
+ set (Hevar := (EVAR_ID x));
+ (* necessary, otherwise pattern might not find all occurences
+ later, see also liCreateProtectedEvar *)
+ cbn in (type of Hevar)
+ end
+ end;
+ (* This is copied from the end of liUnfoldInstantiatedEvar *)
+ let tmp := fresh "tmp" in
+ intros tmp;
+ pattern (protected tmp);
+ simple refine (tac_protected_eq_app _ _ _);
+ unfold tmp, EVAR_ID; clear tmp
+ end.
+Tactic Notation "instantiate_protected" hyp(H) open_constr(c) :=
+ do_instantiate_protected (protected H) ltac:(fun H => instantiate (1:=c) in (value of H)).
+
+Ltac unfold_instantiated_evars :=
+ repeat match goal with
+ | H := EVAR_ID ?x |- _ =>
+ assert_fails (is_evar x);
+ unfold_instantiated_evar H
+ end.
+
+Create HintDb solve_protected_eq_db discriminated.
+Global Hint Constants Opaque : solve_protected_eq_db.
+
+Ltac solve_protected_eq :=
+ (* intros because it is less aggressive than move => * *)
+ intros;
+ solve_protected_eq_hook;
+ li_unfold_lets_in_context;
+ unfold_all_protected_evars;
+ lazymatch goal with |- ?a = ?b => unify a b with solve_protected_eq_db end;
+ exact: eq_refl.
diff --git a/theories/lithium/pure_definitions.v b/theories/lithium/pure_definitions.v
new file mode 100644
index 0000000000000000000000000000000000000000..66aaad923bab6305847c63d2620e353ebf5ea422
--- /dev/null
+++ b/theories/lithium/pure_definitions.v
@@ -0,0 +1,35 @@
+From lithium Require Export base.
+From lithium Require Import hooks.
+
+(** This file contains the pure definitions that are used by the
+automation. *)
+
+(** * [protected] *)
+(** [protected] is wrapped around evars to prevent them from being
+accidentally instantiated. *)
+Definition protected_def {A} (a : A) : A := a.
+Definition protected_aux {A} (a : A) : seal (@protected_def A a). by eexists. Qed.
+Definition protected {A} (a : A) : A := (protected_aux a).(unseal).
+Definition protected_eq {A} (a : A) : protected a = a := (protected_aux a).(seal_eq).
+(** We make [protected] Typeclasses Opaque to tell typeclasses eauto
+it can use discrimination nets for it. *)
+Global Typeclasses Opaque protected.
+
+Class ContainsProtected {A} (x : A) : Set := contains_protected: ().
+Class IsProtected {A} (x : A) : Set := is_protected: ().
+Global Hint Extern 0 (ContainsProtected ?x) => (match x with | context [protected _] => exact: tt end) : typeclass_instances.
+Global Hint Extern 0 (IsProtected (protected _) ) => (exact: tt) : typeclass_instances.
+
+(** * [CanSolve] *)
+(** Exposes the general purpose solver in [can_solve_hook] (see
+ hooks.v) as the [can_solve] tactic and via the [CanSolve] typeclass. *)
+Tactic Notation "can_solve" := can_solve_hook.
+Class CanSolve (P : Prop) : Prop := can_solve_proof: P.
+Global Hint Extern 10 (CanSolve ?P) => (change P; can_solve) : typeclass_instances.
+
+(** * [shelve_hint] *)
+(** [shelve_hint P] tells the automation it should shelve [P] even if
+it contains evars. *)
+Definition shelve_hint (P : Prop) : Prop := P.
+Global Typeclasses Opaque shelve_hint.
+Arguments shelve_hint : simpl never.
diff --git a/theories/lithium/simpl_classes.v b/theories/lithium/simpl_classes.v
index 15683c187b62c94e23139e8fcf2203eea6f8acca..3a3acc257d9d97349c9e4dabc491e85c1fdce847 100644
--- a/theories/lithium/simpl_classes.v
+++ b/theories/lithium/simpl_classes.v
@@ -1,31 +1,38 @@
-From lithium Require Import base.
+From lithium Require Export base.
+(** This file provides the classes for the simplification
+infrastructure for pure sideconditions. *)
+
+(** * [SimplExist] and [SimplForall] *)
Class SimplExist (T : Type) (e : T → Prop) (Q: Prop) := simpl_exist_proof : Q → ∃ x, e x.
Class SimplForall (T : Type) (n : nat) (e : T → Prop) (Q: Prop) := simpl_forall_proof : Q → ∀ x, e x.
+(** * [SimplImpl] and [SimplAnd] *)
+
+(** ** [SimplImplUnsafe] and [SimplAndUnsafe] *)
+(** changed = false indicates that the topmost implication did not
+change and should be introduced (but potentially more information was
+added after it). *)
Class SimplImplUnsafe (changed : bool) (P : Prop) (Ps : Prop → Prop) := simpl_impl_unsafe T: (Ps T) → (P → T).
-Class SimplAndUnsafe (changed : bool) (P : Prop) (Ps : Prop → Prop) := simpl_and_unsafe T: (Ps T) → (P ∧ T).
-Global Instance simplimpl_unsafe_id (P : Prop) : SimplImplUnsafe false P (λ T, P → T) | 1000.
-Proof. by move => ?. Qed.
-Global Instance simpland_unsafe_id (P : Prop) : SimplAndUnsafe false P (λ T, P ∧ T) | 1000.
-Proof. by move => ?. Qed.
+Class SimplAndUnsafe (P : Prop) (Ps : Prop → Prop) := simpl_and_unsafe T: (Ps T) → (P ∧ T).
Global Instance simpland_unsafe_not_neq {A} (x y : A) :
- SimplAndUnsafe true (¬ (x ≠y)) (λ T, x = y ∧ T) | 1000.
+ SimplAndUnsafe (¬ (x ≠y)) (λ T, x = y ∧ T) | 1000.
Proof. move => T [? ?]. by eauto. Qed.
-(* safe variants which ensure that no information is lost *)
-(* changed = false can be used to prevent infinite loops when adding
-additional information. See below for more an example. It only makes sense for Impl *)
+(** ** [SimplImpl] and [SimplAnd] *)
+(** [SimplImpl] and [SimplAnd] are safe variants which ensure that no
+information is lost. *)
Class SimplImpl (changed : bool) (P : Prop) (Ps : Prop → Prop) := simpl_impl T: (Ps T) ↔ (P → T).
Class SimplAnd (P : Prop) (Ps : Prop → Prop) := simpl_and T: (Ps T) ↔ (P ∧ T).
Global Instance simplimpl_simplunsafe c P Ps {Hi: SimplImpl c P Ps} :
SimplImplUnsafe c P Ps.
Proof. unfold SimplImpl, SimplImplUnsafe in *. naive_solver. Qed.
Global Instance simpland_simplunsafe P Ps {Hi: SimplAnd P Ps} :
- SimplAndUnsafe true P Ps.
+ SimplAndUnsafe P Ps.
Proof. unfold SimplAnd, SimplAndUnsafe in *. naive_solver. Qed.
+(** ** [SimplImplRel] and [SimplAndRel] *)
Class SimplImplRel {A} (R : relation A) (changed : bool) (x1 x2 : A) (Ps : Prop → Prop)
:= simpl_impl_eq T: (Ps T) ↔ (R x1 x2 → T).
Class SimplAndRel {A} (R : relation A) (x1 x2 : A) (Ps : Prop → Prop)
@@ -43,6 +50,7 @@ Global Instance simpl_and_rel_inst2 {A} R (x1 x2 : A) Ps `{!SimplAndRel R x2 x1
SimplAnd (R x1 x2) Ps.
Proof. unfold SimplAndRel, SimplAnd in *. naive_solver. Qed.
+(** ** [SimplBoth] *)
Class SimplBoth (P1 P2 : Prop) := simpl_both: P1 ↔ P2.
Global Instance simpl_impl_both_inst P1 P2 {Hboth : SimplBoth P1 P2}:
SimplImpl true P1 (λ T, P2 → T).
@@ -51,6 +59,7 @@ Global Instance simpl_and_both_inst P1 P2 {Hboth : SimplBoth P1 P2}:
SimplAnd P1 (λ T, P2 ∧ T).
Proof. unfold SimplBoth in Hboth. split; naive_solver. Qed.
+(** ** [SimplBothRel] *)
Class SimplBothRel {A} (R : relation A) (x1 x2 : A) (P2 : Prop) := simpl_both_eq: R x1 x2 ↔ P2.
Global Instance simpl_both_rel_inst1 {A} R (x1 x2 : A) P2 `{!SimplBothRel R x1 x2 P2}:
SimplBoth (R x1 x2) P2.
@@ -58,10 +67,3 @@ Proof. unfold SimplBothRel, SimplBoth in *. naive_solver. Qed.
Global Instance simpl_both_rel_inst2 {A} R (x1 x2 : A) P2 `{!SimplBothRel R x2 x1 P2} `{!Symmetric R}:
SimplBoth (R x1 x2) P2.
Proof. unfold SimplBothRel, SimplBoth in *. naive_solver. Qed.
-
-Lemma apply_simpl_impl b P Ps T {Himpl: SimplImplUnsafe b P Ps} :
- (b = b → Ps T) → (P → T).
-Proof. move => ?. apply Himpl. eauto. Qed.
-Lemma apply_simpl_and b P Ps T {Himpl: SimplAndUnsafe b P Ps} :
- (b = b → Ps T) → (P ∧ T).
-Proof. move => ?. apply Himpl. eauto. Qed.
diff --git a/theories/lithium/simpl_instances.v b/theories/lithium/simpl_instances.v
index e6df64252e846264f0c141235648c6d0d7fba470..65edf52aa53499bfb3de549205a962293349256d 100644
--- a/theories/lithium/simpl_instances.v
+++ b/theories/lithium/simpl_instances.v
@@ -1,4 +1,8 @@
-From lithium Require Import base simpl_classes infrastructure.
+From lithium Require Export base.
+From lithium Require Import simpl_classes pure_definitions.
+
+(** This file provides the instances for the simplification
+infrastructure for pure sideconditions. *)
Local Open Scope Z_scope.
@@ -6,7 +10,7 @@ Local Open Scope Z_scope.
(* Global Instance simpl_exist_impl A P : SimplImpl true (@ex A P) (λ T, ∀ x, P x → T). *)
(* Proof. split; try naive_solver. intros ?[??]. eauto. Qed. *)
Global Instance simpl_exist_and A P : SimplAnd (@ex A P) (λ T, ∃ x, P x ∧ T).
-Proof. split. naive_solver. intros [[??]?]. eauto. Qed.
+Proof. split; [naive_solver|]. intros [[??]?]. eauto. Qed.
Global Instance simpl_and_and (P1 P2 : Prop):
SimplAnd (P1 ∧ P2) (λ T, P1 ∧ P2 ∧ T).
Proof. split; naive_solver. Qed.
@@ -325,23 +329,22 @@ it if f goes into type. Thus we use the AssumeInj typeclass such that
the user can mark functions which are morally injective, but one
cannot prove it. *)
Global Instance simpl_fmap_fmap_subequiv_Unsafe {A B} (l1 l2 : list A) ig (f : A → B) `{!AssumeInj (=) (=) f}:
- SimplAndUnsafe true (list_subequiv ig (f <$> l1) (f <$> l2)) (λ T, list_subequiv ig l1 l2 ∧ T).
+ SimplAndUnsafe (list_subequiv ig (f <$> l1) (f <$> l2)) (λ T, list_subequiv ig l1 l2 ∧ T).
Proof. move => ? [Hs ?]. split => //. by apply: list_subequiv_fmap. Qed.
(* The other direction might not hold if ig contains indices which are
out of bounds, but we don't care about that. *)
Global Instance simpl_subequiv_protected {A} (l1 l2 : list A) ig `{!IsProtected l2}:
- SimplAndUnsafe true (list_subequiv ig l1 l2) (λ T,
+ SimplAndUnsafe (list_subequiv ig l1 l2) (λ T,
foldr (λ i f, (λ l', ∃ x, f (<[i:=x]> l'))) (λ l', l2 = l' ∧ T) ig l1).
Proof.
(* TODO: add a lemma for list_subequiv such that this unfolding is not necessary anymore. *)
- Local Transparent list_subequiv.
- unfold list_subequiv, IsProtected in * => T. elim: ig l1 l2.
+ unfold_opaque @list_subequiv.
+ unfold IsProtected in * => T. elim: ig l1 l2.
- move => ??/=. move => [??]. naive_solver.
- move => i ig IH l1 l2/= [x /IH [Hi ?]]. split => // i'.
move: (Hi i') => [<- Hlookup]. rewrite insert_length. split => //.
move => Hi'. rewrite -Hlookup ?list_lookup_insert_ne; set_solver.
- Local Opaque list_subequiv.
Qed.
Global Instance simpl_fmap_nil {A B} (l : list A) (f : A → B) : SimplBothRel (=) (f <$> l) [] (l = []).
@@ -363,7 +366,7 @@ Proof.
by rewrite fmap_length take_app drop_app.
Qed.
Global Instance simpl_fmap_assume_inj_Unsafe {A B} (l1 l2 : list A) (f : A → B) `{!AssumeInj (=) (=) f}:
- SimplAndUnsafe true (f <$> l1 = f <$> l2) (λ T, l1 = l2 ∧ T).
+ SimplAndUnsafe (f <$> l1 = f <$> l2) (λ T, l1 = l2 ∧ T).
Proof. move => T [-> ?]. naive_solver. Qed.
Global Instance simpl_replicate_app_and {A} (l1 l2 : list A) x n:
@@ -371,10 +374,10 @@ Global Instance simpl_replicate_app_and {A} (l1 l2 : list A) x n:
Proof.
unfold shelve_hint. split.
- move => [n'[?[?[??]]]]; subst. split => //.
- have ->: (n = n' + (n - n'))%nat by lia. rewrite replicate_plus. do 2 f_equal. lia.
+ have ->: (n = n' + (n - n'))%nat by lia. rewrite replicate_add. do 2 f_equal. lia.
- move => [Hr ?].
have Hn: (n = length l1 + length l2)%nat by rewrite -(replicate_length n x) -app_length Hr.
- move: Hr. rewrite Hn replicate_plus => /app_inj_1[|<- <-]. by rewrite replicate_length.
+ move: Hr. rewrite Hn replicate_add => /app_inj_1[|<- <-]. 1: by rewrite replicate_length.
exists (length l1). repeat split => //.
+ rewrite !replicate_length. lia.
+ rewrite !replicate_length. f_equal. lia.
@@ -491,21 +494,6 @@ Global Instance simpl_and_lookup_lookup_total {A} (l : list A) (i : nat) `{Inhab
SimplBothRel (=) (l !! i) (Some (l !!! i)) (i < length l).
Proof. rewrite /SimplBothRel list_lookup_alt. naive_solver lia. Qed.
-(* TODO: these instances seem broken, typeclass search diverges when it should find them... *)
-Global Instance simpl_lookup_insert_map_eq `{Countable K} `{EqDecision K} {V} (m : gmap K V) i j x x' `{!CanSolve (i = j)} :
- SimplBothRel (=) (<[i := x']> m !! j) (Some x) (x = x').
-Proof.
- unfold SimplBothRel, CanSolve in *; subst.
- rewrite lookup_insert. naive_solver.
-Qed.
-
-Global Instance simpl_lookup_insert_map_neq `{Countable K} `{EqDecision K} {V} (m : gmap K V) i j x x' `{!CanSolve (i ≠j)} :
- SimplBothRel (=) (<[i := x']> m !! j) (Some x) (m !! j = Some x).
-Proof.
- unfold SimplBothRel, CanSolve in *; subst.
- rewrite lookup_insert_ne; naive_solver.
-Qed.
-
Global Instance simpl_learn_insert_some_len_impl {A} l i (x : A) :
(* The false is important here as we learn additional information,
but don't want to get stuck in an endless loop. *)
@@ -541,12 +529,12 @@ Proof. unfold SimplBothRel. by rewrite lookup_rotate_r_Some. Qed.
But one should not use rotate nat in this case.
TODO: use CanSolve when it is able to prove base < len for slot_for_key_ref key len *)
Global Instance simpl_rotate_nat_add_0_Unsafe base offset len:
- SimplAndUnsafe true (base = rotate_nat_add base offset len) (λ T, (base < len)%nat ∧ offset = 0%nat ∧ T).
+ SimplAndUnsafe (base = rotate_nat_add base offset len) (λ T, (base < len)%nat ∧ offset = 0%nat ∧ T).
Proof. move => T [? [-> ?]]. rewrite rotate_nat_add_0 //. Qed.
Global Instance simpl_rotate_nat_add_next_Unsafe (base offset1 offset2 len : nat) `{!CanSolve (0 < len)%nat}:
- SimplAndUnsafe true ((rotate_nat_add base offset1 len + 1) `rem` len = rotate_nat_add base offset2 len) (λ T, offset2 = S offset1 ∧ T).
+ SimplAndUnsafe ((rotate_nat_add base offset1 len + 1) `rem` len = rotate_nat_add base offset2 len) (λ T, offset2 = S offset1 ∧ T).
Proof.
- unfold CanSolve in * => ? -[-> ?]. split => //. rewrite rotate_nat_add_S // Nat2Z_inj_mod.
+ unfold CanSolve in * => ? -[-> ?]. split => //. rewrite rotate_nat_add_S // Nat2Z.inj_mod.
rewrite Z.rem_mod_nonneg //=; lia.
Qed.
diff --git a/theories/lithium/solvers.v b/theories/lithium/solvers.v
index b649d8727e9c2eb54d622067dc88c11a7e9875d4..48e430f60100d70aae5974a9862419155c1186a1 100644
--- a/theories/lithium/solvers.v
+++ b/theories/lithium/solvers.v
@@ -1,4 +1,7 @@
-From lithium Require Import base tactics_extend simpl_classes infrastructure.
+From lithium Require Export base.
+From lithium Require Import hooks simpl_classes pure_definitions normalize.
+
+(** This file provides various pure solvers. *)
(** * [refined_solver]
Version of naive_solver which fails faster. *)
@@ -59,6 +62,50 @@ Tactic Notation "refined_solver" tactic(tac) :=
Tactic Notation "refined_solver" := refined_solver eauto.
(** * [normalize_and_simpl_goal] *)
+Ltac normalize_and_simpl_impl handle_exist :=
+ let do_intro :=
+ idtac;
+ match goal with
+ | |- (∃ _, _) → _ =>
+ lazymatch handle_exist with
+ | true => case
+ | false => fail 1 "exist not handled"
+ end
+ | |- (_ = _) → _ =>
+ check_injection_hook;
+ let Hi := fresh "Hi" in move => Hi; injection Hi; clear Hi
+ | |- ?P → _ => assert_is_not_trivial P; intros ?; subst
+ | |- _ => move => _
+ end;
+ after_intro_hook
+ in
+ lazymatch goal with
+ (* relying on the fact that unification variables cannot contain
+ dependent variables to distinguish between dependent and non
+ dependent forall *)
+ | |- ?P -> ?Q =>
+ lazymatch type of P with
+ | Prop => first [
+ (* first check if the hyp is trivial *)
+ assert_is_trivial P; intros _
+ | progress normalize_goal_impl
+ | let changed := open_constr:(_) in
+ notypeclasses refine (@simpl_impl_unsafe changed P _ _ Q _); [solve [refine _] |];
+ (* We need to simpl here to make sure that we only introduce
+ fully simpl'd terms into the context (and do beta reduction
+ for the lemma application above). *)
+ simpl;
+ lazymatch changed with
+ | true => idtac
+ | false => do_intro
+ end
+ | do_intro
+ ]
+ (* just some unused variable, forget it *)
+ | _ => move => _
+ end
+ end.
+
Lemma intro_and_True P :
(P ∧ True) → P.
Proof. naive_solver. Qed.
@@ -80,41 +127,23 @@ Ltac normalize_and_simpl_goal_step :=
| |- _ ∧ _ => idtac
| _ => refine (intro_and_True _ _)
end;
- refine (apply_simpl_and _ _ _ _ _);
lazymatch goal with
- | |- true = true → _ => move => _; split_and?
+ | |- ?P ∧ ?Q =>
+ notypeclasses refine (@simpl_and_unsafe P _ _ Q _); [solve [refine _] |];
+ simpl;
+ split_and?
end
- |
- lazymatch goal with
+ | lazymatch goal with
(* relying on the fact that unification variables cannot contain
dependent variables to distinguish between dependent and non dependent forall *)
- | |- ?P -> ?Q =>
- lazymatch type of P with
- | Prop => first [
- assert_is_trivial P; intros _ |
- progress normalize_goal_impl |
- notypeclasses refine (apply_simpl_impl _ _ _ _ _); [ solve [refine _] |]; simpl;
- match goal with
- | |- true = true -> _ => move => _
- | |- false = false -> ?P → _ => move => _;
- match P with
- | ∃ _, _ => case
- | _ = _ =>
- check_injection_tac;
- let Hi := fresh "Hi" in move => Hi; injection Hi; clear Hi
- | _ => assert_is_not_trivial P; intros ?; subst
- | _ => move => _
- end
- end]
- (* just some unused variable, forget it *)
- | _ => move => _
- end
- | |- forall _ : ?P, _ =>
- lazymatch P with
- | (prod _ _) => case
- | unit => case
- | _ => intro
- end
+ | |- ?P -> ?Q =>
+ normalize_and_simpl_impl true
+ | |- forall _ : ?P, _ =>
+ lazymatch P with
+ | (prod _ _) => case
+ | unit => case
+ | _ => intro
+ end
end ].
Ltac normalize_and_simpl_goal := repeat normalize_and_simpl_goal_step.
@@ -156,47 +185,38 @@ Ltac enrich_context_base :=
pose proof (filter_length P l)
end.
-Ltac enrich_context_tac :=
- enrich_context_base.
-
Ltac enrich_context :=
- enrich_context_tac;
+ enrich_context_base;
+ enrich_context_hook;
unfold enrich_marker.
-(* Open Scope Z_scope. *)
-(* Goal ∀ n m, 0 < n → 1 < m → n `quot` m = n `rem` m. *)
- (* move => n m ??. enrich_context. *)
-(* Abort. *)
+Section enrich_test.
+ Local Open Scope Z_scope.
+ Goal ∀ n m, 0 < n → 1 < m → n `quot` m = n `rem` m.
+ move => n m ??. enrich_context.
+ Abort.
+End enrich_test.
(** * [solve_goal] *)
-Ltac solve_goal_prepare_tac := idtac.
-Ltac solve_goal_normalized_prepare_tac := idtac.
-
-Local Open Scope Z_scope.
-Ltac reduce_closed_Z_tac := idtac.
Ltac reduce_closed_Z :=
idtac;
- reduce_closed_Z_tac;
+ reduce_closed_Z_hook;
repeat match goal with
- | |- context [?a ≪ ?b] => progress reduce_closed (a ≪ b)
- | H : context [?a ≪ ?b] |- _ => progress reduce_closed (a ≪ b)
- | |- context [?a ≫ ?b] => progress reduce_closed (a ≫ b)
- | H : context [?a ≫ ?b] |- _ => progress reduce_closed (a ≫ b)
+ | |- context [(?a ≪ ?b)%Z] => progress reduce_closed (a ≪ b)%Z
+ | H : context [(?a ≪ ?b)%Z] |- _ => progress reduce_closed (a ≪ b)%Z
+ | |- context [(?a ≫ ?b)%Z] => progress reduce_closed (a ≫ b)%Z
+ | H : context [(?a ≫ ?b)%Z] |- _ => progress reduce_closed (a ≫ b)%Z
end.
Tactic Notation "solve_goal" "with" tactic(tac) :=
simpl;
try fast_done;
- solve_goal_prepare_tac;
+ solve_goal_prepare_hook;
normalize_and_simpl_goal;
- solve_goal_normalized_prepare_tac; reduce_closed_Z; enrich_context;
+ solve_goal_normalized_prepare_hook; reduce_closed_Z; enrich_context;
repeat case_bool_decide => //; repeat case_decide => //; repeat case_match => //;
tac.
+Tactic Notation "solve_goal" :=
+ solve_goal with solve_goal_final_hook.
-(* TODO sometimes this diverges, so we put a timeout on it.
- Should really fix the refined_solver though. *)
-Ltac hammer :=
- first [timeout 4 lia | timeout 4 nia | timeout 4 refined_solver lia].
-Tactic Notation "solve_goal" :=
- solve_goal with hammer.
diff --git a/theories/lithium/syntax.v b/theories/lithium/syntax.v
new file mode 100644
index 0000000000000000000000000000000000000000..50d29df724d1cae937dc641df54f13354d4456ca
--- /dev/null
+++ b/theories/lithium/syntax.v
@@ -0,0 +1,388 @@
+From lithium Require Export base.
+From lithium Require Import definitions hooks.
+
+Import environments.
+
+Module li.
+Section lithium.
+ Context {Σ : gFunctors}.
+
+ (* Alternative names: prove, assert, consume *)
+ Definition exhale (P T : iProp Σ) : iProp Σ :=
+ P ∗ T.
+ (* Alternative names: intro, assume, produce *)
+ Definition inhale (P T : iProp Σ) : iProp Σ :=
+ P -∗ T.
+
+ Definition all {A} : (A → iProp Σ) → iProp Σ :=
+ bi_forall.
+ Definition exist {A} : (A → iProp Σ) → iProp Σ :=
+ bi_exist.
+
+ Definition done : iProp Σ := True.
+ Definition false : iProp Σ := False.
+
+ Definition and : iProp Σ → iProp Σ → iProp Σ :=
+ bi_and.
+ Definition and_map {K A} `{!EqDecision K} `{!Countable K}
+ (m : gmap K A) (Φ : K → A → iProp Σ) : iProp Σ :=
+ big_opM bi_and Φ m.
+
+ Definition find_in_context : ∀ fic : find_in_context_info, (fic.(fic_A) → iProp Σ) → iProp Σ :=
+ find_in_context.
+
+ Definition case_if : Prop → iProp Σ → iProp Σ → iProp Σ :=
+ case_if.
+ Definition case_destruct {A} : A → (A → bool → iProp Σ) → iProp Σ :=
+ @case_destruct Σ A.
+
+ Definition drop_spatial : iProp Σ → iProp Σ :=
+ bi_intuitionistically.
+
+ Definition tactic {A} : ((A → iProp Σ) → iProp Σ) → (A → iProp Σ) → iProp Σ :=
+ @li_tactic Σ A.
+
+ Definition accu : (iProp Σ → iProp Σ) → iProp Σ :=
+ accu.
+
+ Definition trace {A} : A → iProp Σ → iProp Σ :=
+ @li_trace Σ A.
+
+ Definition subsume : iProp Σ → iProp Σ → iProp Σ → iProp Σ :=
+ subsume.
+ (* TODO: Should we also have a syntax for subsume list? *)
+
+ Definition ret (T : iProp Σ) : iProp Σ := T.
+ Definition iterate [A B] : (B → A → A) → A → list B → A :=
+ @foldr A B.
+
+ Definition bind0 (P : iProp Σ → iProp Σ) (T : iProp Σ) : iProp Σ := P T.
+ Definition bind1 {A1} (P : (A1 → iProp Σ) → iProp Σ) (T : A1 → iProp Σ) : iProp Σ := P T.
+ Definition bind2 {A1 A2} (P : (A1 → A2 → iProp Σ) → iProp Σ) (T : A1 → A2 → iProp Σ) : iProp Σ := P T.
+ Definition bind3 {A1 A2 A3} (P : (A1 → A2 → A3 → iProp Σ) → iProp Σ) (T : A1 → A2 → A3 → iProp Σ) : iProp Σ := P T.
+ Definition bind4 {A1 A2 A3 A4} (P : (A1 → A2 → A3 → A4 → iProp Σ) → iProp Σ) (T : A1 → A2 → A3 → A4 → iProp Σ) : iProp Σ := P T.
+ Definition bind5 {A1 A2 A3 A4 A5} (P : (A1 → A2 → A3 → A4 → A5 → iProp Σ) → iProp Σ) (T : A1 → A2 → A3 → A4 → A5 → iProp Σ) : iProp Σ := P T.
+End lithium.
+End li.
+
+Declare Scope lithium_scope.
+Delimit Scope lithium_scope with LI.
+Global Open Scope lithium_scope.
+
+Declare Custom Entry lithium.
+
+(* notation principle: notations that look like an application (e.g.
+return or inhale) don't have a colon after the name. More fancy
+notations have a colon after the first identifiers (e.g. pattern:).
+This might also be necessary to avoid registering keywords.*)
+Notation "'[{' e } ]" := e
+ (e custom lithium at level 200,
+ format "'[hv' [{ '[hv' e ']' '/' } ] ']'") : lithium_scope.
+Notation "{ x }" := x (in custom lithium, x constr).
+
+Notation "'inhale' x" := (li.inhale x) (in custom lithium at level 0, x constr,
+ format "'inhale' '[' x ']'") : lithium_scope.
+Notation "'exhale' x" := (li.exhale x) (in custom lithium at level 0, x constr,
+ format "'exhale' '[' x ']'") : lithium_scope.
+
+Notation "∀ x .. y , P" := (li.all (λ x, .. (li.all (λ y, P)) ..))
+ (in custom lithium at level 100, x binder, y binder, P at level 100, right associativity,
+ format "'[' ∀ x .. y , ']' '/' P") : lithium_scope.
+Notation "∃ x .. y , P" := (li.exist (λ x, .. (li.exist (λ y, P)) ..))
+ (in custom lithium at level 100, x binder, y binder, P at level 100, right associativity,
+ format "'[' ∃ x .. y , ']' '/' P") : lithium_scope.
+
+Notation "'done'" := (li.done) (in custom lithium at level 0) : lithium_scope.
+Notation "'false'" := (li.false) (in custom lithium at level 0) : lithium_scope.
+
+(* Making this a recursive notation is tricky because it is not clear,
+where the and: would end, see
+https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/Problem.20with.20right.20associative.20recursive.20notation/near/365455519 *)
+Notation "'and:' | x | y" := (li.and x y)
+ (in custom lithium at level 100, x at level 100, y at level 100,
+ format "'[hv' and: '/' | '[hv' x ']' '/' | '[hv' y ']' ']'") : lithium_scope.
+(* Notation "'and_map:' m | k v , P" := (li.and_map (λ k v, P) m) *)
+ (* (in custom lithium at level 100, k binder, v binder, m constr, P at level 100, *)
+ (* format "'[hv' 'and_map:' m '/' | k v , '[hv' P ']' ']'") : lithium_scope. *)
+Notation "'and_map' x" := (li.and_map x) (in custom lithium at level 0, x constr,
+ format "'and_map' '[' x ']'") : lithium_scope.
+
+Notation "'find_in_context' x" := (li.find_in_context x) (in custom lithium at level 0, x constr,
+ format "'find_in_context' '[' x ']'") : lithium_scope.
+
+Notation "'if:' P | G1 | G2" := (li.case_if P G1 G2)
+ (in custom lithium at level 100, P constr, G1, G2 at level 100,
+ format "'[hv' 'if:' P '/' | '[hv' G1 ']' '/' | '[hv' G2 ']' ']'") : lithium_scope.
+Notation "'destruct' x" := (li.case_destruct x) (in custom lithium at level 0, x constr,
+ format "'destruct' '[' x ']'") : lithium_scope.
+
+Notation "'drop_spatial'" := (li.drop_spatial) (in custom lithium at level 0) : lithium_scope.
+
+Notation "'tactic' x" := (li.tactic x) (in custom lithium at level 0, x constr,
+ format "'tactic' '[' x ']'") : lithium_scope.
+
+Notation "'accu'" := (li.accu) (in custom lithium at level 0) : lithium_scope.
+
+Notation "'trace' x" := (li.trace x) (in custom lithium at level 0, x constr,
+ format "'trace' '[' x ']'") : lithium_scope.
+
+Notation "x :> y" := (li.subsume x y) (in custom lithium at level 0, x constr, y constr,
+ format "'[' x ']' :> '[' y ']'") : lithium_scope.
+
+Notation "'return' x" := (li.ret x) (in custom lithium at level 0, x constr,
+ format "'return' '[' x ']'") : lithium_scope.
+(* TODO: figure out if it makes sense to handle this to liToSyntax *)
+Notation "'iterate:' l '{{' x T , P } }" :=
+ (λ T, li.iterate (λ x T, P) T l)
+ (in custom lithium at level 0, l constr, x binder, T binder, P at level 100,
+ format "'[hv ' 'iterate:' l '{{' x T , '/' P } } ']'") : lithium_scope.
+Notation "'iterate:' l 'with' a1 '{{' x T x1 , P } }" :=
+ (λ T, li.iterate (λ x T x1, P) T l a1)
+ (in custom lithium at level 0, l constr, a1 constr, x binder, T binder, x1 binder,
+ P at level 100,
+ format "'[hv ' 'iterate:' l 'with' a1 '{{' x T x1 , '/' P } } ']'") : lithium_scope.
+Notation "'iterate:' l 'with' a1 , a2 '{{' x T x1 x2 , P } }" :=
+ (λ T, li.iterate (λ x T x1 x2, P) T l a1 a2)
+ (in custom lithium at level 0, l constr, a1 constr, a2 constr, x binder, T binder,
+ x1 binder, x2 binder, P at level 100,
+ format "'[hv ' 'iterate:' l 'with' a1 , a2 '{{' x T x1 x2 , '/' P } } ']'") : lithium_scope.
+Notation "'iterate:' l 'with' a1 , a2 , a3 '{{' x T x1 x2 x3 , P } }" :=
+ (λ T, li.iterate (λ x T x1 x2 x3, P) T l a1 a2 a3)
+ (in custom lithium at level 0, l constr, a1 constr, a2 constr, a3 constr, x binder, T binder,
+ x1 binder, x2 binder, x3 binder, P at level 100,
+ format "'[hv ' 'iterate:' l 'with' a1 , a2 , a3 '{{' x T x1 x2 x3 , '/' P } } ']'") : lithium_scope.
+
+
+Notation "y ; z" := (li.bind0 y z)
+ (in custom lithium at level 100, z at level 100,
+ format "y ; '/' z") : lithium_scope.
+Notation "x ↠y ; z" := (li.bind1 y (λ x : _, z))
+ (in custom lithium at level 0, x name, y at level 99, z at level 100,
+ format "x ↠y ; '/' z") : lithium_scope.
+Notation "' x ↠y ; z" := (li.bind1 y (λ x : _, z))
+ (in custom lithium at level 0, x strict pattern, y at level 99, z at level 100,
+ format "' x ↠y ; '/' z") : lithium_scope.
+Notation "x1 , x2 ↠y ; z" := (li.bind2 y (λ x1 x2 : _, z))
+ (in custom lithium at level 0, y at level 99, z at level 100, x1 name, x2 name,
+ format "x1 , x2 ↠y ; '/' z") : lithium_scope.
+Notation "x1 , ' x2 ↠y ; z" := (li.bind2 y (λ x1 x2 : _, z))
+ (in custom lithium at level 0, y at level 99, z at level 100, x1 name, x2 strict pattern,
+ format "x1 , ' x2 ↠y ; '/' z") : lithium_scope.
+Notation "x1 , x2 , x3 ↠y ; z" := (li.bind3 y (λ x1 x2 x3 : _, z))
+ (in custom lithium at level 0, y at level 99, z at level 100, x1 name, x2 name, x3 name,
+ format "x1 , x2 , x3 ↠y ; '/' z") : lithium_scope.
+Notation "x1 , x2 , x3 , x4 ↠y ; z" := (li.bind4 y (λ x1 x2 x3 x4 : _, z))
+ (in custom lithium at level 0, y at level 99, z at level 100, x1 name, x2 name, x3 name, x4 name,
+ format "x1 , x2 , x3 , x4 ↠y ; '/' z") : lithium_scope.
+Notation "x1 , x2 , x3 , x4 , x5 ↠y ; z" := (li.bind5 y (λ x1 x2 x3 x4 x5 : _, z))
+ (in custom lithium at level 0, y at level 99, z at level 100, x1 name, x2 name, x3 name, x4 name, x5 name,
+ format "x1 , x2 , x3 , x4 , x5 ↠y ; '/' z") : lithium_scope.
+
+Notation "P 'where' x1 .. xn ':-' Q" := (∀ x1, .. (∀ xn, Q ⊢ P) ..)
+ (at level 99, Q custom lithium at level 100, x1 binder, xn binder, only parsing) : stdpp_scope.
+Notation "P ':-' Q" := (Q ⊢ P)
+ (at level 99, Q custom lithium at level 100, only parsing) : stdpp_scope.
+
+(* for find_in_context: *)
+Notation "'pattern:' x .. y , P ; G" :=
+ (li.exist (λ x, .. (li.exist (λ y, li.bind0 (li.exhale P) G)) .. ))
+ (in custom lithium at level 100, x binder, y binder, P constr, G at level 100, only parsing) : lithium_scope.
+
+Declare Reduction liFromSyntax_eval :=
+ cbv [ li.exhale li.inhale li.all li.exist li.done li.false li.and li.and_map
+ li.find_in_context li.case_if li.case_destruct li.drop_spatial li.tactic
+ li.accu li.trace li.subsume li.ret li.iterate
+ li.bind0 li.bind1 li.bind2 li.bind3 li.bind4 li.bind5 ].
+
+Ltac liFromSyntaxTerm c :=
+ eval liFromSyntax_eval in c.
+
+Ltac liFromSyntax :=
+ match goal with
+ | |- ?P =>
+ let Q := liFromSyntaxTerm P in
+ change (Q)
+ end.
+
+Ltac liFromSyntaxGoal :=
+ match goal with
+ | |- @envs_entails ?PROP ?Δ ?P =>
+ let Q := liFromSyntaxTerm P in
+ change (envs_entails Δ Q)
+ end.
+
+Notation "'[type_from_syntax' x ]" :=
+ ltac:(let t := type of x in let t := liFromSyntaxTerm t in exact t) (only parsing).
+
+Definition liToSyntax_UNFOLD_MARKER {A} (x : A) : A := x.
+(* This tactic heurisitically converts the goal to the Lithium syntax.
+It is not perfect as it might convert occurences to Lithium syntax
+that should stay in Iris syntax, so it should only be used for
+debugging and pretty printing.
+TODO: Build a proper version using Ltac2, see
+https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/Controlling.20printing.20of.20patters.20in.20binders/near/363637321
+ *)
+Ltac liToSyntax :=
+ liFromSyntax; (* make sure that we are not adding things twice, especially around user-defined functions *)
+ liToSyntax_hook;
+ change (bi_sep ?a) with (li.bind0 (li.exhale (liToSyntax_UNFOLD_MARKER a)));
+ change (bi_wand ?a) with (li.bind0 (li.inhale (liToSyntax_UNFOLD_MARKER a)));
+ change (@bi_forall (iPropI ?Σ) ?A) with (@li.all Σ A);
+ change (@bi_exist (iPropI ?Σ) ?A) with (@li.exist Σ A);
+ change (@bi_pure (iPropI ?Σ) True) with (@li.done Σ);
+ change (@bi_pure (iPropI ?Σ) False) with (@li.false Σ);
+ repeat (progress change (big_opM bi_and ?f ?m) with (li.bind2 (li.and_map m) f));
+ change (@bi_and (iPropI ?Σ)) with (@li.and Σ);
+ change (find_in_context ?a) with (li.bind1 (li.find_in_context a));
+ change (@case_if ?Σ ?P) with (@li.case_if Σ P);
+ change (@case_destruct ?Σ ?A ?a) with (li.bind2 (@li.case_destruct Σ A a));
+ change (@bi_intuitionistically (iPropI ?Σ)) with (li.bind0 (@li.drop_spatial Σ));
+ change (li_tactic ?t) with (li.bind1 (li.tactic t));
+ change (@accu ?Σ) with (li.bind1 (@li.accu Σ));
+ change (@li_trace ?Σ ?A ?t) with (li.bind0 (@li.trace Σ A t));
+ change (subsume ?a ?b) with (li.bind0 (li.subsume (liToSyntax_UNFOLD_MARKER a) (liToSyntax_UNFOLD_MARKER b)));
+ change (subsume_list ?A ?ig ?l1 ?l2 ?f) with (li.bind0 (subsume_list A ig l1 l2 f));
+ (* Try to at least unfold some spurious conversions. *)
+ repeat (first [
+ progress change (liToSyntax_UNFOLD_MARKER (li.bind0 (@li.exhale ?Σ ?a) ?b))
+ with (a ∗ liToSyntax_UNFOLD_MARKER b)%I
+ | progress change (liToSyntax_UNFOLD_MARKER (li.bind0 (@li.drop_spatial ?Σ) ?b))
+ with (â–¡ liToSyntax_UNFOLD_MARKER b)%I ]);
+ change (liToSyntax_UNFOLD_MARKER (@li.done ?Σ)) with (@bi_pure (iPropI Σ) True);
+ change (liToSyntax_UNFOLD_MARKER (@li.false ?Σ)) with (@bi_pure (iPropI Σ) False);
+ unfold liToSyntax_UNFOLD_MARKER.
+
+Ltac liToSyntaxGoal :=
+ iEval ( liToSyntax ).
+
+(* The following looses the printing of patterns and is extremely slow
+when going under many binders (e.g. typed_place). *)
+(*
+Ltac to_li c :=
+ lazymatch c with
+ | bi_sep ?P ?G =>
+ refine (li.bind0 (li.exhale P) _);
+ to_li G
+ | bi_wand ?P ?G =>
+ refine (li.bind0 (li.inhale P) _);
+ to_li G
+ | @bi_forall _ ?A (fun x => @?G x) =>
+ refine (@li.all _ A (λ x, _));
+ let y := eval lazy beta in (G x) in
+ to_li y
+ | @bi_exist _ ?A (fun x => @?G x) =>
+ refine (@li.exist _ A (λ x, _));
+ let y := eval lazy beta in (G x) in
+ to_li y
+ | @bi_exist _ ?A (fun x => @?G x) =>
+ refine (@li.exist _ A (λ x, _));
+ let y := eval lazy beta in (G x) in
+ to_li y
+ | True%I => refine (li.done)
+ | ?P (fun x => @?G x) =>
+ (* idtac x; *)
+ refine (li.bind1 P (λ x, _));
+ let y := eval lazy beta in (G x) in
+ (* idtac y; *)
+ to_li y
+ | match ?x with | (a, b) => @?G a b end =>
+ refine (match x with | (a, b) => _ end);
+ let y := eval lazy beta in (G a b) in
+ (* idtac y; *)
+ to_li y
+ | ?G =>
+ refine (G)
+ end.
+
+Ltac goal_to_li :=
+ match goal with
+ | |- @envs_entails ?PROP ?Δ ?P =>
+ let x := fresh in
+ unshelve evar (x : bi_car PROP); [to_li P|];
+ change (envs_entails Δ x); unfold x; clear x
+ end.
+*)
+
+Module li_test.
+Section test.
+
+ Context {Σ : gFunctors}.
+ Parameter check_wp : ∀ (e : Z) (T : Z → iProp Σ), iProp Σ.
+ Parameter get_tuple : ∀ (T : (Z * Z * Z) → iProp Σ), iProp Σ.
+
+ Local Ltac liToSyntax_hook ::=
+ change (check_wp ?x) with (li.bind1 (check_wp x));
+ change (get_tuple) with (li.bind1 (get_tuple)).
+
+ Lemma ex1_1 :
+ ⊢ get_tuple (λ '(x1, x2, x3), ⌜x1 = 0⌠∗ subsume False False True).
+ Proof.
+ iStartProof.
+ (* Important: '(...) syntax should be preserved *)
+ liToSyntax.
+ liFromSyntax.
+ Abort.
+
+ Lemma ex1_1 :
+ ⊢ [{ '(x1, x2, x3) ↠{get_tuple}; exhale ⌜x1 = 0âŒ; done }].
+ Proof.
+ iStartProof.
+ liFromSyntax.
+ Abort.
+
+ Lemma ex1_3 :
+ ⊢ ∀ n1 n2, (⌜n1 + Z.to_nat n2 > 0⌠∗ ⌜n2 = 1âŒ) -∗
+ check_wp (n1 + 1) (λ v,
+ ∃ n' : nat, (⌜v = n'⌠∗ ⌜n' > 0âŒ) ∗ li_trace 1 $ accu (λ P,
+ find_in_context (FindDirect (λ '(n, m), ⌜n =@{Z} mâŒ)) (λ '(n, m), ⌜n = m⌠∗
+ get_tuple (λ '(x1, x2, x3), □ ⌜x1 = 0⌠∗ (P ∧
+ □ [∧ map] a↦'(b1, b2)∈{[1 := (1, 1)]}, ⌜a = b1⌠∗
+ case_if (n' = 1) (case_destruct n' (λ n'' b,
+ ⌜b = b⌠∗ ⌜n'' = 0⌠∗ subsume True True (True ∗ True ∗ True ∗ True ∗ True ∗ True))) False))))).
+ Proof.
+ iStartProof.
+ liToSyntax.
+ liFromSyntax.
+ Abort.
+
+ Lemma iterate0 ls :
+ ⊢@{iProp Σ} [{ iterate: ls {{x T,
+ exhale ⌜x = 1âŒ;
+ return T}};
+ exhale ⌜[] = lsâŒ;
+ done}].
+ Proof. Abort.
+
+ Lemma iterate1 (ls : list Z) :
+ ⊢@{iProp Σ} [{ a ↠iterate: ls with [] {{x T a,
+ exhale ⌜a = []âŒ;
+ exhale ⌜a = []âŒ;
+ exhale ⌜a = []âŒ;
+ return T (a ++ [x])}};
+ exhale ⌜a = lsâŒ;
+ done}].
+ Proof. Abort.
+
+ Lemma iterate2 (ls : list Z) :
+ ⊢@{iProp Σ} [{ a, b ↠iterate: ls with [], [] {{x T a b,
+ exhale ⌜a = bâŒ;
+ exhale ⌜a = []âŒ;
+ exhale ⌜a = []âŒ;
+ return T (a ++ [x]) (b ++ [x])}};
+ exhale ⌜a = lsâŒ;
+ done}].
+ Proof. Abort.
+
+ Lemma iterate3 (ls : list Z) :
+ ⊢@{iProp Σ} [{ a, b, c ↠iterate: ls with [], [], [] {{x T a b c,
+ exhale ⌜a = bâŒ;
+ exhale ⌜a = câŒ;
+ exhale ⌜a = []âŒ;
+ return T (a ++ [x]) (b ++ [x]) (c ++ [x])}};
+ exhale ⌜a = lsâŒ;
+ exhale ⌜a = bâŒ;
+ done}].
+ Proof. Abort.
+
+End test.
+End li_test.
diff --git a/theories/lithium/tactics.v b/theories/lithium/tactics.v
deleted file mode 100644
index bc222954adff345f55a0b9001c9e8b593f1ec2ad..0000000000000000000000000000000000000000
--- a/theories/lithium/tactics.v
+++ /dev/null
@@ -1 +0,0 @@
-From lithium Require Export infrastructure simpl_classes simpl_instances interpreter tactics_extend normalize solvers Z_bitblast.
diff --git a/theories/lithium/tactics_extend.v b/theories/lithium/tactics_extend.v
deleted file mode 100644
index b8861d731ade08a2403260bd7adfd7317959c004..0000000000000000000000000000000000000000
--- a/theories/lithium/tactics_extend.v
+++ /dev/null
@@ -1,31 +0,0 @@
-From lithium Require Import base infrastructure.
-
-Ltac can_solve_tac := fail "provide a can_solve_tac!".
-Global Hint Extern 10 (CanSolve ?P) => (change P; can_solve_tac) : typeclass_instances.
-
-Ltac sidecond_hook := idtac.
-Ltac unsolved_sidecond_hook := idtac.
-
-(* There can be some goals where one should not call injection on an
-hypothesis that is introduced. The [check_injection_tac] hook is called
-before injection and allows the client to customize this. *)
-Ltac check_injection_tac := idtac.
-
-(** * general normalization infrastructure *)
-Ltac normalize_tac := fail "provide a normalize_tac!".
-Lemma tac_normalize_goal (P1 P2 : Prop):
- P2 = P1 → P1 → P2.
-Proof. by move => ->. Qed.
-Lemma tac_normalize_goal_and (P1 P2 T : Prop):
- P2 = P1 → P1 ∧ T → P2 ∧ T.
-Proof. by move => ->. Qed.
-Lemma tac_normalize_goal_impl (P1 P2 T : Prop):
- P2 = P1 → (P1 → T) → (P2 → T).
-Proof. by move => ->. Qed.
-
-Ltac normalize_goal :=
- notypeclasses refine (tac_normalize_goal _ _ _ _); [normalize_tac|].
-Ltac normalize_goal_and :=
- notypeclasses refine (tac_normalize_goal_and _ _ _ _ _); [normalize_tac|].
-Ltac normalize_goal_impl :=
- notypeclasses refine (tac_normalize_goal_impl _ _ _ _ _); [normalize_tac|].
diff --git a/theories/rust_typing/adequacy.v b/theories/rust_typing/adequacy.v
new file mode 100644
index 0000000000000000000000000000000000000000..882baffb343ae3f439796671885f9a7aec1420b8
--- /dev/null
+++ b/theories/rust_typing/adequacy.v
@@ -0,0 +1,183 @@
+From iris.program_logic Require Export adequacy weakestpre.
+From iris.algebra Require Import csum excl auth cmra_big_op gmap.
+From iris.base_logic.lib Require Import ghost_map.
+From caesium Require Import ghost_state.
+From refinedrust Require Export type.
+From refinedrust Require Import programs functions products.
+From iris.program_logic Require Export language. (* must be last to get the correct nsteps *)
+Set Default Proof Using "Type".
+
+Class typePreG Σ := PreTypeG {
+ type_invG :: invGpreS Σ;
+ type_na_invG :: na_invG Σ;
+ type_lftG :: lftGpreS Σ;
+ type_frac_borrowG :: frac_borG Σ;
+ type_lctxG :: lctxGPreS Σ;
+ type_ghost_varG :: ghost_varG Σ RT;
+ type_pinnedBorG :: pinnedBorG Σ;
+ type_timeG :: timeGpreS Σ;
+ type_heap_heap_inG :: inG Σ (authR heapUR);
+ type_heap_alloc_meta_map_inG :: ghost_mapG Σ alloc_id (Z * nat * alloc_kind);
+ type_heap_alloc_alive_map_inG :: ghost_mapG Σ alloc_id bool;
+ type_heap_fntbl_inG :: ghost_mapG Σ addr function;
+}.
+
+Definition typeΣ : gFunctors :=
+ #[invΣ;
+ na_invΣ;
+ lftΣ;
+ GFunctor (constRF fracR);
+ lctxΣ;
+ ghost_varΣ RT;
+ pinnedBorΣ;
+ timeΣ;
+ GFunctor (constRF (authR heapUR));
+ ghost_mapΣ alloc_id (Z * nat * alloc_kind);
+ ghost_mapΣ alloc_id bool;
+ ghost_mapΣ addr function].
+Global Instance subG_typePreG {Σ} : subG typeΣ Σ → typePreG Σ.
+Proof. solve_inG. Qed.
+
+Definition initial_prog (main : loc) : runtime_expr :=
+ coerce_rtexpr (Call main []).
+
+Definition initial_heap_state :=
+ {| hs_heap := ∅; hs_allocs := ∅; |}.
+
+Definition initial_state (fns : gmap addr function) :=
+ {| st_heap := initial_heap_state; st_fntbl := fns; |}.
+
+Definition main_type `{!typeGS Σ} (P : iProp Σ) :=
+ fn(∀ () : 0 | () : (), λ Ï, []; λ Ï€, P) → ∃ () : (), () @ unit_t; λ Ï€, True.
+
+(** * The main adequacy lemma *)
+Lemma refinedrust_adequacy Σ `{!typePreG Σ} `{ALG : LayoutAlg} (thread_mains : list loc) (fns : gmap addr function) n t2 σ2 obs σ:
+ σ = {| st_heap := initial_heap_state; st_fntbl := fns; |} →
+ (* show that the main functions for the individual threads are well-typed for a provable precondition [P] *)
+ (∀ {HtypeG : typeGS Σ},
+ ([∗ map] k↦qs∈fns, fntbl_entry (fn_loc k) qs) ={⊤}=∗
+ [∗ list] main ∈ thread_mains, ∀ Ï€, ∃ P, main â—áµ¥{Ï€} main @ function_ptr [] (main_type P) ∗ P) →
+ (* if the whole thread pool steps for [n] steps *)
+ nsteps (Λ := c_lang) n (initial_prog <$> thread_mains, σ) obs (t2, σ2) →
+ (* then it has not gotten stuck *)
+ ∀ e2, e2 ∈ t2 → not_stuck e2 σ2.
+Proof.
+ move => -> Hwp. apply: wp_strong_adequacy. move => ?.
+ (* heap/Caesium stuff *)
+ set h := to_heapUR ∅.
+ iMod (own_alloc (◠h ⋅ ◯ h)) as (γh) "[Hh _]" => //.
+ { apply auth_both_valid_discrete. split => //. }
+ iMod (ghost_map_alloc fns) as (γf) "[Hf Hfm]".
+ iMod (ghost_map_alloc_empty (V:=(Z * nat * alloc_kind))) as (γr) "Hr".
+ iMod (ghost_map_alloc_empty (V:=bool)) as (γs) "Hs".
+ set (HheapG := HeapG _ _ γh _ γr _ γs _ γf).
+
+ (* time credits *)
+ iMod (time_init) as "(%Htime & #TIME & Htime)"; first done.
+ iMod (own_alloc (i:=(@time_nat_inG Σ Htime)) (◠0 ⋅ ◯ 0)) as (γdis) "[Hdis _]" => //.
+ { apply auth_both_valid_discrete. split => //. }
+ set (HrefinedCG := RefinedCG _ _ HheapG Htime γdis).
+ iMod (additive_time_receipt_0) as "Hat".
+
+ (* lifetime logic stuff *)
+ iMod (lft_init _ lft_userE) as "(%Hlft & #LFT)"; [solve_ndisj.. | ].
+ iMod (lctx_init) as "(%Hlctx & #LCTX & _)"; [solve_ndisj.. | ].
+
+ set (HtypeG := TypeG _ HrefinedCG Hlft _ _ Hlctx _ _ ALG).
+ move: (Hwp HtypeG) => {Hwp}.
+ move => Hwp.
+ iAssert (|==> [∗ map] k↦qs ∈ fns, fntbl_entry (fn_loc k) qs)%I with "[Hfm]" as ">Hfm". {
+ iApply big_sepM_bupd. iApply (big_sepM_impl with "Hfm").
+ iIntros "!>" (???) "Hm". rewrite fntbl_entry_eq.
+ iExists _. iSplitR; [done|]. by iApply ghost_map_elem_persist.
+ }
+ iMod (Hwp with "Hfm") as "Hmains".
+
+ iModIntro. iExists _, (replicate (length thread_mains) (λ _, True%I)), _, _.
+ iSplitL "Hh Hf Hr Hs Htime Hdis Hat"; last first. 1: iSplitL "Hmains".
+ - rewrite big_sepL2_fmap_l. iApply big_sepL2_replicate_r; [done|]. iApply (big_sepL_impl with "Hmains").
+ iIntros "!#" (? main ?) "Hfn".
+ iMod (na_alloc) as "(%Ï€ & Hna)".
+ iDestruct ("Hfn" $! π) as (P) "[Hmain HP]".
+ rewrite /initial_prog.
+ iApply (type_call_fnptr π [] [] 0 [] main main [] [] (λ _ _ _ _ _, True%I) (main_type P) [] with "[HP Hna] Hmain [] [] [] []").
+ + iIntros "_". iExists eq_refl, tt.
+ iIntros (???) "#CTX #HE HL".
+ iModIntro. iExists [], [], True%I.
+ iFrame. iSplitR.
+ { iApply maybe_logical_step_intro. simpl. eauto. }
+ iIntros "_". simpl. iR.
+ iIntros (???) "_ _ HL". iModIntro.
+ iExists [], [], True%I. iFrame.
+ iSplitL "HP". { iApply maybe_logical_step_intro. eauto. }
+ simpl. iSplitR. { iPureIntro. by apply Forall_nil. }
+ iSplitR. { iPureIntro. intros. apply elctx_sat_nil. }
+ iIntros (v []).
+ iIntros (??) "_ HL _". eauto with iFrame.
+ + by iApply big_sepL2_nil.
+ + rewrite /rrust_ctx. iFrame "#".
+ + by iApply big_sepL_nil.
+ + by iApply big_sepL_nil.
+ + iIntros (?????) "HL Hv _". done.
+ - iFrame. iIntros (?? _ _ ?) "_ _ _". iApply fupd_mask_intro_discard => //. iPureIntro. by eauto.
+ - iFrame.
+ rewrite /heap_state_ctx /alloc_meta_ctx /to_alloc_meta_map /alloc_alive_ctx /to_alloc_alive_map.
+ iFrame. iR. iExists 0. iFrame.
+Qed.
+
+(* clients of this:
+ - create a function map with monomorphized entries of all the functions they need
+ -> this we need to know upfront.
+ - from the fntbl_entry we get, build the function_ptr types.
+ we use Löb induction as part of that (have a later in the function_ptr type to enable that)
+ the induction assumes that we already have fn_ptrs for all the functions we build, at the types that they should have.
+
+
+ clients of this may also instantiate it with concrete layouts, if they can provide a layout algorithm that computes them.
+ we may want to provide a verified repr(C) algorithm for completeness/increasing trust in the interface.
+ *)
+
+
+
+(** * Helper functions for using the adequacy lemma *)
+Definition fn_lists_to_fns (addrs : list addr) (fns : list function) : gmap addr function :=
+ list_to_map (zip addrs fns).
+
+Lemma fn_lists_to_fns_cons `{!refinedcG Σ} addr fn addrs fns :
+ length addrs = length fns →
+ addr ∉ addrs →
+ ([∗ map] k↦qs ∈ fn_lists_to_fns (addr :: addrs) (fn :: fns), fntbl_entry (fn_loc k) qs) -∗
+ fntbl_entry (ProvFnPtr, addr) fn ∗ ([∗ map] k↦qs ∈ fn_lists_to_fns addrs fns, fntbl_entry (fn_loc k) qs).
+Proof.
+ move => Hnotin ?.
+ rewrite /fn_lists_to_fns /= big_sepM_insert //; auto.
+ apply not_elem_of_list_to_map_1. rewrite fst_zip => //; lia.
+Qed.
+
+(** * Tactics for solving conditions in an adequacy proof *)
+
+Ltac adequacy_intro_parameter :=
+ repeat lazymatch goal with
+ | |- ∀ _ : (), _ => case
+ | |- ∀ _ : (_ * _), _ => case
+ | |- ∀ _ : _, _ => move => ?
+ end.
+
+(*
+Ltac adequacy_unfold_equiv :=
+ lazymatch goal with
+ | |- type_fixpoint _ _ ≡ type_fixpoint _ _ => apply: type_fixpoint_proper; [|move => ??]
+ | |- ty_own_val _ _ ≡ ty_own_val _ _ => unfold ty_own_val => /=
+ | |- _ =@{struct_layout} _ => apply: struct_layout_eq
+ end.
+
+Ltac adequacy_solve_equiv unfold_tac :=
+ first [ eassumption | fast_reflexivity | unfold_type_equiv | adequacy_unfold_equiv | f_contractive | f_equiv' | reflexivity | progress unfold_tac ].
+
+Ltac adequacy_solve_typed_function lemma unfold_tac :=
+ iApply typed_function_equiv; [
+ done |
+ adequacy_intro_parameter => /=; repeat (constructor; [done|]); by constructor |
+ | iApply lemma => //; iExists _; repeat iSplit => //];
+ adequacy_intro_parameter => /=; eexists eq_refl => /=; split_and!; [..|adequacy_intro_parameter => /=; split_and!]; repeat adequacy_solve_equiv unfold_tac.
+ *)
diff --git a/theories/rust_typing/alias_ptr.v b/theories/rust_typing/alias_ptr.v
new file mode 100644
index 0000000000000000000000000000000000000000..40ee55a29f41fce0d0d01623c4a50464f364c435
--- /dev/null
+++ b/theories/rust_typing/alias_ptr.v
@@ -0,0 +1,454 @@
+From refinedrust Require Export type ltypes programs program_rules.
+From refinedrust Require Import memcasts ltype_rules value.
+From iris Require Import options.
+
+
+(** A specialized version for pointers.
+ This is mainly useful if we want to specify ownership of allocations in an ADT separately (e.g. in RawVec) from the field of the struct actually containing the pointer.
+ Disadvantage: this does not have any useful interaction laws with the AliasLtype, and we need to duplicate the place typing lemma for both of these. *)
+Section alias.
+ Context `{!typeGS Σ}.
+ Program Definition alias_ptr_t : type loc := {|
+ st_own Ï€ (l : loc) v := ⌜v = lâŒ%I;
+ st_syn_type := PtrSynType;
+ st_has_op_type ot mt := is_ptr_ot ot;
+ |}.
+ Next Obligation.
+ iIntros (Ï€ l v ->). iExists void*. eauto.
+ Qed.
+ Next Obligation.
+ iIntros (ot mt Hot).
+ destruct ot; try done.
+ rewrite Hot. done.
+ Qed.
+ Next Obligation.
+ iIntros (ot mt st π l v Hot) "Hv".
+ simpl in Hot. iPoseProof (mem_cast_compat_loc (λ v, ⌜v = lâŒ)%I with "Hv") as "%Hid"; first done.
+ { iIntros "->". eauto. }
+ destruct mt; [done | | done].
+ rewrite Hid. done.
+ Qed.
+
+ Global Instance alias_ptr_t_copy : Copyable (alias_ptr_t).
+ Proof. apply _. Qed.
+
+End alias.
+
+Global Hint Unfold alias_ptr_t : tyunfold.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ (* TODO interaction with ghost drop? *)
+ Lemma alias_ptr_simplify_hyp (v : val) π (l : loc) T :
+ (⌜v = l⌠-∗ T)
+ ⊢ simplify_hyp (v â—áµ¥{Ï€} l @ alias_ptr_t) T.
+ Proof.
+ iIntros "HT %Hv". by iApply "HT".
+ Qed.
+ Global Instance alias_ptr_simplify_hyp_inst v π l :
+ SimplifyHypVal v π (alias_ptr_t) l (Some 0%N) :=
+ λ T, i2p (alias_ptr_simplify_hyp v π l T).
+
+ Lemma alias_ptr_simplify_goal (v : val) π (l : loc) T :
+ (⌜v = lâŒ) ∗ T ⊢ simplify_goal (v â—áµ¥{Ï€} l @ alias_ptr_t) T.
+ Proof.
+ rewrite /simplify_goal. iIntros "(-> & $)". done.
+ Qed.
+ Global Instance alias_ptr_simplify_goal_inst v π l :
+ SimplifyGoalVal v π (alias_ptr_t) l (Some 0%N) :=
+ λ T, i2p (alias_ptr_simplify_goal v π l T).
+
+ Import EqNotations.
+ (** Unsafe simplification: if we can't find a value assignment for a location, also just try to make it an alias_ptr. *)
+ (*
+ Lemma alias_ptr_simplify_goal_unsafe1 π (l : loc) {rt} (ty : type rt) (r : rt) T :
+ (* redundant thing due to evar instantiation *)
+ T (⌜rt = loc⌠∗ l â—áµ¥{Ï€} r @ ty) -∗
+ simplify_goal (l â—áµ¥{Ï€} r @ ty) T.
+ Proof.
+ iIntros "HT". iExists _. iFrame.
+ iIntros "(-> & $)".
+ Qed.
+ Global Instance alias_ptr_simplify_goal_unsafe1_inst π (l : loc) {rt} (ty : type rt) (r : rt) :
+ SimplifyGoalVal l π ty r (Some 11%N) :=
+ λ T, i2p (alias_ptr_simplify_goal_unsafe1 π l ty r T).
+
+ Lemma alias_ptr_simplify_goal_unsafe2 π (l : loc) (ty : type loc) (r : loc) T :
+ (* redundant thing due to evar instantiation *)
+ T (⌜ty = alias_ptr_t⌠∗ ⌜r = lâŒ) -∗
+ simplify_goal (l â—áµ¥{Ï€} r @ ty) T.
+ Proof.
+ iIntros "HT". iExists _. iFrame.
+ iIntros "(-> & ->)". rewrite /ty_own_val/=. done.
+ Qed.
+ Global Instance alias_ptr_simplify_goal_unsafe2_inst π (l : loc) (ty : type loc) (r : loc) :
+ SimplifyGoalVal l π ty r (Some 10%N) :=
+ λ T, i2p (alias_ptr_simplify_goal_unsafe2 π l ty r T).
+ *)
+
+ (* Place typing accesses to alias_ptr:
+ - in RefinedC's setup: essentially just exploit the equality and then start a new search in the context for the location; independent of any actual operation
+ - for us: that would entail making alias_ptr an ltype.
+ does that make sense? maybe not so much.
+ Or maybe it dose?
+
+ Does the fact that we need to do a dereference affect us much?
+ - difference is that we always have some actual ownership involved when stating place ownership of alias_ptr, because we wrap it in ofty.
+ - I can't really do chains of alias_ptr that way.
+
+ One idea: have a simplification thing for ofty and then simplify value ownership of the type. That way, we could basically chase chains of alias_ptr. (by always simplifyign below the â—)
+ - does this make much sense apart from simplifying alias_ptr? In all other cases, I don't have precise enough information about what value to simplify.
+ - but: this requires then having a proper owned_ptr for the Vec spec. (?)
+ -
+
+ How about having an alias_ptr_lt?
+ - We do not get a direct unfoldign equation in terms of ofty.
+ Rather, this is another ltype we can "leave" in case we take the ownership of an ofty and instead want to leave an alias.
+ - we can easily formulate the place lemma
+ - this makes a lot of sense for taking raw address-of
+ *)
+
+
+ (* unnatural about this: ofty contains an owned pointer.
+ why can't we just strip it? because we don't have a location ownership predicate for the contained type in general -- ofty is precisely providing that.
+
+ the tension here: the corresponding location predicate for alias_ptr does not actually assert any ownership.
+ why do we need the value version at all?
+ concretely for us: for rawvec.
+ in refinedc, one would probably use an owned pointer instead.
+ in our case, we could also use owned_ptr instead, if our array type was less ugly.
+ *)
+
+ (* way to make this generic: have a lemma for ofty that says
+ "I give you value ownership of the contained thing, then you give me some new ltype and then I can continue"
+ *)
+
+
+ Lemma typed_place_ofty_alias_ptr_owned π E L l l2 bmin0 wl P T :
+ find_in_context (FindLoc l2 π) (λ '(existT rt2 (lt2, r2, b2)),
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' [] li b3 bmin rti ltyi ri
+ (match strong with
+ | Some strong => Some $ mk_strong (λ _, _) (λ _ _ _, â— alias_ptr_t) (λ _ _, PlaceIn l2) (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)
+ | None => None
+ end)
+ (match weak with
+ | Some weak => Some $ mk_weak (λ _ _, â— alias_ptr_t) (λ _, #l2) (λ ltyi2 ri2, llft_elt_toks κs ∗ l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)
+ | None =>
+ match strong with
+ | Some strong => Some $ mk_weak (λ _ _, â— alias_ptr_t) (λ _, #l2) (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)
+ | None => None
+ end
+ end)
+ ))
+ ⊢ typed_place π E L l (◠alias_ptr_t) (PlaceIn l2) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iDestruct 1 as ((rt2 & ([lt2 r2] & b2))) "(Hl2 & HP)". simpl.
+ iApply typed_place_ofty_access_val_owned; first done.
+ iIntros (? v ?) "-> !>". iExists _, _, _, _, _. iSplitR; first done. iFrame "Hl2 HP". done.
+ Qed.
+ Global Instance typed_place_ofty_alias_ptr_owned_inst π E L l l2 bmin0 wl P :
+ TypedPlace E L π l (◠alias_ptr_t)%I (PlaceIn l2) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) |30 :=
+ λ T, i2p (typed_place_ofty_alias_ptr_owned π E L l l2 bmin0 wl P T).
+
+ Lemma typed_place_ofty_alias_ptr_uniq π E L l l2 bmin0 κ γ P T :
+ ⌜lctx_lft_alive E L κ⌠∗
+ find_in_context (FindLoc l2 π) (λ '(existT rt2 (lt2, r2, b2)),
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' κs li b3 bmin rti ltyi ri
+ (fmap (λ strong, mk_strong (λ _, _) (λ _ _ _, ◠alias_ptr_t) (λ _ _, PlaceIn l2)
+ (* give back ownership through R *)
+ (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (fmap (λ weak, mk_weak (λ _ _, ◠alias_ptr_t) (λ _, PlaceIn l2)
+ (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ ))
+ ⊢ typed_place π E L l (◠alias_ptr_t) (PlaceIn l2) bmin0 (Uniq κ γ) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iDestruct 1 as (Hal (rt2 & ([lt2 r2] & b2))) "(Hl2 & HP)". simpl.
+ iApply typed_place_ofty_access_val_uniq; first done. iSplitR; first done.
+ iIntros (? v ?) "-> !>". iExists _, _, _, _, _. iSplitR; first done. iFrame. done.
+ Qed.
+ Global Instance typed_place_ofty_alias_ptr_uniq_inst π E L l l2 bmin0 κ γ P :
+ TypedPlace E L π l (◠alias_ptr_t)%I (PlaceIn l2) bmin0 (Uniq κ γ) (DerefPCtx Na1Ord PtrOp true :: P) |30 :=
+ λ T, i2p (typed_place_ofty_alias_ptr_uniq π E L l l2 bmin0 κ γ P T).
+
+ Lemma typed_place_ofty_alias_ptr_shared π E L l l2 bmin0 κ P T :
+ ⌜lctx_lft_alive E L κ⌠∗
+ find_in_context (FindLoc l2 π) (λ '(existT rt2 (lt2, r2, b2)),
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' κs li b3 bmin rti ltyi ri
+ (fmap (λ strong, mk_strong (λ _, _) (λ _ _ _, ◠alias_ptr_t) (λ _ _, PlaceIn l2)
+ (* give back ownership through R *)
+ (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (option_map (λ weak, mk_weak (λ _ _, ◠alias_ptr_t) (λ _, PlaceIn l2)
+ (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ ))
+ ⊢ typed_place π E L l (◠alias_ptr_t) (PlaceIn l2) bmin0 (Shared κ) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iDestruct 1 as (Hal (rt2 & ([lt2 r2] & b2))) "(Hl2 & HP)". simpl.
+ iApply typed_place_ofty_access_val_shared; first done. iSplitR; first done.
+ iIntros (? v ?) "-> !>". iExists _, _, _, _, _. iSplitR; first done. iFrame. done.
+ Qed.
+ Global Instance typed_place_ofty_alias_ptr_shared_inst π E L l l2 bmin0 κ P :
+ TypedPlace E L π l (◠alias_ptr_t)%I (PlaceIn l2) bmin0 (Shared κ) (DerefPCtx Na1Ord PtrOp true :: P) |30 :=
+ λ T, i2p (typed_place_ofty_alias_ptr_shared π E L l l2 bmin0 κ P T).
+
+ (* TODO is there a better design that does not require us to essentially duplicate this?
+ we have alias_ltype in the first place only because of the interaction with OpenedLtype, when we do a raw-pointer-addrof below references.
+ *)
+End rules.
+
+(** Rules for AliasLtype *)
+Section alias_ltype.
+ Context `{!typeGS Σ}.
+
+ Lemma alias_ltype_owned_simplify_hyp π rt st wl (l l2 : loc) (r : place_rfn rt) T :
+ (⌜l = l2⌠-∗ T)
+ ⊢ simplify_hyp (l â—â‚—[Ï€, Owned wl] r @ AliasLtype rt st l2) T.
+ Proof.
+ iIntros "HT Hl".
+ rewrite ltype_own_alias_unfold /alias_lty_own.
+ iDestruct "Hl" as "(%ly & Hst & -> & Hloc & Hlb)".
+ by iApply "HT".
+ Qed.
+ Global Instance alias_ltype_owned_simplify_hyp_inst π rt st wl l l2 r :
+ SimplifyHyp (l â—â‚—[Ï€, Owned wl] r @ AliasLtype rt st l2) (Some 0%N) :=
+ λ T, i2p (alias_ltype_owned_simplify_hyp π rt st wl l l2 r T).
+
+ Lemma alias_ltype_unowned_simplify_hyp π rt st b (l l2 : loc) (r : place_rfn rt) T :
+ (if b is Owned _ then False else True) →
+ (False -∗ T)
+ ⊢ simplify_hyp (l â—â‚—[Ï€, b] r @ AliasLtype rt st l2) T.
+ Proof.
+ iIntros (?) "HT Hl".
+ rewrite ltype_own_alias_unfold /alias_lty_own.
+ destruct b; done.
+ Qed.
+ Global Instance alias_ltype_uniq_simplify_hyp_inst π rt st κ γ l l2 r :
+ SimplifyHyp (l â—â‚—[Ï€, Uniq κ γ] r @ AliasLtype rt st l2) (Some 0%N) :=
+ λ T, i2p (alias_ltype_unowned_simplify_hyp π rt st (Uniq κ γ) l l2 r T I).
+ Global Instance alias_ltype_shared_simplify_hyp_inst π rt st κ l l2 r :
+ SimplifyHyp (l â—â‚—[Ï€, Shared κ] r @ AliasLtype rt st l2) (Some 0%N) :=
+ λ T, i2p (alias_ltype_unowned_simplify_hyp π rt st (Shared κ) l l2 r T I).
+
+ (* At the core this is really similar to the place lemma for alias_ptr_t - just without the deref *)
+ Lemma typed_place_alias_owned π E L l l2 rt (r : place_rfn rt) st bmin0 wl P T :
+ find_in_context (FindLoc l2 π) (λ '(existT rt2 (lt2, r2, b2)),
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' κs li b3 bmin rti ltyi ri
+ (fmap (λ strong, mk_strong (λ _, _) (λ _ _ _, AliasLtype rt st l2) (λ _ _, r)
+ (* give back ownership through R *)
+ (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (fmap (λ weak, mk_weak (λ _ _, AliasLtype rt st l2) (λ _, r)
+ (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ ))
+ ⊢ typed_place π E L l (AliasLtype rt st l2) r bmin0 (Owned wl) P T.
+ Proof.
+ iDestruct 1 as ((rt2 & ([lt2 r2] & b2))) "(Hl2 & HP)". simpl.
+ iIntros (????) "#CTX #HE HL #Hincl Hl Hcont".
+ rewrite ltype_own_alias_unfold /alias_lty_own.
+ iDestruct "Hl" as "(%ly & % & -> & #? & #? & Hcred)".
+ iApply ("HP" with "[//] [//] CTX HE HL [] Hl2").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L' κs l2 b0 bmin rti ltyi ri strong weak) "#Hincl1 Hl2 Hcl HT HL".
+ iApply ("Hcont" with "[//] Hl2 [Hcl Hcred] HT HL").
+ iSplit.
+ - (* strong *)
+ destruct strong as [ strong | ]; last done.
+ iDestruct "Hcl" as "[Hcl _]". simpl.
+ iIntros (rti2 ltyi2 ri2) "Hl2 %Hst".
+ iMod ("Hcl" with "Hl2 [//]") as "(Hl & % & Hstrong)".
+ iModIntro. iSplitL "Hcred".
+ { rewrite ltype_own_alias_unfold /alias_lty_own. eauto 8 with iFrame. }
+ iSplitR; first done. iFrame.
+ - (* weak *) iDestruct "Hcl" as "[_ Hcl]". simpl.
+ destruct weak as [weak | ]; simpl; last done.
+ iIntros (ltyi2 ri2 ?) "#Hincl3 Hl2 Hcond".
+ iMod ("Hcl" with "Hincl3 Hl2 Hcond") as "(Hl & Hcond & Htoks & Hweak)".
+ iModIntro. iSplitL "Hcred".
+ { rewrite ltype_own_alias_unfold /alias_lty_own. eauto 8 with iFrame. }
+ iFrame.
+ iApply typed_place_cond_refl. done.
+ Qed.
+ Global Instance typed_place_alias_owned_inst π E L l l2 rt r st bmin0 wl P :
+ TypedPlace E L π l (AliasLtype rt st l2) r bmin0 (Owned wl) P :=
+ λ T, i2p (typed_place_alias_owned π E L l l2 rt r st bmin0 wl P T).
+
+
+ (** Core lemma for putting back ownership after raw borrows *)
+ Lemma stratify_ltype_alias_owned π E L mu mdu ma {M} (m : M) l l2 rt st r wl (T : stratify_ltype_cont_t) :
+ match ma with
+ | StratNoRefold => T L True _ (AliasLtype rt st l2) r
+ | _ =>
+ find_in_context (FindLoc l2 π) (λ '(existT rt2 (lt2, r2, b2)),
+ ⌜ltype_st lt2 = st⌠∗ ⌜b2 = Owned wl⌠∗
+ (* recursively stratify *)
+ stratify_ltype π E L mu mdu ma m l2 lt2 r2 b2 (λ L2 R rt2' lt2' r2',
+ T L2 R rt2' lt2' r2'))
+ end
+ ⊢ stratify_ltype π E L mu mdu ma m l (AliasLtype rt st l2) r (Owned wl) T.
+ Proof.
+ iIntros "HT".
+ destruct (decide (ma = StratNoRefold)) as [-> | ].
+ { iIntros (???) "#CTX #HE HL Hl". iModIntro. iExists _, _, _, _, _. iFrame.
+ iSplitR; first done. iApply logical_step_intro. by iFrame. }
+ iAssert (find_in_context (FindLoc l2 π) (λ '(existT rt2 (lt2, r2, b2)), ⌜ltype_st lt2 = st⌠∗ ⌜b2 = Owned wl⌠∗ stratify_ltype π E L mu mdu ma m l2 lt2 r2 b2 T))%I with "[HT]" as "HT".
+ { destruct ma; done. }
+ iDestruct "HT" as ([rt2 [[lt2 r2] b2]]) "(Hl2 & <- & -> & HT)".
+ simpl. iIntros (???) "#CTX #HE HL Hl".
+ rewrite ltype_own_alias_unfold /alias_lty_own.
+ iDestruct "Hl" as "(%ly & %Halg & -> & %Hly & Hlb)".
+ simp_ltypes.
+ iMod ("HT" with "[//] [//] CTX HE HL Hl2") as (L3 R rt2' lt2' r2') "(HL & %Hst & Hstep & HT)".
+ iModIntro. iExists _, _, _, _, _. iFrame. done.
+ Qed.
+ Global Instance stratify_ltype_alias_owned_inst π E L mu mdu ma {M} (m : M) l l2 rt st r wl :
+ StratifyLtype π E L mu mdu ma m l (AliasLtype rt st l2) r (Owned wl) :=
+ λ T, i2p (stratify_ltype_alias_owned π E L mu mdu ma m l l2 rt st r wl T).
+
+ (* TODO move; doesn't hold anymore because of credits.. *)
+ (*
+ Global Instance ltype_own_alias_pers π l b rt r st l2 :
+ Persistent (l â—â‚—[Ï€, b] r @ AliasLtype rt st l2).
+ Proof.
+ rewrite ltype_own_alias_unfold /alias_lty_own.
+ destruct b; apply _.
+ Qed.
+ *)
+
+ (* Instance for &raw mut, in the case that the place type is AliasLtype. This case is fairly trivial. *)
+ Lemma typed_addr_of_mut_end_alias π E L l l2 st rt r b2 bmin (T : typed_addr_of_mut_end_cont_t) :
+ (⌜l2 = l⌠-∗ T L _ (alias_ptr_t) l2 _ (AliasLtype rt st l2) r)
+ ⊢ typed_addr_of_mut_end π E L l (AliasLtype rt st l2) r b2 bmin T.
+ Proof.
+ iIntros "HT". iIntros (????) "#CTX #HE HL Hincl Hl".
+ rewrite ltype_own_alias_unfold /alias_lty_own. destruct b2 as [wl | | ]; [| done..].
+ iDestruct "Hl" as "(%ly & %Hst & -> & %Hly & #Hlb & Hcred)".
+ iSpecialize ("HT" with "[//]").
+ iApply logical_step_intro. iExists _, _, _, _, _, _, _. iFrame.
+ iSplitR; first done.
+ rewrite !ltype_own_alias_unfold /alias_lty_own.
+ iSplitL "Hcred". { eauto 8 with iFrame. }
+ iSplitR. { eauto 8 with iFrame. }
+ done.
+ Qed.
+ Global Instance typed_addr_of_mut_end_alias_inst π E L l l2 rt st r b2 bmin :
+ TypedAddrOfMutEnd π E L l (AliasLtype rt st l2) r b2 bmin | 10 :=
+ λ T, i2p (typed_addr_of_mut_end_alias π E L l l2 st rt r b2 bmin T).
+
+
+ (* Instance for ofty *)
+ (* TODO maybe remove the bmin part *)
+
+ (* TODO: is there a good way to streamline all of these instances in a nice way?
+ I have roughly the same duplication/problems for typed_write and typed_read and possibly typed_borrow_shr, too.
+ Especially if we get more ltypes, that is really annoying.
+
+ Maybe there is a nice notion of "simple ltypes" that admits generic lemmas for stuff like this, because it doesn't exploit the different ownership kinds in an interesting way?
+ In that case, there should be a core of the definition that is the same in all these cases.
+
+ if b ≠Shared:
+ l â—â‚—[Ï€, b] r @ lt -∗
+ logical_step (l â—â‚—[Ï€, b] OpenedLtype lt lt lt .. ..)
+
+ l â—â‚—[Ï€, Owned true] r @ lt -∗
+ logical_step (l â—â‚—[Ï€, Owned false] r @ lt)
+
+ *)
+
+ (* TODO: should make typed_addr_of_mut_end available in cases where no strong updates are allowed.
+ AliasLtype does now support that case. *)
+
+ Lemma typed_addr_of_mut_end_owned π E L l {rt} (lt : ltype rt) r wl bmin (T : typed_addr_of_mut_end_cont_t) :
+ ltype_owned_openable lt →
+ T L _ (alias_ptr_t) l _ (AliasLtype rt (ltype_st lt) l) (#r)
+ ⊢ typed_addr_of_mut_end π E L l lt #r (Owned wl) bmin T.
+ Proof.
+ iIntros (Hopen) "Hvs".
+ iIntros (????) "#CTX #HE HL Hincl Hl".
+ iApply fupd_logical_step.
+ iMod (ltype_owned_openable_elim_logstep with "Hl") as "(Hl & Hs)"; first done.
+ iApply logical_step_fupd.
+ iApply (logical_step_wand with "Hs").
+ iIntros "!> Hcreds".
+ iPoseProof (ltype_own_make_alias with "Hl Hcreds") as "(Hl & Halias)".
+ iModIntro. iExists _, _, _, _, _, _, _. iFrame. simp_ltypes.
+ iSplitR; done.
+ Qed.
+ Global Program Instance tyepd_addr_of_mut_end_owned_ofty_inst π E L l {rt} (ty : type rt) r wl bmin :
+ TypedAddrOfMutEnd π E L l (◠ty)%I #r (Owned wl) bmin :=
+ λ T, i2p (typed_addr_of_mut_end_owned π E L l (◠ty)%I r wl bmin T _).
+ Next Obligation. intros. apply ltype_owned_openable_ofty. Qed.
+ (* TODO more instances *)
+
+ Lemma typed_addr_of_mut_end_uniq π E L l {rt} (lt : ltype rt) r κ γ bmin (T : typed_addr_of_mut_end_cont_t) :
+ ltype_uniq_openable lt →
+ li_tactic (lctx_lft_alive_count_goal E L κ) (λ '(κs, L2),
+ T L2 _ (alias_ptr_t) l _ (OpenedLtype (AliasLtype rt (ltype_st lt) l) lt lt (λ ri ri', ⌜ri = ri'âŒ) (λ ri ri', llft_elt_toks κs)) (#r))
+ ⊢ typed_addr_of_mut_end π E L l lt #r (Uniq κ γ) bmin T.
+ Proof.
+ iIntros (Hopen). rewrite /lctx_lft_alive_count_goal.
+ iDestruct 1 as (κs L2) "(%Hcount & HT)".
+ iIntros (????) "#CTX #HE HL Hincl Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Halg & %Hly)".
+ iPoseProof (ltype_own_loc_in_bounds with "Hl") as "#Hlb"; first done.
+ iApply fupd_logical_step.
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (lctx_lft_alive_count_tok lftE with "HE HL") as "(%q & Htok & Hcl_tok & HL)"; [done.. | ].
+ iMod ("Hcl_F") as "_".
+ iPoseProof (Hopen with "CTX Htok Hcl_tok Hl") as "Hs"; first done.
+ iApply logical_step_fupd.
+ iMod "Hs". iApply logical_step_intro.
+ iIntros "!>!>".
+ iPoseProof (opened_ltype_acc_uniq with "Hs") as "(Hl & Hl_cl)".
+ iPoseProof (ltype_own_make_alias false with "Hl [//]") as "(Hl & Halias)".
+ iPoseProof ("Hl_cl" with "Halias []") as "Hopened".
+ { simp_ltypes. done. }
+ iExists _, _, _, _, _, _, _. iFrame. simp_ltypes.
+ iSplitR; done.
+ Qed.
+ Global Program Instance tyepd_addr_of_mut_end_uniq_ofty_inst π E L l {rt} (ty : type rt) r κ γ bmin :
+ TypedAddrOfMutEnd π E L l (◠ty)%I #r (Uniq κ γ) bmin :=
+ λ T, i2p (typed_addr_of_mut_end_uniq π E L l (◠ty)%I r κ γ bmin T _).
+ Next Obligation. intros. apply ltype_uniq_openable_ofty. Qed.
+ (* TODO more instances *)
+
+
+ (** ExtractValueAnnot *)
+ Lemma type_extract_value_annot_alias π E L n v l (T : typed_annot_expr_cont_t) :
+ find_in_context (FindLoc l π) (λ '(existT rt (lt, r, bk)),
+ ∃ wl ty r', ⌜bk = Owned wl⌠∗ ⌜lt = â—ty⌠∗ ⌜r = #r'⌠∗
+ (⌜Nat.b2n wl ≤ n⌠∗
+ li_tactic (compute_layout_goal ty.(ty_syn_type)) (λ ly,
+ (∀ v3, v3 â—áµ¥{Ï€} r' @ ty -∗ l â—â‚—[Ï€, Owned wl] #v3 @ (â— value_t (UntypedSynType ly)) -∗ T L v _ alias_ptr_t l))))
+ ⊢ typed_annot_expr Ï€ E L n ExtractValueAnnot v (v â—áµ¥{Ï€} l @ alias_ptr_t) T.
+ Proof.
+ rewrite /FindLoc.
+ iIntros "(%a & Hl & HT)". destruct a as [rt [[lt r] bk]].
+ iDestruct "HT" as "(%wl & %ty & %r' & -> & -> & -> & HT)".
+ rewrite /compute_layout_goal. simpl.
+ iDestruct "HT" as "(%Hle & %ly & %Hst & HT)".
+ iIntros "#CTX #HE HL Halias". iApply step_fupdN_intro; first done.
+ rewrite (ltype_own_ofty_unfold ty) /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly' & % & % & Hsc & Hlb & Hcreds & %r & <- & Hb)".
+ assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (bi.laterN_le _ n with "Hb") as "Hb"; first done.
+ iNext.
+ iMod (fupd_mask_mono with "Hb") as "(%v3 & Hl & Hv)"; first done.
+ iPoseProof (value_split _ _ _ _ (UntypedSynType _) with "Hv") as "(Hv' & Hv)".
+ { split; first done. eapply syn_type_has_layout_make_untyped; done. }
+ iDestruct ("HT" with "Hv [Hl Hv' Hlb Hcreds]") as "HT".
+ { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists _. simpl.
+ iSplitR. { iPureIntro. eapply syn_type_has_layout_make_untyped; done. }
+ iSplitR; first done. iFrame.
+ iExists _. iSplitR; first done. iModIntro.
+ iExists v3. by iFrame. }
+ iExists L, _, _, _. by iFrame.
+ Qed.
+ Global Instance type_extract_value_annot_alias_inst π E L n v l :
+ TypedAnnotExpr Ï€ E L n ExtractValueAnnot v (v â—áµ¥{Ï€} l @ alias_ptr_t)%I :=
+ λ T, i2p (type_extract_value_annot_alias π E L n v l T).
+
+End alias_ltype.
diff --git a/theories/rust_typing/annotations.v b/theories/rust_typing/annotations.v
new file mode 100644
index 0000000000000000000000000000000000000000..1fd15082313eec0820cad74f2db802325098367e
--- /dev/null
+++ b/theories/rust_typing/annotations.v
@@ -0,0 +1,67 @@
+From refinedrust Require Import base.
+
+Inductive stop_annot : Type :=
+ StopAnnot.
+
+(** Annotation for starting a local lifetime [n ⊑ ⨅ sup].
+ [n] will contain a fresh atomic lifetime, which is the handle to end [n]. *)
+Inductive startlft_annot : Type :=
+ StartLftAnnot (n : string) (sup : list string).
+
+(** Similar to startlft, but do not include a new atomic lifetime in n, thus making [n = ⨅ sup]. *)
+Inductive aliaslft_annot : Type :=
+ AliasLftAnnot (n : string) (sup : list string).
+
+(** Annotation for ending a local lifetime n. *)
+Inductive endlft_annot : Type :=
+ EndLftAnnot (n : string).
+
+(** Annotation for extending a local lifetime n ⊑ ⨅ κs to be equal to ⨅ κs. *)
+Inductive extend_annot : Type :=
+ ExtendLftAnnot (n : string).
+
+
+(** Annotation for stratifying the context at this point. *)
+Inductive stratify_context_annot : Type :=
+ StratifyContextAnnot.
+
+(** Annotation for creating a dynamic inclusion of a lifetime κ1 ⊑ κ2 *)
+Inductive includelft_annot : Type :=
+ DynIncludeLftAnnot (n1 n2 : string).
+
+(** Annotation for copying the entry n2 ↦ κ in the name map for n1, so that n1 ↦ κ. *)
+Inductive copylftname_annot : Type :=
+ CopyLftNameAnnot (n1 n2 : string).
+
+(** LftNameTrees for copying lifetime names *)
+Inductive LftNameTree : Set :=
+ | LftNameTreeLeaf
+ | LftNameTreeRef (lft : string) (t : LftNameTree)
+ (* TODO struct etc *)
+.
+
+(** Annotation for shortening the lifetime of an expression *)
+Inductive shortenlft_annot : Type :=
+ ShortenLftAnnot (t : LftNameTree).
+
+(** Annotation for adding lifetime names to the context for the semantic lifetimes of the given expression *)
+Inductive get_lft_names_annot : Type :=
+ GetLftNamesAnnot (t : LftNameTree).
+
+(** This indicates that a goto to the head of a loop is following.
+ Invariants are specified in the context. *)
+Inductive loop_start_annot : Type :=
+ | InitLoopAnnot.
+
+(** This asserts that an expression has a particular syntactic Rust type by triggering subtyping to the intended type. *)
+Inductive assert_type_annot : Type :=
+ | AssertTypeAnnot (ty : rust_type).
+
+(** TODO: just a place holder until we handle drops properly. *)
+Inductive drop_annot : Type :=
+ | DropAnnot.
+
+(** Annotation to extract a value assignment for the given expression.
+ This is a hack we currently need due to restricted evar instantiation on function calls. *)
+Inductive extract_value_annot : Type :=
+ | ExtractValueAnnot.
diff --git a/theories/rust_typing/arrays.v b/theories/rust_typing/arrays.v
new file mode 100644
index 0000000000000000000000000000000000000000..8703c7ab0f89c49a426e61ed43f67358d12e84c8
--- /dev/null
+++ b/theories/rust_typing/arrays.v
@@ -0,0 +1,2889 @@
+From refinedrust Require Export type ltypes.
+From refinedrust Require Import ltype_rules.
+From refinedrust Require Import uninit_def int.
+From refinedrust Require Import uninit value alias_ptr programs.
+Set Default Proof Using "Type".
+
+(** Design decisions:
+ - our array's refinements are homogeneously typed.
+ TODO: check in future if we maybe should switch to option refinements for uninit
+ - we have a fixed capacity -- otherwise, we cannot define the syntype (it would be a dynamically sized type..)
+ - the array does not own its deallocation permission -- because its value form is not a pointer type.
+ - it is refined by a list (homogeneous), similarly for the ltype. (we could also refine the ltype by a vec - but that would make everything more complicated)
+*)
+(* How do we get the Rust type [T; n] as a derived form?
+ - want that it unfolds to the same place type at least. It's fine if the type specifies some additional invariants, as long as the place type can accomodate them.
+ - the array ltype needs to be heterogeneous in the child ltypes, so it's got a list of child ltypes -- this enables us to get folding equations with [T; n]
+
+ What does this mean for initialization?
+ - we cannot partially initialize an array, or move some components out of it, even individually.
+ + is this a problem for drop?
+ => Yes. Dropping will drop all elements in sequence, so I need a representation of the intermediate state.
+ => This is not a problem for the Vec use case, but if we want to support proper Rust arrays, we cannot get around it.
+ TODO
+ + we cannot do strong accesses below arrays.
+ We can however at least do borrows. And we should be able to show that imp_unblockable lifts to arrays.
+ This seems excessively restrictive.
+ For now (just for doing Vec) it seems fine however.
+
+ How do we deal with the restricted form of updates allowed below arrays?
+ - we cannot unfold invariants below, at least not directly. We can first borrow to enable that.
+ - how do we express that in terms of constraints? we just do not allow a strong update vs. i.e., we probably also need to make that one optional.
+ That is a rather artificial limitation and an annoying break with the rest of the typesystem.
+ - Note that it would be rather more desirable if I would not have to introduce a new place type for that, given that this is a really specialized type for the concrete vec use case.
+ Basically, I don't want to have to go through the trouble of having a new place type if I don't need very fine-grained tracking of borrows.
+ Can I phrase it like that?
+ + option 1: would need ofty-based typing rules where I do not fully evaluate the place.
+ - potentially: also hand out a remaining place context to the base judgment, in case we do not have a suitable unfolding rule.
+ - then: can add new read/write/borrow _end rules for our new type specifying suitable place context.
+ one quite big departure: we need a wp in the place_end rules.
+ maybe restrict the set of place contexts allowed here.
+ => this seems like it could work, although it too is not a very principles approach.
+ + option 2: have a custom place rule for that that goes from an ofty (array ty len) to an ofty (ty)
+ this basically shortcuts the ltype part.
+ * When we do a shared borrow: get shared borrow; BUT: the whole place context handling is not really prepared for that.
+ + same for mutable borrows, I can't really phrase it in terms of the place contexts.
+ => this does not really seem to be implementable, as it does not fit in our current framework.
+
+ In general, one could even make this case for ArrayLtype in general: rust's bororw checker does not support precise tracking of borrows below, so we could also make a case that we don't need this here.
+ Only issue: other cases where we want to be able to do funky stuff below arrays, e.g. unfolding invariants -- these we fundamentally cannot just collapse into actions on an ofty because something interesting happens on the types below the array.
+ Maybe: this kind of argument is not a good kind of argument, since we even need to handle the cases that in Rust would be unsafe, or are (in case of invariants/functional properties) not expressible in the Rust type system. For the former, this in particular applies to drop handling, and this is the reason why we should have a proper ltype.
+
+ One other point: if I want to implement iterMut properly, I will likely also need this fine-grained control, because that is what happens internally - in unsafe code.
+
+ Is this such a frequently occurring case that it warrants support for that in the judgments?
+ Are cases where this occurrs not rather cases indicating that our current type system is not complete enough?
+ *)
+
+
+ (*
+ coericing ArrayLtype to uninit?
+ if we have a fully concrete array, it's the same.
+ difficulty compared to struct: what happens for symbolic arrays (e.g. an insert with Blocked)?
+
+ Can we develop some generally useful theory for reasoning about symbolic arrays?
+ TODO
+ *)
+
+
+
+
+(* TODO: should we also have an ArrayOp that reads the array elements at an op that is valid for the element types? *)
+Definition is_array_ot `{!typeGS Σ} {rt} (ty : type rt) (len : nat) (ot : op_type) (mt : memcast_compat_type) : Prop :=
+ match ot with
+ | UntypedOp ly =>
+ ∃ ly', ly = mk_array_layout ly' len ∧ ty.(ty_has_op_type) (UntypedOp ly') mt ∧
+ (* required for offsetting with LLVM's GEP *)
+ (ly_size ly ≤ max_int isize_t)%Z ∧
+ (* enforced by Rust *)
+ layout_wf ly'
+ | _ => False
+ end.
+
+Section array.
+ Context `{!typeGS Σ}.
+ Context {rt : Type}.
+
+ (* TODO: move *)
+ (* for simplicity: restricting to uniform sizes *)
+ Lemma heap_mapsto_mjoin_uniform l (vs : list val) (sz : nat) :
+ (∀ v, v ∈ vs → length v = sz) →
+ l ↦ mjoin vs ⊣⊢ loc_in_bounds l 0 (length vs * sz) ∗ ([∗ list] i ↦ v ∈ vs, (l +ₗ (sz * i)) ↦ v).
+ Proof.
+ intros Hsz.
+ assert (length (mjoin vs) = length vs * sz) as Hlen.
+ { induction vs as [ | v vs IH]; simpl; first lia.
+ rewrite app_length. rewrite Hsz; [ | apply elem_of_cons; by left].
+ f_equiv. apply IH. intros. apply Hsz. apply elem_of_cons; by right. }
+ induction vs as [ | v vs IH] in l, Hlen, Hsz |-*; simpl.
+ { rewrite right_id. by rewrite heap_mapsto_nil. }
+ iSplit.
+ - iIntros "Hl". iPoseProof (heap_mapsto_loc_in_bounds with "Hl") as "#Hlb".
+ rewrite heap_mapsto_app. iDestruct "Hl" as "[Hl1 Hl]".
+ rewrite Z.mul_0_r shift_loc_0_nat. iFrame "Hl1".
+ iSplitR. { rewrite Hlen. done. }
+ iPoseProof (IH with "Hl") as "Ha".
+ { intros. apply Hsz. apply elem_of_cons; by right. }
+ { simpl in Hlen. rewrite app_length in Hlen. rewrite Hsz in Hlen; [ | apply elem_of_cons; by left]. lia. }
+ iDestruct "Ha" as "(_ & Ha)".
+ iApply (big_sepL_wand with "Ha").
+ iApply big_sepL_intro. iIntros "!>" (k v' _).
+ rewrite shift_loc_assoc.
+ rewrite (Hsz v); [ | apply elem_of_cons; by left].
+ assert ((sz + sz * k)%Z = (sz * S k)%Z) as -> by lia.
+ eauto.
+ - iIntros "(Hlb & Hv)".
+ rewrite Z.mul_0_r shift_loc_0_nat heap_mapsto_app.
+ iDestruct "Hv" as "($ & Hv)".
+ iApply IH.
+ { intros. apply Hsz. apply elem_of_cons; by right. }
+ { simpl in Hlen. rewrite app_length in Hlen. rewrite Hsz in Hlen; [ | apply elem_of_cons; by left]. lia. }
+ iSplitL "Hlb".
+ + iApply (loc_in_bounds_offset with "Hlb"); first done.
+ { simpl. rewrite /addr. lia. }
+ { simpl. rewrite Hsz; [ | apply elem_of_cons; by left].
+ rewrite /addr. lia. }
+ + iApply (big_sepL_wand with "Hv").
+ iApply big_sepL_intro.
+ iIntros "!>" (???) "Hv".
+ rewrite shift_loc_assoc.
+ rewrite (Hsz v); [ | apply elem_of_cons; by left].
+ assert ((sz + sz * k)%Z = (sz * S k)%Z) as -> by lia.
+ eauto.
+ Qed.
+
+
+
+
+
+
+ Program Definition array_t (ty : type rt) (len : nat) : type (list (place_rfn rt)) := {|
+ ty_own_val π r v :=
+ ∃ ly,
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ ⌜length r = len⌠∗
+ ⌜v `has_layout_val` (mk_array_layout ly len)⌠∗
+ [∗ list] r'; v' ∈ r; reshape (replicate len (ly_size ly)) v,
+ ∃ r'', place_rfn_interp_owned r' r'' ∗ ty.(ty_own_val) π r'' v';
+ ty_shr κ π r l :=
+ ∃ ly,
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ ⌜length r = len⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ [∗ list] i ↦ r' ∈ r,
+ ∃ r'', place_rfn_interp_shared r' r'' ∗ ty.(ty_shr) κ π r'' (offset_loc l ly i);
+ ty_syn_type := ArraySynType ty.(ty_syn_type) len;
+ ty_has_op_type := is_array_ot ty len;
+ ty_sidecond := True;
+ ty_ghost_drop π r :=
+ [∗ list] r' ∈ r, match r' with | #r'' => ty.(ty_ghost_drop) π r'' | _ => True end;
+ ty_lfts := ty.(ty_lfts);
+ ty_wf_E := ty.(ty_wf_E);
+ |}%I.
+ Next Obligation.
+ iIntros (ty len π r v) "(%ly & %Hst & %Hsz & %Hlen & %Hly & Hv)".
+ iExists _.
+ iSplitR. { iPureIntro. eapply syn_type_has_layout_array; done. }
+ done.
+ Qed.
+ Next Obligation.
+ iIntros (ty len ot mt Hot).
+ destruct ot; try done.
+ destruct Hot as (ly' & -> & Hot & Hsz & Hwf).
+ eapply ty_op_type_stable in Hot.
+ eapply syn_type_has_layout_array.
+ - done.
+ - done.
+ - rewrite /ly_size /mk_array_layout in Hsz. simpl in Hsz. lia.
+ Qed.
+ Next Obligation.
+ iIntros (ty len π r v) "_". done.
+ Qed.
+ Next Obligation.
+ iIntros (ty len κ π l r) "(%ly & %Hst & %Hsz & %Hlen & %Hly & Hv)".
+ iExists (mk_array_layout ly len). iSplitR; first done.
+ iPureIntro. by eapply syn_type_has_layout_array.
+ Qed.
+ Next Obligation.
+ iIntros (ty len E κ l ly π r q ?).
+ iIntros "#(LFT & TIME & LCTX) Htok %Hst %Hly #Hlb Hb".
+ rewrite -lft_tok_sep. iDestruct "Htok" as "(Htok & Htok')".
+ iApply fupd_logical_step.
+ (* reshape the borrow - we must not freeze the existential over v to initiate recursive sharing *)
+ iPoseProof (bor_iff _ _ (∃ ly', ⌜syn_type_has_layout (ty_syn_type ty) ly'⌠∗ ⌜(ly_size ly' * len ≤ max_int isize_t)%Z⌠∗ ⌜length r = len⌠∗
+ [∗ list] i ↦ r' ∈ r, ∃ v r'', (l offset{ly'}ₗ i) ↦ v ∗ place_rfn_interp_owned r' r'' ∗ ty.(ty_own_val) π r'' v)%I with "[] Hb") as "Hb".
+ { iNext. iModIntro. iSplit.
+ - iIntros "(%v & Hl & %ly' & %Hst' & %Hsz & %Hlen & %Hv & Hv)".
+ iExists ly'. iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ subst len. clear -Hv.
+ set (szs := replicate (length r) (ly_size ly')).
+ assert (length r = length (reshape szs v)).
+ { subst szs. rewrite reshape_length replicate_length //. }
+ rewrite -{1}(join_reshape szs v); first last.
+ { rewrite sum_list_replicate. rewrite Hv /mk_array_layout /ly_mult {2}/ly_size. lia. }
+ rewrite (heap_mapsto_mjoin_uniform _ _ (ly_size ly')); first last.
+ { subst szs. intros v'.
+ intros ?%reshape_replicate_elem_length; first done.
+ rewrite Hv. rewrite {1}/ly_size /mk_array_layout /=. lia. }
+ iDestruct "Hl" as "(_ & Hl)".
+ iAssert ([∗ list] i ↦ r'; v' ∈ r; reshape szs v, (l +ₗ ly_size ly' * i) ↦ v')%I with "[Hl]" as "Hl".
+ { iApply big_sepL2_const_sepL_r. iSplit; done. }
+ iPoseProof (big_sepL2_sep with "[$Hv $Hl]") as "Hl".
+ iPoseProof (big_sepL2_wand _ (λ i r _, ∃ v' r'', (l offset{ly'}â‚— i) ↦ v' ∗ place_rfn_interp_owned r r'' ∗ v' â—áµ¥{Ï€} r'' @ ty)%I with "Hl []") as "Hl".
+ { iApply big_sepL2_intro; first done. iIntros "!>" (k ? ? _ _) "((% & ? &Hv) & Hl)".
+ iExists _, _; iFrame. rewrite /offset_loc. done. }
+ rewrite big_sepL2_const_sepL_l. iDestruct "Hl" as "(_ & $)".
+ - iIntros "(%ly' & %Hst' & %Hsz & %Hlen & Hl)".
+ (* if r is empty, we don't have any loc_in_bounds available.. we really need to require that in the sharing predicate. *)
+ rewrite big_sepL_exists. iDestruct "Hl" as "(%vs & Hl)".
+ setoid_rewrite <-bi.sep_exist_l.
+ iExists (mjoin vs). rewrite big_sepL2_sep. iDestruct "Hl" as "(Hl & Hv)".
+ iPoseProof (big_sepL2_length with "Hv") as "%Hlen'".
+ iAssert (∀ v, ⌜v ∈ vs⌠-∗ ⌜v `has_layout_val` ly'âŒ)%I with "[Hv]" as "%Ha".
+ { iIntros (v (i & Hlook)%elem_of_list_lookup_1).
+ assert (∃ r', r !! i = Some r') as (r' & Hlook').
+ { destruct (r !! i) eqn:Heq; first by eauto. exfalso.
+ apply lookup_lt_Some in Hlook. apply lookup_ge_None_1 in Heq. lia. }
+ iPoseProof (big_sepL2_lookup _ _ _ i with "Hv") as "Hv"; [done.. | ].
+ iDestruct "Hv" as "(% & _ & Hv)". by iApply (ty_own_val_has_layout with "Hv"). }
+ iSplitL "Hl". {
+ rewrite big_sepL2_const_sepL_r. iDestruct "Hl" as "(_ & Hl)".
+ iApply heap_mapsto_mjoin_uniform. { done. }
+ iSplitR; last done.
+ apply syn_type_has_layout_array_inv in Hst as (ly0 & Hst0 & -> & ?).
+ assert (ly0 = ly') as ->. { by eapply syn_type_has_layout_inj. }
+ rewrite -Hlen -Hlen'. rewrite Nat.mul_comm. done. }
+ iExists ly'. iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ iSplitR. { rewrite /has_layout_val.
+ rewrite join_length.
+ rewrite (sum_list_fmap_same (ly_size ly')).
+ - rewrite -Hlen' -Hlen. rewrite Nat.mul_comm. done.
+ - apply Forall_elem_of_iff. done. }
+ rewrite reshape_join; first done.
+ apply Forall2_lookup.
+ intros i.
+ destruct (vs !! i) eqn:Heq1; first last.
+ { rewrite Heq1.
+ rewrite (proj1 (lookup_replicate_None _ _ _)); first constructor.
+ apply lookup_ge_None in Heq1. lia. }
+ rewrite lookup_replicate_2; first last.
+ { apply lookup_lt_Some in Heq1. lia. }
+ rewrite Heq1. constructor. rewrite Ha; first last. { eapply elem_of_list_lookup_2. eauto. }
+ done.
+ }
+
+ iMod (bor_exists with "LFT Hb") as "(%ly' & Hb)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hst & Hb)"; first done.
+ iMod (bor_persistent with "LFT Hst Htok") as "(>%Hst' & Htok)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hsz & Hb)"; first done.
+ iMod (bor_persistent with "LFT Hsz Htok") as "(>%Hsz & Htok)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hlen & Hb)"; first done.
+ iMod (bor_persistent with "LFT Hlen Htok") as "(>%Hlen & Htok)"; first done.
+ iMod (bor_big_sepL with "LFT Hb") as "Hb"; first done.
+ iCombine "Htok Htok'" as "Htok". rewrite lft_tok_sep.
+ (* fracture the tokens over the big_sep *)
+ iPoseProof (Fractional_split_big_sepL (λ q, q.[_]%I) len with "Htok") as "(%qs & %Hlen' & Htoks & Hcl_toks)".
+ set (κ' := κ ⊓ foldr meet static (ty_lfts ty)).
+ iAssert ([∗ list] i ↦ x; q' ∈ r; qs, &{κ} (∃ v r'', (l offset{ly'}â‚— i) ↦ v ∗ place_rfn_interp_owned x r'' ∗ v â—áµ¥{ Ï€} r'' @ ty) ∗ q'.[κ'])%I with "[Htoks Hb]" as "Hb".
+ { iApply big_sepL2_sep_sepL_r; iFrame. iApply big_sepL2_const_sepL_l. iSplitR; last done. rewrite Hlen Hlen' //. }
+
+ eapply syn_type_has_layout_array_inv in Hst as (ly0 & Hst & -> & ?).
+ assert (ly0 = ly') as -> by by eapply syn_type_has_layout_inj.
+ iAssert ([∗ list] i ↦ x; q' ∈ r; qs, logical_step E ((∃ r', place_rfn_interp_shared x r' ∗ (l offset{ly'}â‚— i) â—â‚—{Ï€, κ} r' @ ty)
+ ∗ q'.[κ']))%I with "[Hb]" as "Hb".
+ { iApply (big_sepL2_wand with "Hb"). iApply big_sepL2_intro; first by lia.
+ iModIntro. iIntros (k x q0 Hlook1 Hlook2) "(Hb & Htok)".
+ rewrite bi_exist_comm.
+ iApply fupd_logical_step.
+ subst κ'.
+ rewrite -{1}lft_tok_sep. iDestruct "Htok" as "(Htok1 & Htok2)".
+ iMod (bor_exists_tok with "LFT Hb Htok1") as "(%r' & Ha & Htok1)"; first done.
+ iPoseProof (bor_iff _ _ (place_rfn_interp_owned x r' ∗ ∃ a, (l offset{ly'}â‚— k) ↦ a ∗ a â—áµ¥{ Ï€} r' @ ty)%I with "[] Ha") as "Ha".
+ { iNext. iModIntro. iSplit.
+ - iIntros "(%a & ? & ? & ?)". eauto with iFrame.
+ - iIntros "(? & %a & ? & ?)". eauto with iFrame. }
+ iMod (bor_sep with "LFT Ha") as "(Hrfn & Hb)"; first done.
+ iAssert (|={E}=> place_rfn_interp_shared x r' ∗ q0.[κ])%I with "[Hrfn Htok1]" as ">(Ha & Htok1)".
+ { destruct x; first last. { iModIntro. iFrame. done. }
+ simpl. iMod (bor_persistent with "LFT Hrfn Htok1") as "(>Ha & $)"; first done. eauto. }
+ iCombine "Htok1 Htok2" as "Htok". rewrite lft_tok_sep. iModIntro.
+ iPoseProof (ty_share with "[$LFT $TIME $LCTX] Htok [] [] [] Hb") as "Hb"; first done.
+ - done.
+ - iPureIntro.
+ apply has_layout_loc_offset_loc.
+ { eapply use_layout_alg_wf. done. }
+ { done. }
+ - assert (1 + k ≤ len)%nat as ?.
+ { eapply lookup_lt_Some in Hlook1. lia. }
+ iApply loc_in_bounds_offset; last done.
+ { done. }
+ { rewrite /offset_loc. simpl. rewrite /addr. lia. }
+ { rewrite /mk_array_layout /ly_mult {2}/ly_size. rewrite /offset_loc /= /addr.
+ rewrite /addr. nia. }
+ - iApply (logical_step_wand with "Hb"). iIntros "(? & ?)".
+ eauto with iFrame.
+ }
+ iPoseProof (logical_step_big_sepL2 with "Hb") as "Hb".
+ iModIntro. iApply (logical_step_wand with "Hb"). iIntros "Hb".
+ iPoseProof (big_sepL2_sep_sepL_r with "Hb") as "(Hb & Htok)".
+ iPoseProof ("Hcl_toks" with "Htok") as "$".
+ iPoseProof (big_sepL2_const_sepL_l with "Hb") as "(_ & Hb)".
+ iExists _. do 4 iR. done.
+ Qed.
+ Next Obligation.
+ iIntros (ty len κ κ' π r l) "#Hincl Hb".
+ iDestruct "Hb" as "(%ly & Hst & Hsz & Hlen & Hly & Hb)".
+ iExists ly. iFrame.
+ iApply (big_sepL_wand with "Hb"). iApply big_sepL_intro.
+ iIntros "!>" (k x Hlook) "(% & ? & Hb)".
+ iExists _; iFrame. iApply ty_shr_mono; done.
+ Qed.
+ Next Obligation.
+ iIntros (ty len π r v F ?) "(%ly & ? & ? & ? & ? & Hb)".
+ iAssert (logical_step F $ [∗ list] r'; v' ∈ r; reshape (replicate len (ly_size ly)) v,
+ match r' with | # r'' => ty_ghost_drop ty π r'' | PlaceGhost _ => True end)%I with "[Hb]" as "Hb".
+ { iApply logical_step_big_sepL2. iApply (big_sepL2_mono with "Hb"). iIntros (? r' ???).
+ iIntros "(%r'' & Hrfn & Hb)". destruct r'; last by iApply logical_step_intro.
+ iDestruct "Hrfn" as "->". by iApply ty_own_ghost_drop. }
+ iApply (logical_step_wand with "Hb").
+ iIntros "Hb". iPoseProof (big_sepL2_const_sepL_l with "Hb") as "(_ & $)".
+ Qed.
+ Next Obligation.
+ iIntros (ty len ot mt st π r v Hot) "Hb".
+ destruct ot as [ | | | | ly']; [done.. | ].
+ destruct Hot as (ly0 & -> & Hot & Hwf).
+ destruct mt; [done | done | done].
+ (* TODO maybe the second case should really change once we support an ArrayOpType? *)
+ Qed.
+
+ (* TODO: non-expansiveness *)
+
+ (* TODO copy *)
+End array.
+
+Global Typeclasses Opaque array_t.
+
+Section lemmas.
+ Context `{!typeGS Σ}.
+
+ (* TODO move *)
+ Lemma ly_size_mk_array_layout n ly :
+ ly_size (mk_array_layout ly n) = ly_size ly * n.
+ Proof.
+ rewrite /mk_array_layout /ly_mult /ly_size //.
+ Qed.
+
+ Lemma array_t_own_val_split {rt} (ty : type rt) π n1 n2 v1 v2 rs1 rs2 :
+ length rs1 = n1 →
+ length rs2 = n2 →
+ length v1 = n1 * size_of_st ty.(ty_syn_type) →
+ length v2 = n2 * size_of_st ty.(ty_syn_type) →
+ (v1 ++ v2) â—áµ¥{Ï€} (rs1 ++ rs2) @ array_t ty (n1 + n2) -∗
+ v1 â—áµ¥{Ï€} rs1 @ array_t ty n1 ∗ v2 â—áµ¥{Ï€} rs2 @ array_t ty n2.
+ Proof.
+ intros Hrs1 Hrs2 Hv1 Hv2. rewrite /ty_own_val /=.
+ iIntros "(%ly & %Halg & %Hsz & %Hlen & %Hly & Hb)".
+ rewrite /size_of_st /use_layout_alg' Halg /= in Hv1.
+ rewrite /size_of_st /use_layout_alg' Halg /= in Hv2.
+ rewrite replicate_add. rewrite reshape_app.
+ rewrite sum_list_replicate.
+ rewrite take_app_alt; last lia.
+ rewrite drop_app_alt; last lia.
+ iPoseProof (big_sepL2_app_inv with "Hb") as "[Hb1 Hb2]".
+ { rewrite reshape_length replicate_length. eauto. }
+ iSplitL "Hb1".
+ - iExists _. iR. iSplitR. { iPureIntro. lia. }
+ iR. iSplitR. { iPureIntro. rewrite /has_layout_val ly_size_mk_array_layout. lia. }
+ done.
+ - iExists _. iR. iSplitR. { iPureIntro. lia. }
+ iR. iSplitR. { iPureIntro. rewrite /has_layout_val ly_size_mk_array_layout. lia. }
+ done.
+ Qed.
+
+ Lemma array_t_own_val_merge {rt} (ty : type rt) π (n1 n2 : nat) v1 v2 rs1 rs2 :
+ (size_of_st ty.(ty_syn_type) * (n1 + n2) ≤ max_int isize_t)%Z →
+ v1 â—áµ¥{Ï€} rs1 @ array_t ty n1 -∗
+ v2 â—áµ¥{Ï€} rs2 @ array_t ty n2 -∗
+ (v1 ++ v2) â—áµ¥{Ï€} (rs1 ++ rs2) @ array_t ty (n1 + n2).
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros (Hsz) "(%ly1 & %Halg1 & %Hsz1 & %Hlen1 & %Hv1 & Hb1) (%ly2 & %Halg2 & %Hsz2 & %Hlen2 & %Hv2 & Hb2)".
+ assert (ly1 = ly2) as <- by by eapply syn_type_has_layout_inj. clear Halg2.
+ rewrite /size_of_st /use_layout_alg' Halg1 /= in Hsz.
+ iExists ly1. iR. iSplitR. { iPureIntro. lia. }
+ rewrite /has_layout_val ly_size_mk_array_layout in Hv1.
+ rewrite /has_layout_val ly_size_mk_array_layout in Hv2.
+ rewrite app_length -Hlen1 -Hlen2. iR.
+ iSplitR. { iPureIntro. rewrite /has_layout_val app_length Hv1 Hv2 ly_size_mk_array_layout. lia. }
+ rewrite replicate_add. rewrite reshape_app.
+ rewrite sum_list_replicate.
+ rewrite take_app_alt; last lia.
+ rewrite drop_app_alt; last lia.
+ iApply (big_sepL2_app with "Hb1 Hb2").
+ Qed.
+
+ Lemma array_t_shr_split {rt} (ty : type rt) π κ n1 n2 l rs1 rs2 :
+ length rs1 = n1 →
+ length rs2 = n2 →
+ l â—â‚—{Ï€, κ} (rs1 ++ rs2) @ array_t ty (n1 + n2) -∗
+ l â—â‚—{Ï€, κ} rs1 @ array_t ty n1 ∗ (l offsetst{ty.(ty_syn_type)}â‚— n1) â—â‚—{Ï€, κ} rs2 @ array_t ty n2.
+ Proof.
+ rewrite /ty_shr/=. iIntros (Hlen1 Hlen2).
+ iIntros "(%ly & %Halg & %Hsz & %Hlen & %Hly & Hb)".
+ rewrite big_sepL_app. iDestruct "Hb" as "(Hb1 & Hb2)".
+ rewrite app_length in Hlen.
+ iSplitL "Hb1".
+ - iExists _. iR. iSplitR. { iPureIntro. lia. }
+ iSplitR. { iPureIntro. lia. }
+ iR. done.
+ - iExists _. iR. iSplitR. { iPureIntro. lia. }
+ iSplitR. { iPureIntro. lia. }
+ rewrite /OffsetLocSt /use_layout_alg' Halg/=.
+ iSplitR. { iPureIntro. eapply has_layout_loc_offset_loc; last done.
+ by eapply use_layout_alg_wf. }
+ setoid_rewrite offset_loc_offset_loc. rewrite Hlen1.
+ setoid_rewrite Nat2Z.inj_add. done.
+ Qed.
+
+ Lemma array_t_shr_merge {rt} (ty : type rt) π κ (n1 n2 : nat) l rs1 rs2 :
+ (size_of_st ty.(ty_syn_type) * (n1 + n2) ≤ max_int isize_t)%Z →
+ l â—â‚—{Ï€, κ} rs1 @ array_t ty n1 -∗
+ (l offsetst{ty.(ty_syn_type)}â‚— n1) â—â‚—{Ï€, κ} rs2 @ array_t ty n2 -∗
+ l â—â‚—{Ï€, κ} (rs1 ++ rs2) @ array_t ty (n1 + n2).
+ Proof.
+ rewrite /ty_shr/=. iIntros (Hsz).
+ iIntros "(%ly1 & %Halg1 & %Hsz1 & %Hlen1 & %Hly1 & Hb1) (%ly2 & %Halg2 & %Hsz2 & %Hlen2 & %Hly2 & Hb2)".
+ assert (ly2 = ly1) as -> by by eapply syn_type_has_layout_inj. clear Halg2.
+ rewrite /size_of_st /use_layout_alg' Halg1 /= in Hsz.
+ iExists _. iR. iSplitR. { iPureIntro. lia. }
+ rewrite app_length. iSplitR. { iPureIntro. lia. }
+ iR. iApply (big_sepL_app).
+ iFrame.
+ rewrite /OffsetLocSt /use_layout_alg' Halg1 /=.
+ setoid_rewrite offset_loc_offset_loc. rewrite -Hlen1.
+ setoid_rewrite Nat2Z.inj_add. done.
+ Qed.
+
+End lemmas.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ Import EqNotations.
+ Local Definition array_t_incl_precond {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) rs1 rs2 :=
+ ([∗ list] r1; r2 ∈ rs1; rs2,
+ match r1, r2 with
+ | #r1, #r2 => type_incl r1 r2 ty1 ty2
+ | _, _ => ∃ (Heq : rt1 = rt2), ⌜r1 = rew <- [place_rfn] Heq in r2⌠∗ ∀ (r : rt1), type_incl r (rew Heq in r) ty1 ty2
+ end)%I.
+ Local Instance array_t_incl_precond_pers {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) rs1 rs2 :
+ Persistent (array_t_incl_precond ty1 ty2 rs1 rs2).
+ Proof.
+ apply big_sepL2_persistent. intros ? [] []; simpl; apply _.
+ Qed.
+
+ (* TODO: should we handle things like [u16; 2] << [u8; 4]? *)
+
+ (* TODO: in practice, we probably just want equality for the refinements? think about the symbolic case.. *)
+ Lemma array_t_own_val_mono' {rt1 rt2} π (ty1 : type rt1) (ty2 : type rt2) rs1 rs2 len v :
+ array_t_incl_precond ty1 ty2 rs1 rs2 -∗
+ v â—áµ¥{Ï€} rs1 @ array_t ty1 len -∗
+ v â—áµ¥{Ï€} rs2 @ array_t ty2 len.
+ Proof.
+ Admitted.
+ (* the "trivial" (Rust) subtyping that we need for, e.g., lifetimes *)
+ Lemma array_t_own_val_mono {rt} π (ty1 ty2 : type rt) len v rs :
+ (∀ r, type_incl r r ty1 ty2) -∗
+ v â—áµ¥{Ï€} rs @ array_t ty1 len -∗
+ v â—áµ¥{Ï€} rs @ array_t ty2 len.
+ Proof.
+ Admitted.
+
+ Lemma array_t_shr_mono' {rt1 rt2} π (ty1 : type rt1) (ty2 : type rt2) rs1 rs2 len v κ :
+ array_t_incl_precond ty1 ty2 rs1 rs2 -∗
+ v â—â‚—{Ï€, κ} rs1 @ array_t ty1 len -∗
+ v â—â‚—{Ï€, κ} rs2 @ array_t ty2 len.
+ Proof.
+ Admitted.
+ Lemma array_t_shr_mono {rt} π (ty1 ty2 : type rt) len v rs κ :
+ (∀ r, type_incl r r ty1 ty2) -∗
+ v â—â‚—{Ï€, κ} rs @ array_t ty1 len -∗
+ v â—â‚—{Ï€, κ} rs @ array_t ty2 len.
+ Proof.
+ Admitted.
+
+ Lemma array_t_type_incl' {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) rs1 rs2 len :
+ array_t_incl_precond ty1 ty2 rs1 rs2 -∗
+ type_incl rs1 rs2 (array_t ty1 len) (array_t ty2 len).
+ Proof.
+ Admitted.
+ Lemma array_t_type_incl {rt} (ty1 ty2 : type rt) rs len :
+ (∀ r, type_incl r r ty1 ty2) -∗
+ type_incl rs rs (array_t ty1 len) (array_t ty2 len).
+ Proof.
+ Admitted.
+
+ Lemma array_t_full_subtype E L {rt} (ty1 ty2 : type rt) len :
+ full_subtype E L ty1 ty2 →
+ full_subtype E L (array_t ty1 len) (array_t ty2 len).
+ Proof.
+ Admitted.
+
+End subtype.
+
+Section subltype.
+ Context `{!typeGS Σ}.
+
+ (* TODO move *)
+ Lemma interpret_inserts_nil {X} (iml : list (nat * X)) :
+ interpret_inserts iml [] = [].
+ Proof.
+ induction iml as [ | [] iml IH]; simpl; first done.
+ rewrite IH. done.
+ Qed.
+ Lemma interpret_iml_0 {X} (def : X) (iml : list (nat * X)) :
+ interpret_iml def 0 iml = [].
+ Proof.
+ rewrite /interpret_iml. rewrite interpret_inserts_nil//.
+ Qed.
+
+ Fixpoint cut_iml {X} (iml : list (nat * X)) : list (nat * X) :=
+ match iml with
+ | [] => []
+ | (0, x) :: iml => cut_iml iml
+ | (S i, x) :: iml => (i, x) :: cut_iml iml
+ end.
+
+ (* TODO move *)
+ Lemma interpret_inserts_cons {X} (iml : list (nat * X)) h l :
+ interpret_inserts iml (h :: l) =
+ (match lookup_iml iml 0 with | Some a => a | _ => h end) :: interpret_inserts (cut_iml iml) l.
+ Proof.
+ induction iml as [ | [i x] iml IH] in h, l |-*; simpl; first done.
+ rewrite IH. destruct i as [ | i]; simpl; done.
+ Qed.
+ Lemma interpret_iml_succ {X} len (def : X) (iml : list (nat * X)) :
+ interpret_iml def (S len) iml =
+ (match lookup_iml iml 0 with | Some a => a | _ => def end) :: interpret_iml def len (cut_iml iml).
+ Proof.
+ rewrite /interpret_iml/=. rewrite interpret_inserts_cons//.
+ Qed.
+
+ (* TODO move *)
+ Lemma big_sepL_prep_for_ind {A} (Φ : nat → A → iProp Σ) (l : list A) :
+ (∀ k, [∗ list] i ↦ x ∈ l, Φ (k + i) x) -∗
+ ([∗ list] i ↦ x ∈ l, Φ i x).
+ Proof.
+ iIntros "Ha". iApply ("Ha" $! 0).
+ Qed.
+ Lemma big_sepL2_prep_for_ind {A B} (Φ : nat → A → B → iProp Σ) (l1 : list A) (l2 : list B) :
+ (∀ k, [∗ list] i ↦ x; y ∈ l1; l2, Φ (k + i) x y) -∗
+ ([∗ list] i ↦ x; y ∈ l1; l2, Φ i x y).
+ Proof.
+ iIntros "Ha". iApply ("Ha" $! 0).
+ Qed.
+
+ Local Lemma array_ltype_incl_big_wand_in {rt1 rt2} k π F (def1 : type rt1) (def2 : type rt2) len (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) rs1 rs2 l b ly :
+ lftE ⊆ F →
+ length rs1 = len → length rs2 = len →
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1;lt2 ∈ zip (interpret_iml (◠def1) len lts1) rs1; zip (interpret_iml (◠def2) len lts2) rs2, ltype_incl b lt1.2 lt2.2 lt1.1 lt2.1) -∗
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def1) len lts1;rs1, ⌜ltype_st lt = ty_syn_type def1⌠∗ (l offset{ly}â‚— (k + i)%nat) â—â‚—[ Ï€, b] r0 @ lt) ={F}=∗
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def2) len lts2;rs2, ⌜ltype_st lt = ty_syn_type def2⌠∗ (l offset{ly}â‚— (k + i)%nat) â—â‚—[ Ï€, b] r0 @ lt).
+ Proof.
+ iIntros (? Hlen1 Hlen2 Hstdef) "#Hincl Ha".
+ iInduction len as [ | len] "IH" forall (k rs1 rs2 lts1 lts2 Hlen1 Hlen2); simpl.
+ { destruct rs2; last done. rewrite !interpret_iml_0 //. }
+ destruct rs2 as [ | r2 rs2]; first done.
+ destruct rs1 as [ | r1 rs1]; first done.
+ simpl.
+ rewrite !interpret_iml_succ. simpl.
+ iDestruct "Ha" as "((%Hsteq & Ha) & Hb)".
+ iDestruct "Hincl" as "(Hincl1 & Hincl)".
+ simpl in *.
+ iSpecialize ("IH" $! (S k) with "[] [] Hincl [Hb]").
+ { iPureIntro. lia. }
+ { iPureIntro. lia. }
+ { setoid_rewrite Nat.add_succ_r. done. }
+ iMod "IH" as "IH".
+ iPoseProof "Hincl1" as "(%Hst & _)".
+ iMod (ltype_incl_use with "Hincl1 Ha") as "$"; first done.
+ iSplitR. { rewrite -Hst -Hstdef. done. }
+ setoid_rewrite Nat.add_succ_r. done.
+ Qed.
+
+ Local Lemma array_ltype_incl_big_wand {rt} k π F (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) rs l b ly :
+ lftE ⊆ F →
+ length rs = len →
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1;lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2, ∀ r, ltype_incl b r r lt1 lt2) -∗
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def1) len lts1;rs, ⌜ltype_st lt = ty_syn_type def1⌠∗ (l offset{ly}â‚— (k + i)%nat) â—â‚—[ Ï€, b] r0 @ lt) ={F}=∗
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def2) len lts2;rs, ⌜ltype_st lt = ty_syn_type def2⌠∗ (l offset{ly}â‚— (k + i)%nat) â—â‚—[ Ï€, b] r0 @ lt).
+ Proof.
+ iIntros (? Hlen Hstdef) "#Hincl Ha".
+ iInduction len as [ | len] "IH" forall (k rs lts1 lts2 Hlen); simpl.
+ { destruct rs; last done. rewrite !interpret_iml_0 //. }
+ destruct rs as [ | r rs]; first done.
+ simpl.
+ rewrite !interpret_iml_succ. simpl.
+ iDestruct "Ha" as "((%Hsteq & Ha) & Hb)".
+ iDestruct "Hincl" as "(Hincl1 & Hincl)".
+ simpl in *.
+ setoid_rewrite Nat.add_succ_r.
+ iSpecialize ("IH" $! (S k) rs with "[] Hincl Hb").
+ { iPureIntro. lia. }
+ iMod "IH" as "IH".
+ iPoseProof ("Hincl1" $! r) as "(%Hst & _)".
+ iMod (ltype_incl_use with "Hincl1 Ha") as "$"; first done.
+ iSplitR. { rewrite -Hst -Hstdef. done. }
+ done.
+ Qed.
+
+ (* TODO move *)
+ Lemma zip_length {A B} (l1 : list A) (l2 : list B) :
+ length (zip l1 l2) = min (length l1) (length l2).
+ Proof.
+ induction l1 as [ | x l1 IH] in l2 |-*; destruct l2 as [ | y l2]; simpl; [done.. | ].
+ rewrite IH. done.
+ Qed.
+
+ Local Lemma array_ltype_incl'_shared_in {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) κ' rs1 rs2 :
+ ty_syn_type def1 = ty_syn_type def2 →
+ (⌜length rs1 = len⌠-∗ ⌜length rs2 = len⌠∗ ([∗ list] lt1; lt2 ∈ zip (interpret_iml (◠def1) len lts1) rs1; zip (interpret_iml (◠def2) len lts2) rs2,
+ ltype_incl (Shared κ') (lt1).2 (lt2).2 (lt1).1 (lt2).1)) -∗
+ ltype_incl' (Shared κ') #rs1 #rs2 (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Hel".
+ iModIntro. iIntros (Ï€ l) "Ha".
+ rewrite !ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Ha" as "(%ly & %Halg & %Hsz & %Hly & Hlb & %r' & <- & %Hlen & #Ha)".
+ iExists ly. iSplitR. { rewrite -Hst. done. }
+ iR. iR. iFrame. iExists rs2. iR.
+ iPoseProof ("Hel" with "[//]") as "Hc".
+ iDestruct "Hc" as "(%Hb & Hc)". iR.
+ iModIntro. iMod "Ha".
+ iMod (array_ltype_incl_big_wand_in 0 with "Hc Ha") as "Ha"; [done.. | ].
+ done.
+ Qed.
+ Lemma array_ltype_incl_shared_in {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) κ' rs1 rs2 :
+ ty_syn_type def1 = ty_syn_type def2 →
+ (⌜length rs1 = len⌠-∗ ⌜length rs2 = len⌠∗ [∗ list] lt1; lt2 ∈ zip (interpret_iml (◠def1) len lts1) rs1; zip (interpret_iml (◠def2) len lts2) rs2,
+ ltype_incl (Shared κ') (lt1).2 (lt2).2 (lt1).1 (lt2).1) -∗
+ ltype_incl (Shared κ') #rs1 #rs2 (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Heq".
+ iSplitR. { iPureIntro. simp_ltypes. rewrite Hst//. }
+ iModIntro. simp_ltypes.
+ iSplit; (iApply array_ltype_incl'_shared_in; first done).
+ - done.
+ - iIntros (Hlen'). iSpecialize ("Heq" with "[//]"). iDestruct "Heq" as "($ & Heq)".
+ rewrite -{2}(ltype_core_ofty def1) -{2}(ltype_core_ofty def2).
+ rewrite !interpret_iml_fmap.
+ rewrite !zip_fmap_l.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k [lt1 r1] [lt2 r2] ??). simpl. iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma array_ltype_incl'_shared {rt} (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) κ' rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_incl (Shared κ') r r lt1 lt2) -∗
+ ltype_incl' (Shared κ') rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Hel".
+ iModIntro. iIntros (Ï€ l) "Ha".
+ rewrite !ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Ha" as "(%ly & %Halg & %Hsz & %Hly & Hlb & %r' & Hrfn & %Hlen & #Ha)".
+ iExists ly. iSplitR. { rewrite -Hst. done. }
+ iR. iR. iFrame. iExists r'. iFrame. iR.
+ iPoseProof ("Hel" with "") as "Hc".
+ iModIntro. iMod "Ha".
+ iMod (array_ltype_incl_big_wand 0 with "Hc Ha") as "Ha"; [done.. | ].
+ done.
+ Qed.
+ Lemma array_ltype_incl_shared {rt} (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) κ' rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_incl (Shared κ') r r lt1 lt2) -∗
+ ltype_incl (Shared κ') rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Heq".
+ iSplitR. { iPureIntro. simp_ltypes. rewrite Hst//. }
+ iModIntro. simp_ltypes.
+ iSplit; (iApply array_ltype_incl'_shared; first done).
+ - done.
+ - rewrite -{2}(ltype_core_ofty def1) -{2}(ltype_core_ofty def2).
+ rewrite !interpret_iml_fmap.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k lt1 lt2 ??). simpl. iIntros "Ha" (?). iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma array_ltype_incl'_owned_in {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) wl rs1 rs2 :
+ ty_syn_type def1 = ty_syn_type def2 →
+ (⌜length rs1 = len⌠-∗ ⌜length rs2 = len⌠∗ [∗ list] lt1; lt2 ∈ zip (interpret_iml (◠def1) len lts1) rs1; zip (interpret_iml (◠def2) len lts2) rs2,
+ ltype_incl (Owned false) (lt1).2 (lt2).2 (lt1).1 (lt2).1) -∗
+ ltype_incl' (Owned wl) #rs1 #rs2 (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Hel".
+ iModIntro. iIntros (Ï€ l) "Ha".
+ rewrite !ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Ha" as "(%ly & %Halg & %Hsz & %Hly & Hlb & Hcred & %r' & <- & %Hlen & Ha)".
+ iExists ly. iSplitR. { rewrite -Hst. done. }
+ iR. iR. iFrame. iExists rs2. iR.
+ iPoseProof ("Hel" with "[//]") as "Hc".
+ iDestruct "Hc" as "(%Hb & Hc)". iR.
+ iModIntro. iNext. iMod "Ha".
+ iMod (array_ltype_incl_big_wand_in 0 with "Hc Ha") as "Ha"; [done.. | ].
+ done.
+ Qed.
+ Lemma array_ltype_incl_owned_in {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) wl rs1 rs2 :
+ ty_syn_type def1 = ty_syn_type def2 →
+ (⌜length rs1 = len⌠-∗ ⌜length rs2 = len⌠∗ [∗ list] lt1; lt2 ∈ zip (interpret_iml (◠def1) len lts1) rs1; zip (interpret_iml (◠def2) len lts2) rs2,
+ ltype_incl (Owned false) (lt1).2 (lt2).2 (lt1).1 (lt2).1) -∗
+ ltype_incl (Owned wl) #rs1 #rs2 (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Heq".
+ iSplitR. { iPureIntro. simp_ltypes. rewrite Hst//. }
+ iModIntro. simp_ltypes.
+ iSplit; (iApply array_ltype_incl'_owned_in; first done).
+ - done.
+ - iIntros (Hlen'). iSpecialize ("Heq" with "[//]"). iDestruct "Heq" as "(% & Heq)". iR.
+ rewrite -{2}(ltype_core_ofty def1) -{2}(ltype_core_ofty def2).
+ rewrite !interpret_iml_fmap.
+ rewrite !zip_fmap_l.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k [lt1 r1] [lt2 r2] ??). simpl. iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma array_ltype_incl'_owned {rt} (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) wl rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_incl (Owned false) r r lt1 lt2) -∗
+ ltype_incl' (Owned wl) rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Hel".
+ iModIntro. iIntros (Ï€ l) "Ha".
+ rewrite !ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Ha" as "(%ly & %Halg & %Hsz & %Hly & Hlb & Hcred & %r' & Hrfn & %Hlen & Ha)".
+ iExists ly. iSplitR. { rewrite -Hst. done. }
+ iR. iR. iFrame. iExists r'. iFrame. iR.
+ iPoseProof ("Hel" with "") as "Hc".
+ iModIntro. iNext. iMod "Ha".
+ iMod (array_ltype_incl_big_wand 0 with "Hc Ha") as "Ha"; [done.. | ].
+ done.
+ Qed.
+ Lemma array_ltype_incl_owned {rt} (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) wl rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_incl (Owned false) r r lt1 lt2) -∗
+ ltype_incl (Owned wl) rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Heq".
+ iSplitR. { iPureIntro. simp_ltypes. rewrite Hst//. }
+ iModIntro. simp_ltypes.
+ iSplit; (iApply array_ltype_incl'_owned; first done).
+ - done.
+ - rewrite -{2}(ltype_core_ofty def1) -{2}(ltype_core_ofty def2).
+ rewrite !interpret_iml_fmap.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k lt1 lt2 ??). simpl. iIntros "Ha" (?). iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma array_ltype_incl'_uniq {rt} (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) κ' γ rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_eq (Owned false) r r lt1 lt2) -∗
+ ltype_incl' (Uniq κ' γ) rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Hel".
+ iModIntro. iIntros (Ï€ l) "Ha".
+ rewrite !ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Ha" as "(%ly & %Halg & %Hsz & %Hly & Hlb & ? & ? & Hrfn & Ha)".
+ iExists ly. iSplitR. { rewrite -Hst. done. }
+ iR. iR. iFrame.
+ iMod "Ha". iModIntro.
+ iApply (pinned_bor_iff with "[] [] Ha"); iNext; iModIntro.
+ - iSplit; iIntros "(%r' & ? & % & Ha)"; iExists _; iFrame "∗%"; iMod "Ha";
+ (iMod (array_ltype_incl_big_wand 0 with "[Hel] Ha") as "Hx"; [done.. | | done ]).
+ + iApply (big_sepL2_mono with "Hel"). iIntros (?????) "Ha". iIntros (?). iDestruct ("Ha" $! _) as "($ & _)".
+ + rewrite big_sepL2_flip.
+ iApply (big_sepL2_mono with "Hel"). iIntros (?????) "Ha". iIntros (?). iDestruct ("Ha" $! _) as "(_ & $)".
+ - iSplit; iIntros "(%r' & ? & % & Ha)"; iExists _; iFrame "∗%"; iMod "Ha".
+ + setoid_rewrite ltype_own_core_equiv.
+
+ (*
+ iMod (array_ltype_incl_big_wand 0 with "[Hel] [Ha]") as "Hx".
+ 5: { iApply (big_sepL2_mono with "Ha"). iIntros (?????). iIntros "(? & ?)". iFrame.
+ simpl.
+ [done.. | | done ].
+ iApply (big_sepL2_mono with "Hel"). iIntros (?????) "Ha". iIntros (?). iDestruct ("Ha" $! _) as "($ & _)".
+ + rewrite big_sepL2_flip.
+ iApply (big_sepL2_mono with "Hel"). iIntros (?????) "Ha". iIntros (?). iDestruct ("Ha" $! _) as "(_ & $)".
+ done.
+ *)
+ Admitted.
+ Lemma array_ltype_incl_uniq {rt} (def1 : type rt) (def2 : type rt) len (lts1 : list (nat * ltype rt)) (lts2 : list (nat * ltype rt)) κ' γ rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_eq (Owned false) r r lt1 lt2) -∗
+ ltype_incl (Uniq κ' γ) rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (Hst) "#Heq".
+ iSplitR. { iPureIntro. simp_ltypes. rewrite Hst//. }
+ iModIntro. simp_ltypes.
+ iSplit; (iApply array_ltype_incl'_uniq; first done).
+ - done.
+ - rewrite -{2}(ltype_core_ofty def1) -{2}(ltype_core_ofty def2).
+ rewrite !interpret_iml_fmap.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k lt1 lt2 ??). simpl. iIntros "Ha" (?). iApply ltype_eq_core; done.
+ Qed.
+
+ Lemma array_ltype_incl {rt} (def1 def2 : type rt) len (lts1 lts2 : list (nat * ltype rt)) k rs :
+ ty_syn_type def1 = ty_syn_type def2 →
+ (∀ k, [∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2) len lts2,
+ ∀ r, ltype_eq k r r lt1 lt2) -∗
+ ltype_incl k rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (?) "#Heq".
+ destruct k.
+ - iApply array_ltype_incl_owned; first done.
+ iApply (big_sepL2_wand with "Heq"). iApply big_sepL2_intro.
+ { rewrite !interpret_iml_length//. }
+ iIntros "!>" (? lt1 lt2 ? ?) "Ha". iIntros (r).
+ iDestruct ("Ha" $! r) as "[$ _]".
+ - iApply array_ltype_incl_shared; first done.
+ iApply (big_sepL2_wand with "Heq"). iApply big_sepL2_intro.
+ { rewrite !interpret_iml_length//. }
+ iIntros "!>" (? lt1 lt2 ? ?) "Ha". iIntros (r).
+ iDestruct ("Ha" $! r) as "[$ _]".
+ - iApply array_ltype_incl_uniq; done.
+ Qed.
+
+ Lemma array_ltype_eq {rt} (def1 def2 : type rt) (lts1 lts2 : list (nat * ltype rt)) len rs k :
+ ty_syn_type def1 = ty_syn_type def2 →
+ (∀ k, [∗ list] lt1; lt2 ∈ (interpret_iml (◠def1) len lts1); (interpret_iml (◠def2) len lts2),
+ ∀ r, ltype_eq k r r lt1 lt2) -∗
+ ltype_eq k rs rs (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ iIntros (?) "#Heq".
+ iSplit.
+ - iApply array_ltype_incl; done.
+ - iApply array_ltype_incl; first done. iIntros (k').
+ iSpecialize ("Heq" $! k').
+ iApply big_sepL2_flip.
+ iApply (big_sepL2_wand with "Heq").
+ iApply big_sepL2_intro. { rewrite !interpret_iml_length//. }
+ iIntros "!>" (? ?? ??) "Heq'".
+ iIntros (?). iApply ltype_eq_sym. done.
+ Qed.
+
+ Lemma array_full_subltype E L {rt} (def1 def2 : type rt) (lts1 lts2 : list (nat * ltype rt)) len :
+ ty_syn_type def1 = ty_syn_type def2 →
+ Forall2 (λ lt1 lt2, full_eqltype E L lt1 lt2) (interpret_iml (◠def1) len lts1)%I (interpret_iml (◠def2)%I len lts2) →
+ full_subltype E L (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ intros ? Hsub.
+ iIntros (qL) "HL #CTX #HE".
+ iAssert (∀ k, [∗ list] lt1; lt2 ∈ interpret_iml (◠def1) len lts1; interpret_iml (◠def2)%I len lts2,
+ ∀ r, ltype_eq k r r lt1 lt2)%I with "[HL]" as "#Heq".
+ { iIntros (k).
+ iPoseProof (Forall2_big_sepL2 with "HL []") as "(Ha & HL)"; first apply Hsub.
+ { rewrite !interpret_iml_length. done. }
+ { iModIntro. iIntros (lt1 lt2) "HL %Heqt".
+ iPoseProof (Heqt with "HL CTX HE") as "#Ha". iFrame "HL". iApply "Ha". }
+ iApply (big_sepL2_mono with "Ha").
+ iIntros (??? ??) "#Heq". iIntros (r). iApply "Heq". }
+ iIntros (k r). iApply array_ltype_incl; done.
+ Qed.
+ Lemma array_full_eqltype E L {rt} (def1 def2 : type rt) len (lts1 lts2 : list (nat * ltype rt)) :
+ ty_syn_type def1 = ty_syn_type def2 →
+ Forall2 (λ lt1 lt2, full_eqltype E L lt1 lt2) (interpret_iml (◠def1) len lts1)%I (interpret_iml (◠def2)%I len lts2) →
+ full_eqltype E L (ArrayLtype def1 len lts1) (ArrayLtype def2 len lts2).
+ Proof.
+ intros ? Hsub.
+ apply full_subltype_eqltype; (eapply array_full_subltype; first done).
+ - done.
+ - rewrite Forall2_flip. eapply Forall2_impl; first done.
+ intros ??; naive_solver.
+ Qed.
+End subltype.
+
+
+Section unfold.
+ Context `{!typeGS Σ}.
+
+ Lemma array_t_unfold_1_owned {rt} wl (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' (Owned wl) rs rs (ArrayLtype ty len []) (◠(array_t ty len)).
+ Proof.
+ Admitted.
+
+ Lemma array_t_unfold_1_shared {rt} κ (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' (Shared κ) rs rs (ArrayLtype ty len []) (◠(array_t ty len)).
+ Proof.
+ Admitted.
+
+ Lemma array_t_unfold_1_uniq {rt} κ γ (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' (Uniq κ γ) rs rs (ArrayLtype ty len []) (◠(array_t ty len)).
+ Proof.
+ Admitted.
+
+ Local Lemma array_t_unfold_1' {rt} k (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' k rs rs (ArrayLtype ty len []) (◠(array_t ty len)).
+ Proof.
+ destruct k.
+ - by apply array_t_unfold_1_owned.
+ - by apply array_t_unfold_1_shared.
+ - by apply array_t_unfold_1_uniq.
+ Qed.
+
+ Lemma array_t_unfold_1 {rt} k (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl k rs rs (ArrayLtype ty len []) (◠(array_t ty len)).
+ Proof.
+ iModIntro.
+ iSplitR. { simp_ltypes. rewrite {2}/ty_syn_type /array_t //. }
+ iSplitR.
+ - by iApply array_t_unfold_1'.
+ - simp_ltypes. by iApply array_t_unfold_1'.
+ Qed.
+
+ Lemma array_t_unfold_2_owned {rt} wl (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' (Owned wl) rs rs (◠(array_t ty len)) (ArrayLtype ty len []).
+ Proof.
+ Admitted.
+
+ Lemma array_t_unfold_2_shared {rt} κ (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' (Shared κ) rs rs (◠(array_t ty len)) (ArrayLtype ty len []).
+ Proof.
+ Admitted.
+
+ Lemma array_t_unfold_2_uniq {rt} κ γ (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' (Uniq κ γ) rs rs (◠(array_t ty len)) (ArrayLtype ty len []).
+ Proof.
+ Admitted.
+
+ Local Lemma array_t_unfold_2' {rt} k (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl' k rs rs (◠(array_t ty len)) (ArrayLtype ty len []).
+ Proof.
+ destruct k.
+ - by apply array_t_unfold_2_owned.
+ - by apply array_t_unfold_2_shared.
+ - by apply array_t_unfold_2_uniq.
+ Qed.
+
+ Lemma array_t_unfold_2 {rt} k (ty : type rt) (len : nat) rs :
+ ⊢ ltype_incl k rs rs (◠(array_t ty len)) (ArrayLtype ty len []).
+ Proof.
+ iModIntro.
+ iSplitR. { simp_ltypes. rewrite {2}/ty_syn_type /array_t //. }
+ iSplitR.
+ - by iApply array_t_unfold_2'.
+ - simp_ltypes. by iApply array_t_unfold_2'.
+ Qed.
+
+ Lemma array_t_unfold {rt} k (ty : type rt) (len : nat) rs:
+ ⊢ ltype_eq k rs rs (◠(array_t ty len)) (ArrayLtype ty len []).
+ Proof.
+ iSplit.
+ - by iApply array_t_unfold_2.
+ - by iApply array_t_unfold_1.
+ Qed.
+
+ Lemma array_t_unfold_full_eqltype E L {rt} (ty : type rt) (len : nat) :
+ full_eqltype E L (â— (array_t ty len))%I (ArrayLtype ty len []).
+ Proof.
+ iIntros (?) "HL CTX HE". iIntros (??). iApply array_t_unfold.
+ Qed.
+End unfold.
+
+Section lemmas.
+ Context `{!typeGS Σ}.
+
+ Lemma array_t_rfn_length_eq π {rt} (ty : type rt) len r v :
+ v â—áµ¥{Ï€} r @ array_t ty len -∗ ⌜length r = lenâŒ.
+ Proof.
+ rewrite /ty_own_val/=. iIntros "(%ly & %Hst & % & $ & _)".
+ Qed.
+
+ (** Learnable *)
+ Global Program Instance learn_from_hyp_val_array {rt} (ty : type rt) xs len :
+ LearnFromHypVal (array_t ty len) xs :=
+ {| learn_from_hyp_val_Q := length xs = len |}.
+ Next Obligation.
+ iIntros (????????) "Hv".
+ iPoseProof (array_t_rfn_length_eq with "Hv") as "%Hlen".
+ by iFrame.
+ Qed.
+
+ (* TODO: possibly also prove these lemmas for location ownership? *)
+
+ Fixpoint delete_iml {X} i (iml : list (nat * X)) : list (nat * X) :=
+ match iml with
+ | [] => []
+ | (j, x) :: iml => if decide (i = j) then delete_iml i iml else (j, x) :: delete_iml i iml
+ end.
+
+ Lemma array_ltype_make_default {rt} (def : type rt) len lts i lt1 b r1 r2 :
+ (∀ b r, ltype_incl b r r lt1 (◠def)) -∗
+ ltype_incl b r1 r2 (ArrayLtype def len ((i, lt1) :: lts)) (ArrayLtype def len (delete_iml i lts)).
+ Proof.
+
+ Abort.
+
+ Lemma array_ltype_make_defaults {rt} (def : type rt) b r len lts :
+ ([∗ list] lt ∈ interpret_iml (◠def)%I len lts, ∀ b r, ltype_incl b r r lt (◠def)) -∗
+ ltype_incl b r r (ArrayLtype def len lts) (ArrayLtype def len []).
+ Proof.
+ iInduction lts as [ | [i lt] lts] "IH"; simpl.
+ { iIntros "_". iApply ltype_incl_refl. }
+ destruct i as [ | i]; simpl.
+ - destruct len; simpl.
+ + rewrite interpret_iml_0; simpl.
+ iIntros "_".
+ (* TODO *)
+ Admitted.
+
+ Lemma array_ltype_make_defaults_full_eqltype E L {rt} (def : type rt) len lts :
+ Forall (λ lt, full_eqltype E L lt (◠def)%I) (interpret_iml (◠def)%I len lts) →
+ full_eqltype E L (ArrayLtype def len lts) (ArrayLtype def len []).
+ Proof.
+ intros Ha. iIntros (?) "HL #CTX #HE". iIntros (??).
+ iPoseProof (Forall_big_sepL with "HL []") as "(Ha & HL)"; first apply Ha.
+ { iModIntro. iIntros (lt) "HL %Heqt". iPoseProof (Heqt with "HL CTX HE") as "#Heq".
+ iFrame "HL". iApply "Heq". }
+ iSplit.
+ - iApply array_ltype_make_defaults.
+ simpl.
+ (* TODO *)
+ Admitted.
+
+ Import EqNotations.
+ Lemma array_ltype_place_cond_ty b {rt rt'} (def : type rt) (def' : type rt') (len : nat) (lts : list (nat * ltype rt)) (lts' : list (nat * ltype rt')) :
+ place_access_rt_rel b rt rt' →
+ ty_syn_type def = ty_syn_type def' →
+ ([∗ list] lt; lt' ∈ interpret_iml (◠def) len lts; interpret_iml (◠def') len lts', typed_place_cond_ty b lt lt') -∗
+ typed_place_cond_ty b (ArrayLtype def len lts) (ArrayLtype def' len lts').
+ Proof.
+ iIntros (Hrel Hst). destruct b; simpl.
+ - iIntros "_". iPureIntro. simp_ltypes. rewrite Hst. done.
+ - iIntros "Hrel".
+ simpl in Hrel. subst rt'.
+ iExists eq_refl.
+ setoid_rewrite <-bi.sep_exist_r.
+ rewrite big_sepL2_sep_sepL_r. iDestruct "Hrel" as "(#Heq & #Hub)".
+ iSplitL.
+ + iIntros (k r). cbn. iApply array_ltype_eq; first done. iIntros (b').
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (? lt1 lt2 Hlook1 Hlook2). iIntros "(%Heq & Ha)".
+ rewrite (UIP_refl _ _ Heq). iIntros (?). iApply "Ha".
+ + iApply array_ltype_imp_unblockable. done.
+ - iIntros "Hrel".
+ simpl in Hrel. subst rt'.
+ iExists eq_refl.
+ setoid_rewrite <-bi.sep_exist_r.
+ rewrite big_sepL2_sep_sepL_r. iDestruct "Hrel" as "(#Heq & #Hub)".
+ iSplitL.
+ + cbn. simp_ltypes. iIntros (k r). iApply array_ltype_eq; first done. iIntros (k').
+ rewrite -{-1}(ltype_core_ofty def) -{-1}(ltype_core_ofty def').
+ rewrite !interpret_iml_fmap. rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (? lt1 lt2 Hlook1 Hlook2). iIntros "(%Heq & Ha)".
+ rewrite (UIP_refl _ _ Heq). iIntros (?). iApply "Ha".
+ + iApply array_ltype_imp_unblockable. done.
+ Qed.
+ Lemma array_ltype_place_cond_ty_strong wl {rt rt'} (def : type rt) (def' : type rt') (len : nat) (lts : list (nat * ltype rt)) (lts' : list (nat * ltype rt')) :
+ ty_syn_type def = ty_syn_type def' →
+ ⊢ typed_place_cond_ty (Owned wl) (ArrayLtype def len lts) (ArrayLtype def' len lts').
+ Proof.
+ iIntros (Hst). iPureIntro. simp_ltypes. rewrite Hst. done.
+ Qed.
+
+ Lemma array_ltype_acc_owned' {rt} F π (def : type rt) (len : nat) (lts : list (nat * ltype rt)) (rs : list (place_rfn rt)) l wl :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned wl] #rs @ ArrayLtype def len lts -∗
+ ∃ ly, ⌜syn_type_has_layout def.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` (mk_array_layout ly len)⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ (*⌜Forall (λ '(i, _), i < len) lts⌠∗*)
+ loc_in_bounds l 0 (ly.(ly_size) * len) ∗ |={F}=>
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def) len lts;rs, ⌜ltype_st lt = ty_syn_type def⌠∗ (l offset{ly}â‚— i) â—â‚—[Ï€, Owned false] r0 @ lt) ∗
+ (∀ (rt' : Type) (def' : type rt') (lts' : list (nat * ltype rt')) (rs' : list (place_rfn rt')),
+ (if wl then £1 else True) -∗
+ ⌜ty_syn_type def = ty_syn_type def'⌠-∗
+ (*⌜Forall (λ '(i, _), i < len) lts'⌠-∗*)
+ (* new ownership *)
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def') len lts';rs', ⌜ltype_st lt = ty_syn_type def'⌠∗ (l offset{ly}â‚— i) â—â‚—[Ï€, Owned false] r0 @ lt)
+ ={F}=∗
+ l â—â‚—[Ï€, Owned wl] #rs' @ ArrayLtype def' len lts').
+ Proof.
+ (* TODO *)
+ iIntros (?) "Hb". rewrite ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Hb" as "(%ly & %Hst & % & %Hly & #Hlb & Hcred & %r' & <- & <- & Hb)".
+ iExists ly. iR. iR. iR. iR.
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iModIntro. iFrame.
+ iIntros (rt' def' lts' rs') "Hcred' %Hst' Hb".
+ rewrite ltype_own_array_unfold /array_ltype_own.
+ iModIntro.
+ iExists ly. rewrite -Hst'. iR. iR. iR. iR. iFrame.
+ iSplitL "Hat Hcred Hcred'".
+ { destruct wl; last done. iFrame. rewrite /num_cred. iApply lc_succ. iFrame. }
+ iExists rs'. iR.
+ iPoseProof (big_sepL2_length with "Hb") as "%Hleneq".
+ rewrite interpret_iml_length in Hleneq. iR.
+ iNext. done.
+ Qed.
+
+ Lemma array_ltype_acc_owned {rt} F π (def : type rt) (len : nat) (lts : list (nat * ltype rt)) (rs : list (place_rfn rt)) l wl :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned wl] #rs @ ArrayLtype def len lts -∗
+ ∃ ly, ⌜syn_type_has_layout def.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` (mk_array_layout ly len)⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ (*⌜Forall (λ '(i, _), i < len) lts⌠∗*)
+ loc_in_bounds l 0 (ly.(ly_size) * len) ∗ |={F}=>
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def) len lts;rs, ⌜ltype_st lt = ty_syn_type def⌠∗ (l offset{ly}â‚— i) â—â‚—[Ï€, Owned false] r0 @ lt) ∗
+ logical_step F
+ (∀ (rt' : Type) (def' : type rt') (lts' : list (nat * ltype rt')) (rs' : list (place_rfn rt')),
+ ⌜ty_syn_type def = ty_syn_type def'⌠-∗
+ (*⌜Forall (λ '(i, _), i < len) lts'⌠-∗*)
+ (* new ownership *)
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def') len lts';rs', ⌜ltype_st lt = ty_syn_type def'⌠∗ (l offset{ly}â‚— i) â—â‚—[Ï€, Owned false] r0 @ lt)
+ ={F}=∗
+ l â—â‚—[Ï€, Owned wl] #rs' @ ArrayLtype def' len lts' ∗
+ (* place condition, if required *)
+ (∀ bmin,
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def) len lts; interpret_iml (◠def') len lts', typed_place_cond_ty bmin lt1 lt2) -∗
+ ([∗ list] r1; r2 ∈ rs; rs', typed_place_cond_rfn bmin r1 r2) -∗
+ ⌜place_access_rt_rel bmin rt rt'⌠-∗
+ typed_place_cond bmin (ArrayLtype def len lts) (ArrayLtype def' len lts') (#rs) (#rs'))).
+ Proof.
+ iIntros (?) "Hb". rewrite ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Hb" as "(%ly & %Hst & % & %Hly & #Hlb & Hcred & %r' & <- & <- & Hb)".
+ iExists ly. iR. iR. iR. iR.
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iModIntro. iFrame.
+ iApply (logical_step_intro_maybe with "Hat"). iIntros "Hcred' !>".
+ iIntros (rt' def' lts' rs') "%Hst' Hb".
+ iSplitL "Hb Hcred'".
+ { rewrite ltype_own_array_unfold /array_ltype_own.
+ iModIntro.
+ iExists ly. rewrite -Hst'. iR. iR. iR. iR. iFrame.
+ iExists rs'. iR.
+ iPoseProof (big_sepL2_length with "Hb") as "%Hleneq".
+ rewrite interpret_iml_length in Hleneq. iR.
+ iNext. done. }
+ (* place cond: *)
+ iModIntro.
+ iIntros (bmin) "Hcond_ty Hcond_rfn %Hrt".
+ rewrite /typed_place_cond.
+ iSplitL "Hcond_ty".
+ { iApply array_ltype_place_cond_ty; [done | done | done]. }
+ destruct bmin; simpl; [done | | done].
+ simpl in Hrt. subst rt'.
+ iExists eq_refl. iClear "Hlb Hcred". clear.
+ iInduction rs as [ | r1 rs IH] "IH" forall (rs'); destruct rs' as [ | r2 rs']; simpl; [done.. | ].
+ iDestruct "Hcond_rfn" as "(Hh & Hcond_rfn)".
+ iDestruct ("IH" with "Hcond_rfn") as "%Heq". injection Heq as <-.
+ iDestruct "Hh" as "(%Heq & %Heq2)".
+ rewrite -Heq2. rewrite (UIP_refl _ _ Heq). done.
+ Qed.
+
+ (* TODO: uniq access *)
+
+ Lemma array_ltype_acc_shared {rt} F π (def : type rt) (len : nat) (lts : list (nat * ltype rt)) (rs : list (place_rfn rt)) l κ :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Shared κ] #rs @ ArrayLtype def len lts -∗
+ ∃ ly, ⌜syn_type_has_layout def.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` (mk_array_layout ly len)⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ (*⌜Forall (λ '(i, _), i < len) lts⌠∗*)
+ loc_in_bounds l 0 (ly.(ly_size) * len) ∗ |={F}=>
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def) len lts;rs, ⌜ltype_st lt = ty_syn_type def⌠∗ (l offset{ly}â‚— i) â—â‚—[Ï€, Shared κ] r0 @ lt) ∗
+ (∀ (def' : type rt) (lts' : list (nat * ltype rt)),
+ ⌜ty_syn_type def = ty_syn_type def'⌠-∗
+ (*⌜Forall (λ '(i, _), i < len) lts'⌠-∗*)
+ (* new ownership *)
+ ([∗ list] i↦lt;r0 ∈ interpret_iml (â— def') len lts';rs, ⌜ltype_st lt = ty_syn_type def'⌠∗ (l offset{ly}â‚— i) â—â‚—[Ï€, Shared κ] r0 @ lt)
+ ={F}=∗
+ l â—â‚—[Ï€, Shared κ] #rs @ ArrayLtype def' len lts' ∗
+ (* place condition, if required *)
+ (∀ bmin,
+ ([∗ list] lt1; lt2 ∈ interpret_iml (◠def) len lts; interpret_iml (◠def') len lts', typed_place_cond_ty bmin lt1 lt2) -∗
+ typed_place_cond bmin (ArrayLtype def len lts) (ArrayLtype def' len lts') (#rs) (#rs))
+ ).
+ Proof.
+ iIntros (?) "Hb". rewrite ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Hb" as "(%ly & %Hst & % & %Hly & #Hlb & %r' & <- & <- & #Hb)".
+ iExists ly. iR. iR. iR. iR.
+ iMod (fupd_mask_mono with "Hb") as "#Hb'"; first done.
+ iModIntro. iFrame "Hb'".
+ iIntros (def' lts') "%Hst' #Hb''".
+ rewrite ltype_own_array_unfold /array_ltype_own.
+ iModIntro.
+ iSplitL.
+ { iExists ly. rewrite -Hst'. iR. iR. iR. iR.
+ iExists _. iR. iR. iModIntro. by iFrame "Hb''".
+ }
+ iIntros (bmin) "Hcond".
+ iSplitL; last iApply typed_place_cond_rfn_refl.
+ iApply array_ltype_place_cond_ty.
+ - apply place_access_rt_rel_refl.
+ - done.
+ - done.
+ Qed.
+End lemmas.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ (*TODO move *)
+ Lemma loc_in_bounds_array_offset len m k l ly :
+ k < len →
+ loc_in_bounds l m (ly_size ly * len) -∗
+ loc_in_bounds (l offset{ly}â‚— k) 0 (ly_size ly).
+ Proof.
+ iIntros (Hlen).
+ iApply loc_in_bounds_offset.
+ - done.
+ - simpl. rewrite /addr. lia.
+ - simpl.
+ rewrite -Z.add_assoc.
+ assert (ly_size ly * (k + 1) ≤ ly_size ly * len)%Z as Ha by nia.
+ rewrite Z.mul_add_distr_l Z.mul_1_r in Ha.
+ rewrite Nat2Z.inj_mul. eapply Zplus_le_compat_l. done.
+ Qed.
+
+ (* TODO move *)
+ Lemma insert_interpret_iml {X} (def : X) (len : nat) (iml : list (nat * X)) i x :
+ <[i := x]> (interpret_iml def len iml) = interpret_iml def len ((i, x) :: iml).
+ Proof. done. Qed.
+
+ (** ** typed_place *)
+ Lemma typed_place_array_owned π E L {rt rtv} (def : type rt) (lts : list (nat * ltype rt)) (len : nat) (rs : list (place_rfn rt)) wl bmin ly l it v (tyv : type rtv) (i : rtv) P T :
+ (∃ i',
+ ⌜syn_type_has_layout (ty_syn_type def) ly⌠∗
+ subsume_full E L false (v â—áµ¥{Ï€} i @ tyv) (v â—áµ¥{Ï€} i' @ int it) (λ L1 R2, R2 -∗
+ ⌜(0 ≤ i')%Z⌠∗ ⌜(i' < len)%Z⌠∗
+ ∀ lt r,
+ (* relies on Lithium's built-in simplification of lookups. *)
+ ⌜interpret_iml (◠def) len lts !! Z.to_nat i' = Some lt⌠-∗
+ ⌜rs !! Z.to_nat i' = Some r⌠-∗
+ (* sidecondition for other components *)
+ ⌜Forall (lctx_bor_kind_outlives E L1 bmin) (concat ((λ '(_, lt), ltype_blocked_lfts lt) <$> (lts)))⌠∗
+ typed_place π E L1 (l offsetst{ty_syn_type def}ₗ i') lt r bmin (Owned false) P (λ L2 κs li bi bmin2 rti ltyi ri strong weak,
+ T L2 κs li bi bmin2 rti ltyi ri None
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, ArrayLtype def len ((Z.to_nat i', weak.(weak_lt) lti2 ri2) :: lts))
+ (λ ri, #(<[Z.to_nat i' := weak.(weak_rfn) ri]> rs))
+ (weak.(weak_R))
+ ) weak))))
+ ⊢ typed_place π E L l (ArrayLtype def len lts) (#rs) bmin (Owned wl) (BinOpPCtx (PtrOffsetOp ly) (IntOp it) v rtv tyv i :: P) T.
+ Proof.
+ iIntros "(%i' & %Hst & HT)".
+ iIntros (????) "#CTX #HE HL #Hincl Hl Hcont".
+ simpl. iIntros "Hv".
+ iApply fupd_wp.
+ iMod ("HT" with "[] [] CTX HE HL Hv") as "(%L' & %R2 & >(Hi & R2) & HL & HT)"; [done.. | ].
+ iDestruct ("HT" with "R2") as "(% & % & HT)".
+ iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iPoseProof (array_ltype_acc_owned with "Hl") as "(%ly' & %Hst' & %Hly & %Hsz & #Hlb & >(Hb & Hcl))"; first done.
+ assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+ iMod "HclF" as "_".
+ iEval (rewrite /ty_own_val/=) in "Hi".
+ iDestruct "Hi" as "(%Hi & %Hiz)".
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply (wp_logical_step with "TIME Hcl"); [done.. | ].
+ iApply wp_ptr_offset.
+ { eapply val_to_of_loc. }
+ { done. }
+ { rewrite /elem_of/int_elem_of_it. split; last nia.
+ specialize (min_int_le_0 isize_t). lia. }
+ { iPoseProof (loc_in_bounds_array_offset _ _ (Z.to_nat i') with "Hlb") as "Hlb'"; first lia.
+ rewrite Z2Nat.id; last done.
+ iApply loc_in_bounds_shorten_suf; last done. lia. }
+ { iApply loc_in_bounds_shorten_suf; last done. lia. }
+ iModIntro. iNext. iIntros "Hcred Hcl".
+ iModIntro. iExists _. iR.
+ iPoseProof (big_sepL2_length with "Hb") as "%Hlen_eq".
+ rewrite interpret_iml_length in Hlen_eq.
+ clear i. set (i := Z.to_nat i').
+ destruct (lookup_lt_is_Some_2 (interpret_iml (â— def) len lts)%I i) as (lti & Hlook_lti).
+ { rewrite interpret_iml_length. lia. }
+ destruct (lookup_lt_is_Some_2 rs i) as (ri & Hlook_ri).
+ { lia. }
+ iPoseProof ("HT" $! lti ri with "[//] [//]") as "(%Houtl & HT)".
+ iPoseProof (lctx_bor_kind_outlives_all_use with "[//] HE HL") as "#Houtl".
+ iPoseProof (big_sepL2_insert_acc with "Hb") as "((%Hsti & Hb) & Hcl_b)"; [done | done | ].
+ iPoseProof ("HT" with "[//] [//] [$LFT $TIME $LLCTX] HE HL") as "Hc".
+ rewrite /OffsetLocSt/use_layout_alg' Hst/=.
+ rewrite /offset_loc.
+ iApply ("Hc" with "[] [Hb]").
+ { destruct bmin; done. }
+ { subst i. rewrite Z2Nat.id//. }
+ iIntros (L2 κs l2 b2 bmin0 rti ltyi ri' strong weak) "#Hincl1 Hi Hc".
+ iApply ("Hcont" with "[//] Hi").
+ iSplitR; first done. destruct weak as [ weak | ]; last done.
+ simpl. iIntros (ltyi2 ri2 bmin') "#Hincl2 Hi Hcond".
+ iDestruct "Hc" as "(_ & Hc)".
+ iMod ("Hc" with "[//] Hi Hcond") as "(Hi & Hcond & Htoks & HR)".
+ iPoseProof (typed_place_cond_syn_type_eq with "Hcond") as "%Hsteq".
+ iPoseProof ("Hcl_b" with "[Hi]") as "Hb".
+ { rewrite /i Z2Nat.id; last done. iFrame. rewrite -Hsteq//. }
+ rewrite insert_interpret_iml.
+ iMod ("Hcl" with "[//] Hb") as "(Hb & Hcondv)".
+ (*{ iPureIntro. rewrite Forall_cons. split; first lia. done. }*)
+ iFrame.
+ iModIntro.
+ iDestruct "Hcond" as "(Hcond & Hcond_rfn)".
+ iApply ("Hcondv" with "[Hcond] [Hcond_rfn] []").
+ - simpl.
+ rewrite -{1}(list_insert_id (interpret_iml _ _ _) i lti); last done.
+ rewrite (big_sepL2_insert _ _ _ _ _ (λ _ lt1 lt2, typed_place_cond_ty bmin lt1 lt2) 0); cycle 1.
+ { rewrite interpret_iml_length. lia. }
+ { rewrite interpret_iml_length. lia. }
+ iFrame. iApply big_sepL2_intro; first done.
+ iModIntro. iIntros (k lt1 lt2 Hlook ?). case_decide; first done.
+ assert (lt1 = lt2) as -> by congruence.
+ apply lookup_interpret_iml_Some_inv in Hlook as (? & [-> | Hel]).
+ { iApply typed_place_cond_ty_refl_ofty. }
+ apply elem_of_list_lookup_1 in Hel as (k' & Hlook).
+ iApply typed_place_cond_ty_refl.
+ iPoseProof (big_sepL_concat_lookup _ _ k' with "Houtl") as "Ha".
+ { rewrite list_lookup_fmap Hlook. done. }
+ done.
+ - rewrite -{1}(list_insert_id rs i ri); last done.
+ rewrite (big_sepL2_insert _ _ _ _ _ (λ _ r1 r2, _) 0); [ | lia..].
+ iSplitL; first done.
+ iApply big_sepL2_intro; first done. iModIntro.
+ iIntros (? r1 r2 ??). case_decide; first done.
+ assert (r1 = r2) as -> by congruence. iApply typed_place_cond_rfn_refl.
+ - iPureIntro. apply place_access_rt_rel_refl.
+ Qed.
+ Global Instance typed_place_array_owned_inst π E L {rt rtv} (def : type rt) (lts : list (nat * ltype rt)) (len : nat) (rs : list (place_rfn rt)) wl bmin ly l it v (tyv : type rtv) (i : rtv) P :
+ TypedPlace E L π l (ArrayLtype def len lts) (#rs) bmin (Owned wl) (BinOpPCtx (PtrOffsetOp ly) (IntOp it) v rtv tyv i :: P) | 30 :=
+ λ T, i2p (typed_place_array_owned π E L def lts len rs wl bmin ly l it v tyv i P T).
+
+ Lemma typed_place_array_uniq π E L {rt rtv} (def : type rt) (lts : list (nat * ltype rt)) (len : nat) (rs : list (place_rfn rt)) κ γ bmin ly l it v (tyv : type rtv) (i : rtv) P T :
+ (∃ i',
+ ⌜syn_type_has_layout (ty_syn_type def) ly⌠∗
+ subsume_full E L false (v â—áµ¥{Ï€} i @ tyv) (v â—áµ¥{Ï€} i' @ int it) (λ L1 R2, R2 -∗
+ ⌜(0 ≤ i')%Z⌠∗ ⌜(i' < len)%Z⌠∗
+ (* get lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L1 κ) (λ '(κs, L2),
+ ∀ lt r,
+ (* relies on Lithium's built-in simplification of lookups. *)
+ ⌜interpret_iml (◠def) len lts !! Z.to_nat i' = Some lt⌠-∗
+ ⌜rs !! Z.to_nat i' = Some r⌠-∗
+ (* sidecondition for other components *)
+ ⌜Forall (lctx_bor_kind_outlives E L1 bmin) (concat ((λ '(_, lt), ltype_blocked_lfts lt) <$> (lts)))⌠∗
+ typed_place π E L2 (l offsetst{ty_syn_type def}ₗ i') lt r bmin (Owned false) P (λ L3 κs' li bi bmin2 rti ltyi ri strong weak,
+ T L3 (κs ++ κs') li bi bmin2 rti ltyi ri None
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, ArrayLtype def len ((Z.to_nat i', weak.(weak_lt) lti2 ri2) :: lts))
+ (λ ri, #(<[Z.to_nat i' := weak.(weak_rfn) ri]> rs))
+ (weak.(weak_R))
+ ) weak)))))
+ ⊢ typed_place π E L l (ArrayLtype def len lts) (#rs) bmin (Uniq κ γ) (BinOpPCtx (PtrOffsetOp ly) (IntOp it) v rtv tyv i :: P) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance typed_place_array_uniq_inst π E L {rt rtv} (def : type rt) (lts : list (nat * ltype rt)) (len : nat) (rs : list (place_rfn rt)) κ γ bmin ly l it v (tyv : type rtv) (i : rtv) P :
+ TypedPlace E L π l (ArrayLtype def len lts) (#rs) bmin (Uniq κ γ) (BinOpPCtx (PtrOffsetOp ly) (IntOp it) v rtv tyv i :: P) | 30 :=
+ λ T, i2p (typed_place_array_uniq π E L def lts len rs κ γ bmin ly l it v tyv i P T).
+
+ (* TODO this is a problem, because we can only get strong below OpenedLtype etc.
+
+ *)
+ Lemma typed_place_array_shared π E L {rt rtv} (def : type rt) (lts : list (nat * ltype rt)) (len : nat) (rs : list (place_rfn rt)) κ bmin ly l it v (tyv : type rtv) (i : rtv) P T :
+ (∃ i',
+ ⌜syn_type_has_layout (ty_syn_type def) ly⌠∗
+ subsume_full E L false (v â—áµ¥{Ï€} i @ tyv) (v â—áµ¥{Ï€} i' @ int it) (λ L1 R2, R2 -∗
+ ⌜(0 ≤ i')%Z⌠∗ ⌜(i' < len)%Z⌠∗
+ (* get lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L1 κ) (λ '(κs, L2),
+ ∀ lt r,
+ (* relies on Lithium's built-in simplification of lookups. *)
+ ⌜interpret_iml (◠def) len lts !! Z.to_nat i' = Some lt⌠-∗
+ ⌜rs !! Z.to_nat i' = Some r⌠-∗
+ (* sidecondition for other components *)
+ ⌜Forall (lctx_bor_kind_outlives E L1 bmin) (concat ((λ '(_, lt), ltype_blocked_lfts lt) <$> (lts)))⌠∗
+ typed_place π E L2 (l offsetst{ty_syn_type def}ₗ i') lt r bmin (Owned false) P (λ L3 κs' li bi bmin2 rti ltyi ri strong weak,
+ T L3 (κs ++ κs') li bi bmin2 rti ltyi ri None
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, ArrayLtype def len ((Z.to_nat i', weak.(weak_lt) lti2 ri2) :: lts))
+ (λ ri, #(<[Z.to_nat i' := weak.(weak_rfn) ri]> rs))
+ (weak.(weak_R))
+ ) weak)))))
+ ⊢ typed_place π E L l (ArrayLtype def len lts) (#rs) bmin (Shared κ) (BinOpPCtx (PtrOffsetOp ly) (IntOp it) v rtv tyv i :: P) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance typed_place_array_shared_inst π E L {rt rtv} (def : type rt) (lts : list (nat * ltype rt)) (len : nat) (rs : list (place_rfn rt)) κ bmin ly l it v (tyv : type rtv) (i : rtv) P :
+ TypedPlace E L π l (ArrayLtype def len lts) (#rs) bmin (Shared κ) (BinOpPCtx (PtrOffsetOp ly) (IntOp it) v rtv tyv i :: P) | 30 :=
+ λ T, i2p (typed_place_array_shared π E L def lts len rs κ bmin ly l it v tyv i P T).
+
+ Lemma typed_place_array_unfold π E L l {rt} (def : type rt) len rs bmin k P T :
+ typed_place π E L l (ArrayLtype def len []) rs bmin k P T
+ ⊢ typed_place π E L l (◠array_t def len) rs bmin k P T.
+ Proof.
+ iIntros "HT". iApply typed_place_eqltype; last done.
+ apply array_t_unfold_full_eqltype.
+ Qed.
+ Global Instance typed_place_array_unfold_inst π E L l {rt} (def : type rt) len rs bmin k P :
+ TypedPlace E L π l (◠array_t def len)%I rs bmin k P | 20 :=
+ λ T, i2p (typed_place_array_unfold π E L l def len rs bmin k P T).
+
+ (** ** subtype instances *)
+
+ (* TODO: should this really match on the addition in the conclusion? probably not. *)
+ (*
+ Lemma subsume_full_array_split_goal :
+ subsume_full E L pers (l â—â‚—[Ï€, Owned false] r @ lt) (l â—â‚—[Ï€, Owned false] #(a1) @ â— array_t def (length a1)) (λ L R2,
+ prove_with_subtype E L pers (l +â‚— ... â—â‚—[Ï€, Owned false] #a2 @ â— array_t def (len - length a1)) T)
+ subsume_full E L pers (l â—â‚—[Ï€, Owned false] r @ lt) (l â—â‚—[Ï€, Owned false] #(a1 ++ a2) @ â— array_t def (len)) T.
+ *)
+ (* Alternative: do this splitting on prove_with_subtype for array values instead.
+ *)
+ (* Higher priority instance than direct search for the value: as a heuristic, we split app values *)
+ (* TODO: how would that scale to more complex transformations? E.g. what about take etc. -- I guess for that we could have instances as well.
+ Basically, I would imagine that we only want to look in the context for primitive values. *)
+ Lemma prove_with_subtype_array_val_split π E L pm v1 v2 {rt} (ty : type rt) r1 r2 (len : nat) T :
+ ⌜(size_of_st (ty_syn_type ty) * len ≤ max_int isize_t)%Z⌠∗
+ ⌜length r1 ≤ len⌠∗
+ prove_with_subtype E L false pm (v1 â—áµ¥{Ï€} r1 @ array_t ty (length r1)) (λ L2 κs1 R2,
+ prove_with_subtype E L2 false pm (v2 â—áµ¥{Ï€} r2 @ array_t ty (len - length r1)) (λ L3 κs2 R3, T L3 (κs1 ++ κs2) (R2 ∗ R3)%I))
+ ⊢ prove_with_subtype E L false pm ((v1 ++ v2) â—áµ¥{Ï€} r1 ++ r2 @ array_t ty len) T.
+ Proof.
+ iIntros "(% & % & HT)" (???) "#CTX #HE HL".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L2 & %κs1 & %R2 & >(Hv1 & HR2) & HL & HT)".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L3 & %κs2 & %R3 & >(Hv2 & HR3) & HL & HT)".
+ iModIntro. iExists L3, _, _. iFrame.
+ destruct pm.
+ - iEval (replace len with ((length r1) + (len - length r1)) by lia).
+ iApply (array_t_own_val_merge with "Hv1 Hv2").
+ nia.
+ - iModIntro. rewrite lft_dead_list_app. iIntros "(Hdead1 & Hdead2)".
+ iMod ("Hv1" with "Hdead1") as "Hv1". iMod ("Hv2" with "Hdead2") as "Hv2".
+ iEval (replace len with ((length r1) + (len - length r1)) by lia).
+ iApply (array_t_own_val_merge with "Hv1 Hv2").
+ nia.
+ Qed.
+ Global Instance prove_with_subtype_array_val_split_inst π E L pm v1 v2 {rt} (ty : type rt) r1 r2 (len : nat) :
+ ProveWithSubtype E L false pm ((v1 ++ v2) â—áµ¥{Ï€} r1 ++ r2 @ array_t ty len) | 20 :=
+ λ T, i2p (prove_with_subtype_array_val_split π E L pm v1 v2 ty r1 r2 len T).
+
+
+ (* TODO: we could strengthen this by taking into account the refinements *)
+ Lemma weak_subtype_array E L {rt} (ty1 ty2 : type rt) len1 len2 rs1 rs2 T :
+ ⌜len1 = len2⌠∗ ⌜rs1 = rs2⌠∗ mut_subtype E L ty1 ty2 T
+ ⊢ weak_subtype E L rs1 rs2 (array_t ty1 len1) (array_t ty2 len2) T.
+ Proof.
+ iIntros "(<- & <- & %Hsubt & HT)".
+ iIntros (??) "#CTX #HE HL". iPoseProof (full_subtype_acc with "HE HL") as "#Hincl"; first done.
+ iFrame. iApply array_t_type_incl. done.
+ Qed.
+ Global Instance weak_subtype_array_inst E L {rt} (ty1 ty2 : type rt) len1 len2 rs1 rs2 :
+ Subtype E L rs1 rs2 (array_t ty1 len1) (array_t ty2 len2) :=
+ λ T, i2p (weak_subtype_array E L ty1 ty2 len1 len2 rs1 rs2 T).
+
+ Lemma mut_subtype_array E L {rt} (ty1 ty2 : type rt) len1 len2 T :
+ ⌜len1 = len2⌠∗ mut_subtype E L ty1 ty2 T
+ ⊢ mut_subtype E L (array_t ty1 len1) (array_t ty2 len2) T.
+ Proof.
+ iIntros "(<- & %Hsubt & HT)".
+ iSplitR; last done. iPureIntro. by eapply array_t_full_subtype.
+ Qed.
+ Global Instance mut_subtype_array_inst E L {rt} (ty1 ty2 : type rt) len1 len2 :
+ MutSubtype E L (array_t ty1 len1) (array_t ty2 len2) :=
+ λ T, i2p (mut_subtype_array E L ty1 ty2 len1 len2 T).
+
+ Lemma mut_eqtype_array E L {rt} (ty1 ty2 : type rt) len1 len2 T :
+ ⌜len1 = len2⌠∗ mut_eqtype E L ty1 ty2 T
+ ⊢ mut_eqtype E L (array_t ty1 len1) (array_t ty2 len2) T.
+ Proof.
+ iIntros "(<- & %Hsubt & HT)".
+ iSplitR; last done. iPureIntro.
+ eapply full_subtype_eqtype.
+ - eapply array_t_full_subtype. by apply full_eqtype_subtype_l.
+ - eapply array_t_full_subtype. by apply full_eqtype_subtype_r.
+ Qed.
+ Global Instance mut_eqtype_array_inst E L {rt} (ty1 ty2 : type rt) len1 len2 :
+ MutEqtype E L (array_t ty1 len1) (array_t ty2 len2) :=
+ λ T, i2p (mut_eqtype_array E L ty1 ty2 len1 len2 T).
+
+ (** ** subltype *)
+
+ (* we use the [relate_list] mechanism *)
+ Program Definition weak_subltype_list_interp {rt1 rt2} (k : bor_kind) (rs1 : list (place_rfn rt1)) (rs2 : list (place_rfn rt2)) : FoldableRelation :=
+ {|
+ fr_rel (E : elctx) (L : llctx) (i : nat) (lt1 : (ltype rt1)) (lt2 : (ltype rt2)) (T : iProp Σ) :=
+ (∃ r1 r2, ⌜rs1 !! i = Some r1⌠∗ ⌜rs2 !! i = Some r2⌠∗ weak_subltype E L k r1 r2 lt1 lt2 T)%I;
+ fr_cap := length rs1;
+ fr_inv := length rs1 = length rs2;
+ fr_elim_mode := true;
+ fr_core_rel E L (i : nat) (lt1 : (ltype rt1)) (lt2 : (ltype rt2)) :=
+ (∃ r1 r2, ⌜rs1 !! i = Some r1⌠∗ ⌜rs2 !! i = Some r2⌠∗ ltype_incl k r1 r2 lt1 lt2)%I;
+ |}.
+ Next Obligation.
+ iIntros (??? rs1 rs2 E L i a b T ? ?) "#CTX #HE HL (%r1 & %r2 & %Hlook1 & %Hlook2 & Hsubt)".
+ iMod ("Hsubt" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iModIntro. eauto with iFrame.
+ Qed.
+ Global Typeclasses Opaque weak_subltype_list_interp.
+
+ (* options;
+ - require homogeneous and then use mut_subltype in the assumption
+ - what about array_t T <: array_t (maybe_uninit T)?
+ for that, would need a pattern on replicate there too.
+ this seems fine, but is difficult to implement. The problem is that we can't pattern on that easily. We'd first need to remove any leading inserts.
+ TODO: Probably have both, with the first one as fallback.
+ *)
+ Lemma weak_subltype_list_replicate_1 (E : elctx) (L : llctx) {rt} (k : bor_kind) (lt1 : ltype rt) (lt2 : ltype rt) rs1 rs2 n ig i0 T :
+ ⌜list_subequiv ig rs1 rs2⌠∗ mut_subltype E L lt1 lt2 T
+ ⊢ relate_list E L ig (replicate n lt1) (replicate n lt2) i0 (weak_subltype_list_interp k rs1 rs2) T.
+ Proof.
+ iIntros "(%Heq & %Hsubt & HT)".
+ iApply relate_list_replicate_elim_full; first done; last done.
+ simpl. iIntros "#CTX HE HL %Hlen".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hincl"; first done.
+ iModIntro. iIntros (i) "%Hlt %Hnel".
+ specialize (Heq i) as (? & Hi).
+ destruct (lookup_lt_is_Some_2 rs1 i) as (r1 & Hlook1). { lia. }
+ destruct (lookup_lt_is_Some_2 rs2 i) as (r2 & Hlook2). { lia. }
+ iExists r1, r2. iR. iR. assert (r1 = r2) as <-.
+ { specialize (Hi Hnel). congruence. }
+ iApply "Hincl".
+ Qed.
+ Global Instance weak_subltype_list_replicate_1_inst (E : elctx) (L : llctx) {rt} (k : bor_kind) (lt1 : ltype rt) (lt2 : ltype rt) rs1 rs2 n ig i0 :
+ RelateList E L ig (replicate n lt1) (replicate n lt2) i0 (weak_subltype_list_interp k rs1 rs2) :=
+ λ T, i2p (weak_subltype_list_replicate_1 E L k lt1 lt2 rs1 rs2 n ig i0 T).
+
+ Program Definition mut_subltype_list_interp {rt} (cap : nat) (interp : bool) : FoldableRelation :=
+ {|
+ fr_rel (E : elctx) (L : llctx) (i : nat) (lt1 : (ltype rt)) (lt2 : (ltype rt)) (T : iProp Σ) := (mut_subltype E L lt1 lt2 T)%I;
+ fr_cap := cap;
+ fr_inv := True;
+ fr_elim_mode := interp;
+ fr_core_rel (E : elctx) (L : llctx) (i : nat) (lt1 : (ltype rt)) (lt2 : (ltype rt)) :=
+ if interp then (∀ k r, ltype_incl k r r lt1 lt2)%I else ⌜full_subltype E L lt1 lt2âŒ%I;
+ |}.
+ Next Obligation.
+ iIntros (rt _ interp E L i a b). destruct interp.
+ - iIntros (???) "#CTX #HE HL (%Hsubt & $)".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#$"; first done.
+ by iFrame.
+ - iIntros (?) "(% & $)"; done.
+ Qed.
+ Global Typeclasses Opaque mut_subltype_list_interp.
+
+ Lemma mut_subltype_list_replicate (E : elctx) (L : llctx) {rt} (lt1 : ltype rt) (lt2 : ltype rt) cap interp n ig i0 T :
+ mut_subltype E L lt1 lt2 T
+ ⊢ relate_list E L ig (replicate n lt1) (replicate n lt2) i0 (mut_subltype_list_interp cap interp) T.
+ Proof.
+ iIntros "(%Hsubt & HT)". destruct interp.
+ - iApply relate_list_replicate_elim_full; first done; last done.
+ simpl. iIntros "#CTX HE HL _".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hincl"; first done.
+ iModIntro. iIntros (i) "%Hlt %Hnel". done.
+ - iApply relate_list_replicate_elim_weak; first done; last done.
+ simpl. iIntros "_". eauto.
+ Qed.
+ Global Instance mut_subltype_list_replicate_inst (E : elctx) (L : llctx) {rt} (lt1 : ltype rt) (lt2 : ltype rt) cap interp n ig i0 :
+ RelateList E L ig (replicate n lt1) (replicate n lt2) i0 (mut_subltype_list_interp cap interp) :=
+ λ T, i2p (mut_subltype_list_replicate E L lt1 lt2 cap interp n ig i0 T).
+
+ Program Definition mut_eqltype_list_interp {rt} (cap : nat) (interp : bool) : FoldableRelation :=
+ {|
+ fr_rel (E : elctx) (L : llctx) (i : nat) (lt1 : (ltype rt)) (lt2 : (ltype rt)) (T : iProp Σ) := (mut_eqltype E L lt1 lt2 T)%I;
+ fr_cap := cap;
+ fr_inv := True;
+ fr_elim_mode := interp;
+ fr_core_rel E L (i : nat) (lt1 : (ltype rt)) (lt2 : (ltype rt)) :=
+ if interp then (∀ k r, ltype_incl k r r lt1 lt2 ∗ ltype_incl k r r lt2 lt1)%I else ⌜full_eqltype E L lt1 lt2âŒ%I;
+ |}.
+ Next Obligation.
+ iIntros (rt _ interp E L i a b). destruct interp.
+ - iIntros (T ? ?) "#CTX #HE HL (%Hsubt & $)".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#$"; first done.
+ by iFrame.
+ - iIntros (T) "(%Heqt & $)". eauto.
+ Qed.
+ Global Typeclasses Opaque mut_eqltype_list_interp.
+
+ Lemma mut_eqltype_list_replicate (E : elctx) (L : llctx) {rt} (lt1 : ltype rt) (lt2 : ltype rt) cap interp n ig i0 T :
+ mut_eqltype E L lt1 lt2 T
+ ⊢ relate_list E L ig (replicate n lt1) (replicate n lt2) i0 (mut_eqltype_list_interp cap interp) T.
+ Proof.
+ iIntros "(%Hsubt & HT)". destruct interp.
+ - iApply relate_list_replicate_elim_full; first done; last done.
+ simpl. iIntros "#CTX HE HL _".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hincl"; first done.
+ iModIntro. iIntros (i) "%Hlt %Hnel". done.
+ - iApply relate_list_replicate_elim_weak; first done; last done.
+ simpl. iIntros "_". eauto.
+ Qed.
+ Global Instance mut_eqltype_list_replicate_inst (E : elctx) (L : llctx) {rt} (lt1 : ltype rt) (lt2 : ltype rt) cap interp n ig i0 :
+ RelateList E L ig (replicate n lt1) (replicate n lt2) i0 (mut_eqltype_list_interp cap interp) :=
+ λ T, i2p (mut_eqltype_list_replicate E L lt1 lt2 cap interp n ig i0 T).
+
+ Local Typeclasses Transparent weak_subltype_list_interp.
+ Local Typeclasses Transparent mut_subltype_list_interp.
+ Local Typeclasses Transparent mut_eqltype_list_interp.
+
+ Lemma weak_subltype_array_evar_def E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 k T :
+ ⌜def1 = def2⌠∗ weak_subltype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def1 len2 lts2) T
+ ⊢ weak_subltype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subltype_array_evar_def_inst E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 k `{!IsProtected def2} :
+ SubLtype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 8 :=
+ λ T, i2p (weak_subltype_array_evar_def E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 k T).
+
+ Lemma weak_subltype_array_evar_lts E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 k T :
+ ⌜lts1 = lts2⌠∗ weak_subltype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts1) T
+ ⊢ weak_subltype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subltype_array_evar_lts_inst E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 k `{!IsProtected lts2} :
+ SubLtype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 9 :=
+ λ T, i2p (weak_subltype_array_evar_lts E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 k T).
+
+ Lemma weak_subltype_array_owned_in E L {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) rs1 rs2 wl T :
+ (⌜len1 = len2⌠∗
+ ∃ rs2', ⌜rs2 = #rs2'⌠∗
+ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (â— def1) len1 lts1) (interpret_iml (â— def2) len1 lts2) 0 (weak_subltype_list_interp (Owned false) rs1 rs2') (
+ ⌜length rs2' = len1⌠∗ T))
+ ⊢ weak_subltype E L (Owned wl) #rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & %rs2' & -> & %Hst & HT)". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & (%Hlen' & $))".
+ iModIntro.
+ iApply array_ltype_incl_owned_in; first done.
+ simpl. iIntros (?). rewrite interpret_iml_length.
+ iSpecialize ("Ha" with "[] []"). { iPureIntro. lia. } {iPureIntro. lia. }
+ iR.
+ Admitted.
+ Global Instance weak_subltype_array_owned_in_inst E L {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) rs1 rs2 wl :
+ SubLtype E L (Owned wl) #rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) |10 :=
+ λ T, i2p (weak_subltype_array_owned_in E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 wl T).
+
+ Lemma weak_subltype_array_owned E L {rt1 } (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 wl T :
+ (⌜len1 = len2⌠∗ ⌜rs1 = rs2⌠∗ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (â— def1) len1 lts1) (interpret_iml (â— def2) len1 lts2) 0 (mut_subltype_list_interp len1 true) T)
+ ⊢ weak_subltype E L (Owned wl) rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & <- & %Hst & HT)". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro.
+ iApply array_ltype_incl_owned; first done.
+ simpl. rewrite interpret_iml_length.
+ iSpecialize ("Ha" with "[] [//]"). { iPureIntro. lia. }
+ iApply (big_sepL2_mono with "Ha"). eauto.
+ Qed.
+ Global Instance weak_subltype_array_owned_inst E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 wl :
+ SubLtype E L (Owned wl) rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) |11 :=
+ λ T, i2p (weak_subltype_array_owned E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 wl T).
+
+ Lemma weak_subltype_array_shared_in E L {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) rs1 rs2 κ T :
+ (⌜len1 = len2⌠∗
+ ∃ rs2', ⌜rs2 = #rs2'⌠∗
+ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (◠def1) len1 lts1) (interpret_iml (◠def2) len1 lts2) 0 (weak_subltype_list_interp (Shared κ) rs1 rs2') (
+ ⌜length rs2' = len1⌠∗ T))
+ ⊢ weak_subltype E L (Shared κ) #rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & %rs2' & -> & %Hst & HT)". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & (%Hlen' & $))".
+ iModIntro.
+ iApply array_ltype_incl_shared_in; first done.
+ simpl. iIntros (?). rewrite interpret_iml_length.
+ iSpecialize ("Ha" with "[] []"). { iPureIntro. lia. } {iPureIntro. lia. }
+ iR.
+ Admitted.
+ Global Instance weak_subltype_array_shared_in_inst E L {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt2)) rs1 rs2 κ :
+ SubLtype E L (Shared κ) #rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) |10 :=
+ λ T, i2p (weak_subltype_array_shared_in E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 κ T).
+
+ Lemma weak_subltype_array_shared E L {rt1 } (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 κ T :
+ (⌜len1 = len2⌠∗ ⌜rs1 = rs2⌠∗ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (â— def1) len1 lts1) (interpret_iml (â— def2) len1 lts2) 0 (mut_subltype_list_interp len1 true) T)
+ ⊢ weak_subltype E L (Shared κ) rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & <- & %Hst & HT)". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro.
+ iApply array_ltype_incl_shared; first done.
+ simpl. rewrite interpret_iml_length.
+ iSpecialize ("Ha" with "[] [//]"). { iPureIntro. lia. }
+ iApply (big_sepL2_mono with "Ha"). eauto.
+ Qed.
+ Global Instance weak_subltype_array_shared_inst E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 κ :
+ SubLtype E L (Shared κ) rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) |11 :=
+ λ T, i2p (weak_subltype_array_shared E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 κ T).
+
+ Lemma weak_subltype_array_base E L {rt1 } (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 κ γ T :
+ (⌜len1 = len2⌠∗ ⌜rs1 = rs2⌠∗ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (â— def1) len1 lts1) (interpret_iml (â— def2) len1 lts2) 0 (mut_eqltype_list_interp len1 true) T)
+ ⊢ weak_subltype E L (Uniq κ γ) rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & <- & %Hst & HT)". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro.
+ iApply array_ltype_incl_uniq; first done.
+ simpl. rewrite interpret_iml_length.
+ iSpecialize ("Ha" with "[] [//]"). { iPureIntro. lia. }
+ iApply (big_sepL2_mono with "Ha"). eauto.
+ Qed.
+ Global Instance weak_subltype_array_base_inst E L {rt1} (def1 : type rt1) (def2 : type rt1) len1 len2 (lts1 : list (nat * ltype rt1)) (lts2 : list (nat * ltype rt1)) rs1 rs2 κ γ :
+ SubLtype E L (Uniq κ γ) rs1 rs2 (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 20 :=
+ λ T, i2p (weak_subltype_array_base E L def1 def2 len1 len2 lts1 lts2 rs1 rs2 κ γ T).
+
+ (* for folding : *)
+ Program Definition fold_overrides_list_interp {rt} (def : type rt) (cap : nat) (req : bool) : FoldablePredicate :=
+ {|
+ fp_pred (E : elctx) (L : llctx) (i : nat) (lt : ltype rt) (T : iProp Σ) :=
+ if req then mut_subltype E L lt (â— def)%I T else mut_eqltype E L lt (â— def)%I T;
+ fp_cap := cap;
+ fp_inv := True;
+ fp_elim_mode := req;
+ fp_core_pred E L (i : nat) (lt : ltype rt) :=
+ if req then (∀ k r, ltype_incl k r r lt (â— def))%I else ⌜full_eqltype E L lt (â— def)âŒ%I;
+ |}.
+ Next Obligation.
+ iIntros (rt def ? req E L i lt). destruct req.
+ - iIntros (T ??) "#CTX #HE HL (%Hsubt & $)".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hincl"; first apply Hsubt.
+ iModIntro. iFrame. done.
+ - iIntros (T) "(%Heqt & $)". done.
+ Qed.
+ Global Typeclasses Opaque fold_overrides_list_interp.
+ Lemma fold_overrides_list_replicate {rt} E L (def : type rt) (lt : ltype rt) n ig i0 cap (req : bool) T :
+ (if req then mut_subltype E L lt (â— def) T else mut_eqltype E L lt (â— def) T)
+ ⊢ fold_list E L ig (replicate n lt) i0 (fold_overrides_list_interp def cap req) T.
+ Proof.
+ destruct req; iIntros "(%Hsubt & HT)".
+ - iApply fold_list_replicate_elim_full; first done; last done.
+ simpl. iIntros "#CTX #HE HL _".
+ iPoseProof (full_subltype_acc with "CTX HE HL")as "#Hincl"; first apply Hsubt.
+ iModIntro. iIntros (i ? k r). iApply "Hincl".
+ - iApply fold_list_replicate_elim_weak; first done; last done.
+ simpl. iIntros "_". eauto.
+ Qed.
+ Global Instance fold_overrides_list_replicate_inst {rt} E L (def : type rt) (lt : ltype rt) n ig i0 cap req :
+ FoldList E L ig (replicate n lt) i0 (fold_overrides_list_interp def cap req) | 20 :=
+ λ T, i2p (fold_overrides_list_replicate E L def lt n ig i0 cap req T).
+ Local Typeclasses Transparent fold_overrides_list_interp.
+
+ Lemma weak_subltype_array_ofty_r E L {rt1} (def1 : type rt1) ty len1 (lts1 : list (nat * ltype rt1)) rs1 rs2 k T :
+ ⌜rs1 = rs2⌠∗ mut_eqtype E L (array_t def1 len1) ty
+ (fold_list E L [] (interpret_iml (â— def1) len1 lts1) 0 (fold_overrides_list_interp def1 len1 true) T)
+ ⊢ weak_subltype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (◠ty) T.
+ Proof.
+ iIntros "(-> & %Hsubt & Hf)".
+ iIntros (??) "#CTX #HE HL".
+ iMod ("Hf" with "[//] CTX HE HL") as "(Ha & HL & $)".
+ simpl. iSpecialize ("Ha" with "[] []").
+ { simpl. rewrite interpret_iml_length. iPureIntro. lia. }
+ { simpl. done. }
+ iDestruct "Ha" as "#Ha".
+ specialize (full_eqtype_subltype _ _ _ _ Hsubt) as Hs.
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hb"; first apply Hs.
+ iFrame. simpl.
+ iModIntro. iApply ltype_incl_trans.
+ { iApply (array_ltype_make_defaults). done. }
+ iApply ltype_incl_trans.
+ { iApply array_t_unfold_1. }
+ iApply "Hb".
+ Qed.
+ Global Instance weak_subltype_array_ofty_r_inst E L {rt1} (def1 : type rt1) ty len1 (lts1 : list (nat * ltype rt1)) rs1 rs2 k :
+ SubLtype E L k rs1 rs2 (ArrayLtype def1 len1 lts1) (â— ty)%I | 14 :=
+ λ T, i2p (weak_subltype_array_ofty_r E L def1 ty len1 lts1 rs1 rs2 k T).
+
+ Lemma weak_subltype_array_ofty_l E L {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len1 len2 (lts2 : list (nat * ltype rt2)) rs1 rs2 k T :
+ weak_subltype E L k rs1 rs2 (ArrayLtype def1 len1 []) (ArrayLtype def2 len2 lts2) T
+ ⊢ weak_subltype E L k rs1 rs2 (◠array_t def1 len1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "Hsubt" (??) "#CTX #HE HL".
+ iMod ("Hsubt" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. iApply ltype_incl_trans; last done.
+ iApply array_t_unfold_2.
+ Qed.
+ Global Instance weak_subltype_array_ofty_l_inst E L {rt1 rt2} (def1 : type rt1) (def2 : type rt2) len1 len2 (lts2 : list (nat * ltype rt2)) rs1 rs2 k :
+ SubLtype E L k rs1 rs2 (â— array_t def1 len1)%I (ArrayLtype def2 len2 lts2) | 14 :=
+ λ T, i2p (weak_subltype_array_ofty_l E L def1 def2 len1 len2 lts2 rs1 rs2 k T).
+
+
+ (* TODO move *)
+ Lemma big_sepL2_Forall2 {A B} (Φ : A → B → Prop) l1 l2 :
+ ([∗ list] x;y ∈ l1; l2, ⌜Φ x yâŒ) -∗ ⌜Forall2 Φ l1 l2⌠: iProp Σ.
+ Proof.
+ iIntros "Ha". iInduction l1 as [ | x l1] "IH" forall (l2) "Ha"; destruct l2 as [ | y l2]; simpl; [done.. | ].
+ iDestruct "Ha" as "(%Ha & Hb)". iPoseProof ("IH" with "Hb") as "%Hc".
+ iPureIntro. constructor; done.
+ Qed.
+ Lemma big_sepL_Forall {A} (Φ : A → Prop) l :
+ ([∗ list] x ∈ l, ⌜Φ xâŒ) -∗ ⌜Forall Φ l⌠: iProp Σ.
+ Proof.
+ iIntros "Ha". iInduction l as [ | x l] "IH"; simpl; first done.
+ iDestruct "Ha" as "(%Ha & Hb)". iPoseProof ("IH" with "Hb") as "%Hc".
+ iPureIntro. constructor; done.
+ Qed.
+
+ (** mut_subltype *)
+ Lemma mut_subltype_array E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) T:
+ ⌜len1 = len2⌠∗ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (â— def1) len1 lts1) (interpret_iml (â— def2) len2 lts2) 0 (mut_eqltype_list_interp len1 false) T
+ ⊢ mut_subltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & %Hst & Hrel)".
+ iPoseProof "Hrel" as "(Hr & $)".
+ simpl. iSpecialize ("Hr" with "[] [//]").
+ { rewrite interpret_iml_length. iPureIntro. lia. }
+ iPoseProof (big_sepL2_Forall2 with "Hr") as "%Ha".
+ iPureIntro. eapply array_full_subltype; done.
+ Qed.
+ Global Instance mut_subltype_array_inst E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) :
+ MutSubLtype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 10 :=
+ λ T, i2p (mut_subltype_array E L def1 def2 len1 len2 lts1 lts2 T).
+
+ (* evar handling *)
+ Lemma mut_subltype_array_evar_def E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) T `{!IsProtected def2} :
+ ⌜def1 = def2⌠∗ mut_subltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def1 len2 lts2) T
+ ⊢ mut_subltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_subltype_array_evar_def_inst E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) `{!IsProtected def2} :
+ MutSubLtype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 8 := λ T, i2p (mut_subltype_array_evar_def E L def1 def2 len1 len2 lts1 lts2 T).
+
+ Lemma mut_subltype_array_evar_lts E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) T `{!IsProtected lts2} :
+ ⌜lts1 = lts2⌠∗ mut_subltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts1) T
+ ⊢ mut_subltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_subltype_array_evar_lts_inst E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) `{!IsProtected lts2} :
+ MutSubLtype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 9 := λ T, i2p (mut_subltype_array_evar_lts E L def1 def2 len1 len2 lts1 lts2 T).
+
+ (* ofty unfolding *)
+ Lemma mut_subltype_array_ofty_r E L {rt} (def1 : type rt) len1 lts1 ty T :
+ mut_eqtype E L (array_t def1 len1) ty (fold_list E L [] (interpret_iml (â— def1) len1 lts1) 0 (fold_overrides_list_interp def1 len1 false) T)
+ ⊢ mut_subltype E L (ArrayLtype def1 len1 lts1) (◠ty) T.
+ Proof.
+ iIntros "(%Heqt & Ha & $)".
+ iSpecialize ("Ha" with "[] [//]"); simpl. { rewrite interpret_iml_length. iPureIntro. lia. }
+ iPoseProof (big_sepL_Forall with "Ha") as "%Ha".
+ iPureIntro. eapply full_eqltype_subltype_l.
+ etrans; first last. { apply full_eqtype_eqltype; last apply Heqt. apply _. }
+ trans (ArrayLtype def1 len1 []); first last.
+ { symmetry. eapply array_t_unfold_full_eqltype. }
+ apply array_ltype_make_defaults_full_eqltype. done.
+ Qed.
+ Global Instance mut_subltype_array_ofty_r_inst E L {rt} (def1 : type rt) len1 lts1 ty :
+ MutSubLtype E L (ArrayLtype def1 len1 lts1)%I (â— ty)%I | 14 :=
+ λ T, i2p (mut_subltype_array_ofty_r E L def1 len1 lts1 ty T).
+
+ Lemma mut_subltype_array_ofty_l E L {rt} (def1 : type rt) (def2 : type rt) len1 len2 (lts2 : list (nat * ltype rt)) T :
+ mut_subltype E L (ArrayLtype def1 len1 []) (ArrayLtype def2 len2 lts2) T
+ ⊢ mut_subltype E L (◠array_t def1 len1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(%Hsubt & $)".
+ iPureIntro. etrans; last apply Hsubt.
+ apply full_eqltype_subltype_l.
+ apply array_t_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_array_ofty_l_inst E L {rt} (def1 : type rt) (def2 : type rt) len1 len2 (lts2 : list (nat * ltype rt)) :
+ MutSubLtype E L (â— array_t def1 len1)%I (ArrayLtype def2 len2 lts2) | 14 :=
+ λ T, i2p (mut_subltype_array_ofty_l E L def1 def2 len1 len2 lts2 T).
+
+ (** eqltype *)
+ Lemma mut_eqltype_array E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) T:
+ ⌜len1 = len2⌠∗ ⌜ty_syn_type def1 = ty_syn_type def2⌠∗
+ relate_list E L [] (interpret_iml (â— def1) len1 lts1) (interpret_iml (â— def2) len2 lts2) 0 (mut_eqltype_list_interp len1 false) T
+ ⊢ mut_eqltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(<- & %Hst & Hrel)".
+ iPoseProof "Hrel" as "(Hr & $)".
+ simpl. iSpecialize ("Hr" with "[] [//]").
+ { rewrite interpret_iml_length. iPureIntro. lia. }
+ iPoseProof (big_sepL2_Forall2 with "Hr") as "%Ha".
+ iPureIntro. eapply array_full_eqltype; done.
+ Qed.
+ Global Instance mut_eqltype_array_inst E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) :
+ MutEqLtype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 10 :=
+ λ T, i2p (mut_eqltype_array E L def1 def2 len1 len2 lts1 lts2 T).
+
+ (* evar handling *)
+ Lemma mut_eqltype_array_evar_def E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) T `{!IsProtected def2} :
+ ⌜def1 = def2⌠∗ mut_eqltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def1 len2 lts2) T
+ ⊢ mut_eqltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_eqltype_array_evar_def_inst E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) `{!IsProtected def2} :
+ MutEqLtype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 8 := λ T, i2p (mut_eqltype_array_evar_def E L def1 def2 len1 len2 lts1 lts2 T).
+
+ Lemma mut_eqltype_array_evar_lts E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) T `{!IsProtected lts2} :
+ ⌜lts1 = lts2⌠∗ mut_eqltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts1) T
+ ⊢ mut_eqltype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_eqltype_array_evar_lts_inst E L {rt} (def1 def2 : type rt) len1 len2 (lts1 lts2 : list (nat * ltype rt)) `{!IsProtected lts2} :
+ MutEqLtype E L (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) | 9 := λ T, i2p (mut_eqltype_array_evar_lts E L def1 def2 len1 len2 lts1 lts2 T).
+
+ Lemma mut_eqltype_array_ofty_r E L {rt} (def1 : type rt) len1 lts1 ty T :
+ mut_eqtype E L (array_t def1 len1) ty (fold_list E L [] (interpret_iml (â— def1) len1 lts1) 0 (fold_overrides_list_interp def1 len1 false) T)
+ ⊢ mut_eqltype E L (ArrayLtype def1 len1 lts1) (◠ty) T.
+ Proof.
+ iIntros "(%Heqt & Ha & $)".
+ iSpecialize ("Ha" with "[] [//]"); simpl. { rewrite interpret_iml_length. iPureIntro. lia. }
+ iPoseProof (big_sepL_Forall with "Ha") as "%Ha".
+ iPureIntro.
+ etrans; first last. { apply full_eqtype_eqltype; last apply Heqt. apply _. }
+ trans (ArrayLtype def1 len1 []); first last.
+ { symmetry. eapply array_t_unfold_full_eqltype. }
+ apply array_ltype_make_defaults_full_eqltype. done.
+ Qed.
+ Global Instance mut_eqltype_array_ofty_r_inst E L {rt} (def1 : type rt) len1 lts1 ty :
+ MutEqLtype E L (ArrayLtype def1 len1 lts1)%I (â— ty)%I | 14 :=
+ λ T, i2p (mut_eqltype_array_ofty_r E L def1 len1 lts1 ty T).
+
+ Lemma mut_eqltype_array_ofty_l E L {rt} (def1 : type rt) (def2 : type rt) len1 len2 (lts2 : list (nat * ltype rt)) T :
+ mut_eqltype E L (ArrayLtype def1 len1 []) (ArrayLtype def2 len2 lts2) T
+ ⊢ mut_eqltype E L (◠array_t def1 len1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ iIntros "(%Hsubt & $)".
+ iPureIntro. etrans; last apply Hsubt.
+ apply array_t_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_array_ofty_l_inst E L {rt} (def1 : type rt) (def2 : type rt) len1 len2 (lts2 : list (nat * ltype rt)) :
+ MutEqLtype E L (â— array_t def1 len1)%I (ArrayLtype def2 len2 lts2) | 14 :=
+ λ T, i2p (mut_eqltype_array_ofty_l E L def1 def2 len1 len2 lts2 T).
+
+ (** Owned subtype for initialization *)
+ Lemma owned_subtype_uninit_array π E L pers {rt} (ty : type rt) (st : syn_type) len r2 T :
+ li_tactic (compute_layout_goal st) (λ ly1,
+ li_tactic (compute_layout_goal (ty_syn_type ty)) (λ ly2,
+ ⌜(ly_size ly1 = ly_size ly2 * len)%nat⌠∗
+ owned_subtype π E L pers (replicate len #()) r2 (array_t (uninit (ty_syn_type ty)) len) (array_t ty len) T))
+ ⊢ owned_subtype π E L pers () r2 (uninit st) (array_t ty len) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly1 & %Halg1 & %ly2 & %Halg2 & %Hszeq & HT)".
+ iIntros (???) "#CTX #HE HL".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & Hincl & ? & ?)".
+ iExists L'. iModIntro. iFrame.
+ iAssert (owned_type_incl π (replicate len # ()) r2 (array_t (uninit (ty_syn_type ty)) len) (array_t ty len) -∗ owned_type_incl π () r2 (uninit st) (array_t ty len))%I as "Hw"; first last.
+ { destruct pers.
+ { simpl. iDestruct "Hincl" as "#Hincl". iModIntro. by iApply "Hw". }
+ { simpl. by iApply "Hw". } }
+ iIntros "Hincl". iDestruct "Hincl" as "(%Hszeq' & _ & Hv)".
+ iSplitR; last iSplitR.
+ - iPureIntro. intros ly3 ly4 Hst1 Hst2.
+ simpl in *.
+ assert (ly3 = ly1) as -> by by eapply syn_type_has_layout_inj.
+ rewrite Hszeq.
+ specialize (syn_type_has_layout_array_inv _ _ _ Hst2) as (ly2' & Hst2' & -> & ?).
+ assert (ly2' = ly2) as -> by by eapply syn_type_has_layout_inj.
+ done.
+ - simpl; done.
+ - iIntros (v) "Hun".
+ iApply "Hv".
+ rewrite /ty_own_val/=.
+ iDestruct "Hun" as "(%ly0 & %Hly0 & %Hlyv0 & _)".
+ assert (ly0 = ly1) as -> by by eapply syn_type_has_layout_inj.
+ iExists _. iR.
+ iSplitR. { iPureIntro. apply (use_layout_alg_size) in Hly0. lia. }
+ rewrite replicate_length. iR.
+ iSplitR. { rewrite /has_layout_val/mk_array_layout/ly_mult /= -Hszeq. done. }
+ iApply big_sepL2_intro.
+ { rewrite reshape_length !replicate_length//. }
+ iModIntro. iIntros (k ?? Hlook1 Hlook2).
+ apply lookup_replicate in Hlook1 as (-> & ?).
+ iExists _. iR.
+ rewrite uninit_own_spec.
+ iExists _. iR.
+ iPureIntro. rewrite /has_layout_val.
+ apply elem_of_list_lookup_2 in Hlook2.
+ apply reshape_replicate_elem_length in Hlook2; first done.
+ rewrite Hlyv0. lia.
+ Qed.
+ Global Instance owned_subtype_uninit_array_inst π E L pers {rt} (ty : type rt) st len r2 :
+ OwnedSubtype π E L pers () r2 (uninit st) (array_t ty len) :=
+ λ T, i2p (owned_subtype_uninit_array π E L pers ty st len r2 T).
+
+ Lemma owned_subtype_array π E L pers {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) len r1 r2 T :
+ (∃ r1' r2', ⌜r1 = replicate len #r1'⌠∗ ⌜r2 = replicate len #r2'⌠∗
+ ⌜syn_type_is_layoutable (ty_syn_type ty2)⌠∗
+ owned_subtype π E L true r1' r2' ty1 ty2 T)
+ ⊢ owned_subtype π E L pers r1 r2 (array_t ty1 len) (array_t ty2 len) T.
+ Proof.
+ iIntros "(%r1' & %r2' & -> & -> & %Hly' & HT)".
+ destruct Hly' as (ly' & Hst').
+ iIntros (???) "#CTX #HE HL".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & #Hincl & ? & ?)".
+ iModIntro. iExists L'. iFrame.
+ iApply bi.intuitionistically_intuitionistically_if. iModIntro.
+ iDestruct "Hincl" as "(%Hszeq & Hsceq & Hv)".
+ iSplitR; last iSplitR.
+ - iPureIntro. simpl. intros ly1 ly2 Hst1 Hst2.
+ apply syn_type_has_layout_array_inv in Hst1 as (ly1' & Hst1 & -> & ?).
+ apply syn_type_has_layout_array_inv in Hst2 as (ly2' & Hst2 & -> & ?).
+ rewrite /mk_array_layout/ly_mult/=.
+ specialize (Hszeq _ _ Hst1 Hst2) as ->. done.
+ - simpl. done.
+ - iIntros (v) "Ha".
+ rewrite {3 4}/ty_own_val /=.
+ iDestruct "Ha" as "(%ly & %Hst1 & % & <- & %Hvly & Ha)".
+ iExists _. iR.
+ assert (ly_size ly = ly_size ly') as Hlysz. { eapply Hszeq; done. }
+ rewrite -Hlysz replicate_length. iR.
+ rewrite replicate_length. iR.
+ iSplitR. { iPureIntro. rewrite /has_layout_val/mk_array_layout/ly_mult/=. rewrite -Hlysz.
+ rewrite replicate_length in Hvly. done. }
+ clear.
+ iInduction len as [ | len] "IH" forall (v); simpl; first done.
+ iDestruct "Ha" as "((%r1 & -> & Ha) & Hr)".
+ iPoseProof ("IH" with "Hr") as "$".
+ iExists _. iR. by iApply "Hv".
+ Qed.
+ Global Instance owned_subtype_array_inst π E L pers {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) len r1 r2 :
+ OwnedSubtype π E L pers r1 r2 (array_t ty1 len) (array_t ty2 len) :=
+ λ T, i2p (owned_subtype_array π E L pers ty1 ty2 len r1 r2 T).
+
+
+ (** ** stratify_ltype *)
+ (* 1. stratify all components
+ -> Then have the new ArrayLtype.
+ 2. 1) If we should fold fully: subltype the core of this new array type to â— array_t (if it contains blocked things), and fold to Coreable (array_t).
+ Or subtype it directly to array_t if it doesn't contain blocked things.
+ 2) Otherwise, leave the ArrayLtype as-is.
+
+ Should stratify go to coreable (i.e., bubble blocked things up), even if it wasn't Opened previously?
+ -> we should not stratify to coreable, as that imposes information loss. Would be an issue for dropping of local variables.
+
+
+ //
+ What happens to mut ref unfolding below?
+ - We might have an OpenedLtype with homogeneous refinement.
+ - this might get turned to coreable.
+ - we need to fold all of them. if one of them doesn't go to the designated type, we need to go to coreable ourselves.
+ (this is like bubbling up)
+ Do we need this?
+ - Rust's native indexing/dereferencing does use dedicated functions on mutrefs (really on slices).
+ So also the drop/overwrite thing would go via an indirection.
+ - Do we need it in unsafe use cases where we really directly work with the array type?
+ + for Vec/VecDeque, we don't need that.
+ *)
+
+ Definition stratify_ltype_array_iter_cont_t (rt : Type) := llctx → iProp Σ → list (nat * ltype rt) → list (place_rfn rt) → iProp Σ.
+ Definition stratify_ltype_array_iter (π : thread_id) (E : elctx) (L : llctx) (mu : StratifyMutabilityMode) (md : StratifyDescendUnfoldMode) (ma : StratifyAscendMode) {M} (m : M) (l : loc) (ig : list nat) {rt} (def : type rt) (len : nat) (iml : list (nat * ltype rt)) (rs : list (place_rfn rt)) (k : bor_kind) (T : stratify_ltype_array_iter_cont_t rt) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗
+ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ([∗ list] i ↦ lt; r ∈ interpret_iml (◠def)%I len iml; rs,
+ if decide (i ∉ ig) then (⌜ltype_st lt = ty_syn_type def⌠∗ (l offsetst{ty_syn_type def}â‚— i) â—â‚—[Ï€, k] r @ lt) else True) ={F}=∗
+ ∃ (L' : llctx) (R' : iProp Σ) (iml' : list (nat * ltype rt)) (rs' : list (place_rfn rt)),
+ ⌜length rs' = length rs⌠∗
+ logical_step F (([∗ list] i ↦ lt; r ∈ interpret_iml (â— def)%I len iml'; rs', if decide (i ∉ ig) then (⌜ltype_st lt = ty_syn_type def⌠∗ (l offsetst{ty_syn_type def}â‚— i) â—â‚—[Ï€, k] r @ lt) else True) ∗ R') ∗
+ llctx_interp L' ∗
+ T L' R' iml' rs'.
+ Class StratifyLtypeArrayIter (Ï€ : thread_id) (E : elctx) (L : llctx) (mu : StratifyMutabilityMode) (md : StratifyDescendUnfoldMode) (ma : StratifyAscendMode) {M} (m : M) (l : loc) (ig : list nat) {rt} (def : type rt) (len : nat) (iml : list (nat * ltype rt)) (rs : list (place_rfn rt)) (k : bor_kind) : Type :=
+ stratify_ltype_array_iter_proof T : iProp_to_Prop (stratify_ltype_array_iter π E L mu md ma m l ig def len iml rs k T).
+ Global Hint Mode StratifyLtypeArrayIter + + + + + + + + + + + + + + + + : typeclass_instances.
+
+ Lemma stratify_ltype_array_iter_nil π E L mu md ma {M} (m : M) (l : loc) {rt} (def : type rt) (len : nat) (rs : list (place_rfn rt)) k ig (T : stratify_ltype_array_iter_cont_t rt) :
+ T L True [] rs
+ ⊢ stratify_ltype_array_iter π E L mu md ma m l ig def len [] rs k T.
+ Proof.
+ iIntros "HT". iIntros (???) "#CTX #HE HL Hl".
+ iModIntro. iExists L, True%I, [], rs.
+ iFrame. simpl. iR. iApply logical_step_intro; eauto.
+ Qed.
+ Global Instance stratify_ltype_array_iter_nil_inst π E L mu md ma {M} (m : M) (l : loc) {rt} (def : type rt) (len : nat) (rs : list (place_rfn rt)) k ig :
+ StratifyLtypeArrayIter π E L mu md ma m l ig def len [] rs k := λ T, i2p (stratify_ltype_array_iter_nil π E L mu md ma m l def len rs k ig T).
+
+ Import EqNotations.
+ Lemma stratify_ltype_array_iter_cons_no_ignore π E L mu mdu ma {M} (m : M) (l : loc) (ig : list nat) {rt} (def : type rt) (rs : list (place_rfn rt)) (len : nat) (iml : list (nat * ltype rt)) (lt : ltype rt) j k T `{Hnel : !CanSolve (j ∉ ig)%nat} :
+ ⌜j < len⌠∗ (∀ r, ⌜rs !! j = Some r⌠-∗
+ stratify_ltype_array_iter π E L mu mdu ma m l (j :: ig) def len iml rs k (λ L2 R2 iml2 rs2,
+ stratify_ltype π E L2 mu mdu ma m (l offsetst{ty_syn_type def}ₗ j) lt r k (λ L3 R3 rt3 lty3 r3,
+ match ltype_blocked_lfts lty3 with
+ | [] =>
+ (* directly fold completely *)
+ ∃ r4, weak_subltype E L3 k r3 r4 lty3 (◠def) (T L3 (R3 ∗ R2) ((j, ◠def) :: iml2) (<[j := r4]> rs2))
+ | _ =>
+ (* we directly try to go to Coreable here in order to use the syntactic hint by [def] on which refinement type we need to go to.
+ If arrays supported heterogeneous refinements, we could also defer this. *)
+ (*∃ (Heq : rt3 = rt), T L3 (R3 ∗ R2) ((j, rew Heq in lty3) :: iml2) (<[j := rew Heq in r3]> rs2)*)
+ ⌜if k is Owned _ then True else False⌠∗ (* we cannot have blocked lfts below shared; TODO: also allow Uniq *)
+ ∃ r4, weak_subltype E L3 k r3 r4 (ltype_core lty3) (◠def) (T L3 (R3 ∗ R2) ((j, CoreableLtype (ltype_blocked_lfts lty3) (◠def)) :: iml2) (<[j := r4]> rs2))
+ end)))
+ ⊢ stratify_ltype_array_iter π E L mu mdu ma m l ig def len ((j, lt) :: iml) rs k T.
+ Proof.
+ iIntros "(%Hlen & HT)". iIntros (???) "#CTX #HE HL Hl".
+ simpl.
+ iPoseProof (big_sepL2_length with "Hl") as "%Hlen'".
+ rewrite insert_length interpret_iml_length in Hlen'. subst len.
+ edestruct (lookup_lt_is_Some_2 rs j) as (r & Hlook); first done.
+ rewrite -{5}(list_insert_id _ _ _ Hlook).
+
+ iPoseProof (big_sepL2_insert (interpret_iml (â— def)%I (length rs) iml) rs j lt r (λ i lt r, if decide (i ∉ ig) then (⌜ltype_st lt = ty_syn_type def⌠∗ (l offsetst{ty_syn_type def}â‚— i) â—â‚—[ Ï€, k] r @ lt) else True)%I 0) as "(Ha & _)".
+ { rewrite interpret_iml_length. done. }
+ { done. }
+ iDestruct ("Ha" with "Hl") as "(Hl & Hl2)". iClear "Ha".
+ simpl.
+ iMod ("HT" with "[//] [//] [//] CTX HE HL [Hl2]") as "(%L2' & %R2' & %iml2 & %rs2 & %Hleneq & Hstep & HL & HT)".
+ { iApply (big_sepL2_mono with "Hl2"). intros ? ? ? Hlook1 Hlook2.
+ case_decide.
+ { subst. iIntros "_". rewrite decide_False; first done. set_solver. }
+ iIntros "Ha". case_decide.
+ - rewrite decide_True; first done. set_solver.
+ - rewrite decide_False; first done. set_solver. }
+ unfold CanSolve in *. rewrite decide_True; last set_solver.
+ iDestruct "Hl" as "(%Hst & Hl)".
+ iMod ("HT" with "[//] [//] CTX HE HL Hl") as "(%L3 & %R3 & %rt' & %lt' & %r' & HL & %Hst' & Hstep' & HT)".
+ destruct (ltype_blocked_lfts lt') eqn:Hbl.
+ - iDestruct "HT" as "(%r4 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & HT)".
+ iDestruct "Hincl" as "(%Hsteq & Hincl & _)".
+ iExists _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. rewrite insert_length//. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iApply (logical_step_compose with "Hstep'").
+ iApply logical_step_intro.
+ iIntros "!> (Hl & $) (Hl2 & $)".
+ simpl.
+ iPoseProof (big_sepL2_insert (interpret_iml (â— def)%I (length rs2) iml2) rs2 j (â— def)%I r4 (λ i lt r, if decide (i ∉ ig) then (⌜ltype_st lt = ty_syn_type def⌠∗ (l offsetst{ty_syn_type def}â‚— i) â—â‚—[ Ï€, k] r @ lt) else True)%I 0) as "(_ & Ha)".
+ { rewrite interpret_iml_length. lia. }
+ { lia. }
+ iMod (ltype_incl'_use with "Hincl Hl") as "Hl"; first done.
+ rewrite -Hleneq. iApply "Ha".
+ iSplitL "Hl".
+ { rewrite decide_True; last set_solver. iFrame. rewrite -Hsteq -Hst'. done. }
+ iApply (big_sepL2_mono with "Hl2").
+ iIntros (k0 ? ? Hlook1 Hlook2) "Ha".
+ destruct (decide (k0 = j)); first done.
+ simpl. destruct (decide (k0 ∉ ig)); last done.
+ rewrite decide_True; last set_solver. done.
+ - (* *)
+ iDestruct "HT" as "(%Hown & %r4 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & HT)".
+ iDestruct "Hincl" as "(%Hsteq & Hincl & _)".
+ iExists _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. rewrite insert_length//. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iApply (logical_step_compose with "Hstep'").
+ iApply logical_step_intro.
+ iIntros "!> (Hl & $) (Hl2 & $)".
+ simpl.
+ iPoseProof (big_sepL2_insert (interpret_iml (â— def)%I (length rs2) iml2) rs2 j (CoreableLtype (ltype_blocked_lfts lt') (â— def))%I r4 (λ i lt r, if decide (i ∉ ig) then (⌜ltype_st lt = ty_syn_type def⌠∗ (l offsetst{ty_syn_type def}â‚— i) â—â‚—[ Ï€, k] r @ lt) else True)%I 0) as "(_ & Ha)".
+ { rewrite interpret_iml_length. lia. }
+ { lia. }
+ rewrite -Hleneq -Hbl. iApply "Ha". iClear "Ha".
+ iSplitL "Hl".
+ + iModIntro. rewrite decide_True; last set_solver.
+ simp_ltypes. iR.
+ destruct k as [ wl | |]; [ | done..].
+ (* TODO this should also work for Uniq -- the only problem is that we need to split it up into the observation. Maybe we should just have a generic lemma for that for all ltypes. *)
+ rewrite ltype_own_coreable_unfold /coreable_ltype_own.
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Halg & %Hly)".
+ iPoseProof (ltype_own_loc_in_bounds with "Hl") as "#Hlb"; first done.
+ iExists ly. simp_ltypes.
+ match goal with H : ty_syn_type def = ltype_st lt' |- _ => rename H into Hsteq end.
+ rewrite Hsteq. iR.
+ simpl. rewrite -Hsteq. iR. iR.
+ iIntros "Hdead".
+ iPoseProof (imp_unblockable_blocked_dead lt') as "(_ & #Himp)".
+ iMod ("Himp" with "Hdead Hl") as "Hl". rewrite !ltype_own_core_equiv.
+ iMod (ltype_incl'_use with "Hincl Hl") as "Hl"; first done.
+ simp_ltypes. done.
+ + iApply (big_sepL2_mono with "Hl2").
+ iIntros (k0 ? ? Hlook1 Hlook2) "Ha".
+ destruct (decide (k0 = j)); first done.
+ simpl. destruct (decide (k0 ∉ ig)); last done.
+ rewrite decide_True; last set_solver. done.
+ Qed.
+ Global Instance stratify_ltype_array_iter_cons_no_ignore_inst π E L mu md ma {M} (m : M) (l : loc) ig {rt} (def : type rt) (len : nat) (rs : list (place_rfn rt)) iml lt (j : nat) k `{Hnel : !CanSolve (j ∉ ig)%nat} :
+ StratifyLtypeArrayIter π E L mu md ma m l ig def len ((j, lt) :: iml) rs k := λ T, i2p (stratify_ltype_array_iter_cons_no_ignore π E L mu md ma m l ig def rs len iml lt j k T).
+
+ Lemma stratify_ltype_array_iter_cons_ignore π E L mu mdu ma {M} (m : M) (l : loc) (ig : list nat) {rt} (def : type rt) (rs : list (place_rfn rt)) (len : nat) (iml : list (nat * ltype rt)) (lt : ltype rt) j k T `{Hnel : !CanSolve (j ∈ ig)%nat} :
+ ⌜j < len⌠∗ stratify_ltype_array_iter π E L mu mdu ma m l (ig) def len iml rs k T
+ ⊢ stratify_ltype_array_iter π E L mu mdu ma m l ig def len ((j, lt) :: iml) rs k T.
+ Proof.
+ iIntros "(%Hlen & HT)". iIntros (???) "#CTX #HE HL Hl".
+ unfold CanSolve in *.
+ iPoseProof (big_sepL2_length with "Hl") as "%Hlen'".
+ rewrite insert_length interpret_iml_length in Hlen'. subst len.
+ iMod ("HT" with "[//] [//] CTX HE HL [Hl]") as "(%L2 & %R2 & %iml2 & %rs2 & %Hleneq & Hstep & HL & HT)".
+ { edestruct (lookup_lt_is_Some_2 rs j) as (r & Hlook). { lia. }
+ rewrite -{2}(list_insert_id _ _ _ Hlook).
+ simpl.
+ iPoseProof (big_sepL2_insert (interpret_iml (â— def)%I (length rs) iml) rs j lt r (λ i lt r, if decide (i ∉ ig) then (⌜ltype_st lt = ty_syn_type def⌠∗ (l offsetst{ty_syn_type def}â‚— i) â—â‚—[ Ï€, k] r @ lt) else True)%I 0) as "(Ha & _)".
+ { rewrite interpret_iml_length. done. }
+ { done. }
+ iDestruct ("Ha" with "Hl") as "(_ & Hl)". iClear "Ha".
+ iApply (big_sepL2_mono with "Hl"). iIntros (??? Hlook1 Hlook2) "Ha".
+ case_decide. { rewrite decide_False; first done. set_solver. }
+ simpl. done.
+ }
+ iExists _, _, _, _. iFrame.
+ done.
+ Qed.
+ Global Instance stratify_ltype_array_iter_cons_ignore_inst π E L mu md ma {M} (m : M) (l : loc) ig {rt} (def : type rt) (len : nat) (rs : list (place_rfn rt)) iml lt (j : nat) k `{Hnel : !CanSolve (j ∈ ig)%nat} :
+ StratifyLtypeArrayIter π E L mu md ma m l ig def len ((j, lt) :: iml) rs k := λ T, i2p (stratify_ltype_array_iter_cons_ignore π E L mu md ma m l ig def rs len iml lt j k T).
+
+ Lemma stratify_ltype_array_owned {rt} π E L mu mdu ma {M} (m : M) l (def : type rt) len iml rs wl (T : stratify_ltype_cont_t) :
+ stratify_ltype_array_iter π E L mu mdu ma m l [] def len iml rs (Owned false) (λ L2 R2 iml2 rs2,
+ T L2 R2 _ (ArrayLtype def len iml2) (#rs2))
+ ⊢ stratify_ltype π E L mu mdu ma m l (ArrayLtype def len iml) (#rs) (Owned wl) T.
+ Proof.
+ iIntros "HT". iIntros (???) "#CTX #HE HL Hl".
+ rewrite ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hsz & %Hly & Hlb & Hcreds & %r' & <- & %Hlen & Hl)". subst len.
+ iMod (maybe_use_credit with "Hcreds Hl") as "(Hcred & Hat & Hl)"; first done.
+ iMod ("HT" with "[//] [//] CTX HE HL [Hl]") as "(%L2 & %R2 & %iml2 & %rs2 & %Hleneq & Hstep & HL & HT)".
+ { iApply (big_sepL2_mono with "Hl"). intros ? ? ? HLook1 Hlook2.
+ rewrite /OffsetLocSt /use_layout_alg' Halg/=. done. }
+ iModIntro. iExists L2, R2, _, _, _. iFrame. simp_ltypes. iR.
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred2 !> (Ha & $)".
+ iModIntro.
+ rewrite ltype_own_array_unfold /array_ltype_own.
+ iExists _. iFrame "∗%".
+ iExists _. iR. iR. iNext.
+ iApply (big_sepL2_mono with "Ha").
+ intros ??? Hlook1 Hlook2.
+ rewrite /OffsetLocSt /use_layout_alg' Halg/=. done.
+ Qed.
+ Global Instance stratify_ltype_array_owned_inst {rt} π E L mu mdu ma {M} (m : M) l (def : type rt) len iml rs wl :
+ StratifyLtype π E L mu mdu ma m l (ArrayLtype def len iml) (#rs) (Owned wl) :=
+ λ T, i2p (stratify_ltype_array_owned π E L mu mdu ma m l def len iml rs wl T).
+
+ (* TODO Uniq *)
+
+ (** ** prove_place_cond instances *)
+ (* TODO: should probably augment FoldableRelation to be able to pass something to the continuation. *)
+ (*
+ Program Definition prove_place_cond_list_interp {rt1 rt2} (k : bor_kind) (len : nat) : FoldableRelation :=
+ {|
+ fr_rel (E : elctx) (L : llctx) (i : nat) (lt1 : (ltype rt1)) (lt2 : (ltype rt2)) (T : iProp Σ) :=
+ (prove_place_cond E L k lt1 lt2 (λ upd, T))%I;
+ fr_cap := len;
+ fr_inv := True;
+ fr_core_rel (E : elctx) (L : llctx) (i : nat) (lt1 : (ltype rt1)) (lt2 : (ltype rt2)) :=
+ (∃ upd : access_result rt1 rt2,
+ match upd with
+ | ResultWeak _ => typed_place_cond_ty k lt1 lt2
+ | ResultStrong => ⌜ltype_st lt1 = ltype_st lt2âŒ%I
+ end)%I
+ |}.
+ Next Obligation.
+ iIntros (???? ? E L i a b T ?) "#CTX #HE HL Hcond".
+ iMod ("Hcond" with "[//] CTX HE HL") as "($ & Hincl)".
+ iDestruct "Hincl" as "(%upd & ? & $)".
+ iModIntro. eauto with iFrame.
+ Qed.
+ Global Typeclasses Opaque prove_place_cond_list_interp.
+ *)
+
+ (* These need to have a lower priority than the ofty_refl instance (level 2) and the unblocking instances (level 5), but higher than the trivial "no" instance *)
+ (* TODO: similar unfolding for array
+ Lemma prove_place_cond_unfold_mut_l E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k T :
+ prove_place_cond E L k (MutLtype (◠ty) κ) lt T -∗
+ prove_place_cond E L k (◠(mut_ref ty κ)) lt T.
+ Proof.
+ iApply prove_place_cond_eqltype_l. apply symmetry. apply mut_ref_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_mut_l_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k :
+ ProvePlaceCond E L k (◠(mut_ref ty κ))%I lt | 10 := λ T, i2p (prove_place_cond_unfold_mut_l E L ty lt κ k T).
+ Lemma prove_place_cond_unfold_mut_r E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k T :
+ prove_place_cond E L k lt (MutLtype (◠ty) κ) T -∗
+ prove_place_cond E L k lt (◠(mut_ref ty κ)) T.
+ Proof.
+ iApply prove_place_cond_eqltype_r. apply symmetry. apply mut_ref_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_mut_r_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k :
+ ProvePlaceCond E L k lt (◠(mut_ref ty κ))%I | 10 := λ T, i2p (prove_place_cond_unfold_mut_r E L ty lt κ k T).
+ *)
+ (*
+ Lemma prove_place_cond_array_ltype E L {rt} (def1 def2 : type rt) (lts1 : ltype rt) (lts2 : ltype rt) len1 len2 κ1 κ2 k T :
+ ⌜len1 = len2⌠∗ ⌜def1 = def2⌠∗
+ (*prove_place_cond E L k lt1 lt2 (λ upd, T $ access_result_lift (λ rt, (place_rfn rt * gname)%type) upd) -∗*)
+ prove_place_cond E L k (ArrayLtype def1 len1 lts1) (ArrayLtype def2 len2 lts2) T.
+ Proof.
+ Abort.
+ *)
+ (*Global Instance prove_place_cond_mut_ltype_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 k :*)
+ (*ProvePlaceCond E L k (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 5 := λ T, i2p (prove_place_cond_mut_ltype E L lt1 lt2 κ1 κ2 k T).*)
+
+
+ (* TODO phrase this with fold_list instead *)
+ (* Iteration is controlled by refinement [rs] *)
+ Definition resolve_ghost_iter_cont_t rt : Type := llctx → list (place_rfn rt) → iProp Σ → bool → iProp Σ.
+ Definition resolve_ghost_iter {rt} (π : thread_id) (E : elctx) (L : llctx) (rm : ResolutionMode) (lb : bool) (l : loc) (st : syn_type) (lts : list (ltype rt)) (b : bor_kind) (rs : list (place_rfn rt)) (ig : list nat) (i0 : nat) (T : resolve_ghost_iter_cont_t rt) : iProp Σ :=
+ (∀ F : coPset,
+ ⌜lftE ⊆ F⌠-∗
+ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ⌜length lts = (length rs)%nat⌠-∗
+ ([∗ list] i ↦ r; lt ∈ rs; lts, if decide ((i + i0) ∈ ig) then True else (l offsetst{st}â‚— i) â—â‚—[ Ï€, b] r @ lt) ={F}=∗
+ ∃ (L' : llctx) (rs' : list $ place_rfn rt) (R : iPropI Σ) (progress : bool),
+ maybe_logical_step lb F (([∗ list] i ↦ r; lt ∈ rs'; lts, if decide ((i + i0) ∈ ig) then True else (l offsetst{st}â‚— i) â—â‚—[ Ï€, b] r @ lt) ∗ R) ∗
+ llctx_interp L' ∗ T L' rs' R progress).
+ Class ResolveGhostIter {rt} (Ï€ : thread_id) (E : elctx) (L : llctx) (rm : ResolutionMode) (lb : bool) (l : loc) (st : syn_type) (lts : list (ltype rt)) (b : bor_kind) (rs : list (place_rfn rt)) (ig : list nat) (i0 : nat) : Type :=
+ resolve_ghost_iter_proof T : iProp_to_Prop (resolve_ghost_iter π E L rm lb l st lts b rs ig i0 T).
+ Global Hint Mode ResolveGhostIter + + + + + + + + + + + + + : typeclass_instances.
+
+ Lemma resolve_ghost_iter_cons π E L rm lb l st {rt} (lts : list (ltype rt)) b (r : place_rfn rt) (rs : list (place_rfn rt)) ig (i0 : nat) T :
+ (∃ lt lts', ⌜lts = lt :: lts'⌠∗
+ resolve_ghost π E L rm lb (l offsetst{st}ₗ i0) lt b r (λ L2 r' R progress,
+ resolve_ghost_iter π E L2 rm lb l st lts' b rs ig (S i0) (λ L3 rs2 R2 progress',
+ T L3 (r' :: rs2) (R ∗ R2) (orb progress progress'))))
+ ⊢
+ resolve_ghost_iter π E L rm lb l st lts b (r :: rs) ig i0 T.
+ Proof.
+ Admitted.
+ Global Instance resolve_ghost_iter_cons_inst π E L rm lb l st {rt} (lts : list (ltype rt)) b (r : place_rfn rt) rs ig i0 :
+ ResolveGhostIter π E L rm lb l st lts b (r :: rs) ig i0 := λ T, i2p (resolve_ghost_iter_cons π E L rm lb l st lts b r rs ig i0 T).
+
+ Lemma resolve_ghost_iter_nil π E L rm lb l st {rt} (lts : list (ltype rt)) b ig i0 T :
+ T L [] True%I true
+ ⊢ resolve_ghost_iter π E L rm lb l st lts b [] ig i0 T.
+ Proof.
+ Admitted.
+ Global Instance resolve_ghost_iter_nil_inst π E L rm lb l st {rt} (lts : list (ltype rt)) b ig i0 :
+ ResolveGhostIter π E L rm lb l st lts b [] ig i0 := λ T, i2p (resolve_ghost_iter_nil π E L rm lb l st lts b ig i0 T).
+End rules.
+
+Section value.
+ Context `{!typeGS Σ}.
+ Lemma value_t_untyped_to_array π v vs n ly :
+ v â—áµ¥{Ï€} vs @ value_t (UntypedSynType (mk_array_layout ly n)) -∗
+ v â—áµ¥{Ï€} (fmap (M:=list) PlaceIn $ reshape (replicate n (ly_size ly)) vs) @ (array_t (value_t (UntypedSynType ly)) n).
+ Proof.
+ Admitted.
+ Lemma value_t_untyped_from_array π v vs n ly :
+ v â—áµ¥{Ï€} (fmap (M:=list) PlaceIn $ reshape (replicate n (ly_size ly)) vs) @ (array_t (value_t (UntypedSynType ly)) n) -∗
+ v â—áµ¥{Ï€} vs @ value_t (UntypedSynType (mk_array_layout ly n)).
+ Proof.
+ Admitted.
+
+ Lemma ofty_value_t_untyped_to_array π l vs ly n :
+ (l â—â‚—[Ï€, Owned false] #vs @ â— value_t (UntypedSynType (mk_array_layout ly n)))%I -∗
+ l â—â‚—[Ï€, Owned false] #(fmap (M:=list) PlaceIn $ reshape (replicate n (ly_size ly)) vs) @ â— (array_t (value_t (UntypedSynType ly)) n).
+ Proof.
+ Admitted.
+ Lemma ofty_value_t_untyped_from_array π l vs ly n :
+ (l â—â‚—[Ï€, Owned false] #(fmap (M:=list) PlaceIn $ reshape (replicate n (ly_size ly)) vs) @ â— (array_t (value_t (UntypedSynType ly)) n))%I -∗
+ (l â—â‚—[Ï€, Owned false] #vs @ â— value_t (UntypedSynType (mk_array_layout ly n)))%I.
+ Proof.
+ Admitted.
+
+ Lemma ofty_value_t_has_length F π l v st ly :
+ lftE ⊆ F →
+ syn_type_has_layout st ly →
+ l â—â‚—[Ï€, Owned false] #v @ (â— value_t st)%I ={F}=∗
+ ⌜length v = ly_size ly⌠∗ l â—â‚—[Ï€, Owned false] #v @ (â— value_t st)%I.
+ Proof.
+ iIntros (? Hst) "Hl".
+ Admitted.
+End value.
+
+Global Typeclasses Opaque stratify_ltype_array_iter.
+
+Section offset_ptr.
+ Context `{!typeGS Σ}.
+
+ Program Definition offset_ptr_t st : type (loc * nat) := {|
+ st_own Ï€ (p : loc * nat) v := let '(l, off) := p in ⌜v = l offsetst{st}â‚— offâŒ%I;
+ st_syn_type := PtrSynType;
+ st_has_op_type ot mt := is_ptr_ot ot;
+ |}.
+ Next Obligation.
+ iIntros (st π [l off] v ->). iExists void*. eauto.
+ Qed.
+ Next Obligation.
+ iIntros (st ot mt Hot).
+ destruct ot; try done.
+ rewrite Hot. done.
+ Qed.
+ Next Obligation.
+ iIntros (st π [l off] v). apply _.
+ Qed.
+ Next Obligation.
+ iIntros (st ot mt sts π [l off] v Hot) "Hv".
+ simpl in Hot. iPoseProof (mem_cast_compat_loc (λ v, ⌜v = l offsetst{st}â‚— offâŒ)%I with "Hv") as "%Hid"; first done.
+ { iIntros "->". eauto. }
+ destruct mt; [done | | done].
+ rewrite Hid. done.
+ Qed.
+
+ Global Instance offset_ptr_t_copy st : Copyable (offset_ptr_t st).
+ Proof. apply _. Qed.
+End offset_ptr.
+
+Section offset_rules.
+ Context `{!typeGS Σ}.
+
+ (*
+ In general, I think I want:
+ - a type judgment to cast a type to an array type, into which I can index.
+ - then I want to look up
+ - then I want to do the place access for the array's element.
+
+ Then for the subsumption (prove with subtype):
+ - for now only can do Onwed false. in general, would want to have later credits to do that.
+ How does it work for Shared though? need a later credit there.
+ Having just a logical step also does not help here.
+ TODO: really figure this out.
+ I guess I should really just have some later credits in the post of ptr::add, and have a introduce_with_hooks for that.
+
+ Ideally: should formulate this generalically, for a generalized version of SimplifyHyp, maybe.
+ Then I can use it for both typed_place and subsume_full. Look at RefinedC for that.
+ *)
+ (* TODO maybe we also generally want this to unblock/stratify first? *)
+ Definition typed_array_access_cont_t : Type := ∀ (rt' : Type), type rt' → nat → list (nat * ltype rt') → list (place_rfn rt') → bor_kind → ∀ rte, ltype rte → place_rfn rte → iProp Σ.
+ Definition typed_array_access (π : thread_id) (E : elctx) (L : llctx) (base : loc) (off : nat) (st : syn_type) {rt} (lt : ltype rt) (r : place_rfn rt) (k : bor_kind) (T : typed_array_access_cont_t) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ base â—â‚—[Ï€, k] r @ lt ={F}=∗
+ ∃ k' rt' (ty' : type rt') (len : nat) (iml : list (nat * ltype rt')) rs' (rte : Type) re (lte : ltype rte),
+ (* updated array assignment *)
+ base â—â‚—[Ï€, k'] #rs' @ ArrayLtype ty' len iml ∗
+ (base offsetst{st}â‚— off) â—â‚—[Ï€, k'] re @ lte ∗
+ llctx_interp L ∗
+ T _ ty' len iml rs' k' rte lte re.
+ Class TypedArrayAccess (Ï€ : thread_id) (E : elctx) (L : llctx) (base : loc) (off : nat) (st : syn_type) {rt} (lt : ltype rt) (r : place_rfn rt) (k : bor_kind) : Type :=
+ typed_array_access_proof T : iProp_to_Prop (typed_array_access π E L base off st lt r k T).
+ Global Hint Mode TypedArrayAccess + + + + + + + + + + : typeclass_instances.
+
+ Lemma typed_array_access_unfold π E L base off st {rt} (ty : type rt) len (rs : place_rfn (list (place_rfn rt))) k T :
+ typed_array_access π E L base off st (ArrayLtype ty len []) rs k T
+ ⊢ typed_array_access π E L base off st (◠array_t ty len) rs k T.
+ Proof.
+ iIntros "HT". iIntros (??) "#CTX #HE HL Hl".
+ iPoseProof (array_t_unfold k ty len rs) as "((_ & HIncl & _) & _)".
+ iMod (ltype_incl'_use with "HIncl Hl") as "Hl"; first done.
+ iApply ("HT" with "[//] CTX HE HL Hl").
+ Qed.
+ Global Instance typed_array_access_unfold_inst π E L base off st {rt} (ty : type rt) len rs k :
+ TypedArrayAccess π E L base off st (◠array_t ty len)%I rs k :=
+ λ T, i2p (typed_array_access_unfold π E L base off st ty len rs k T).
+
+ (* TODO make this. first have some theory for converting Owned true to Owned false with a credit *)
+ Lemma typed_array_access_array_owned π E L base off st {rt} (ty : type rt) len iml rs (wl : bool) (T : typed_array_access_cont_t) :
+ (⌜off < len⌠∗ (if wl then £ 1 else True) ∗
+ ∀ lt r, ⌜interpret_iml (◠ty)%I len iml !! off = Some lt⌠-∗ ⌜rs !! off = Some r⌠-∗
+ T _ ty len ((off, AliasLtype _ st (base offsetst{st}â‚— off)) :: iml) (rs) (Owned false) _ lt r)
+ ⊢ typed_array_access π E L base off st (ArrayLtype ty len iml) (#rs) (Owned wl) T.
+ Proof.
+ iIntros "(%Hoff & Hcred & HT)".
+ iIntros (??) "#CTX #HE HL Hl".
+ Abort.
+
+ (* NOTE: this will misbehave if we've moved the value out before already!
+ But in that case, the subsumption for offset_ptr will not trigger, because we've got the location assignment in context which will be found with higher priority.
+ *)
+ Lemma typed_array_access_array_owned_false π E L base off st {rt} (ty : type rt) len iml rs (T : typed_array_access_cont_t) :
+ (⌜off < len⌠∗ ⌜st = ty_syn_type ty⌠∗ ∀ lt r, ⌜interpret_iml (◠ty)%I len iml !! off = Some lt⌠-∗ ⌜rs !! off = Some r⌠-∗
+ T _ ty len ((off, AliasLtype _ st (base offsetst{st}â‚— off)) :: iml) (rs) (Owned false) _ lt r)
+ ⊢ typed_array_access π E L base off st (ArrayLtype ty len iml) (#rs) (Owned false) T.
+ Proof.
+ iIntros "(%Hoff & %Hst & HT)".
+ iIntros (??) "#CTX #HE HL Hl".
+ iPoseProof (array_ltype_acc_owned' with "Hl") as "(%ly & %Halg & % & % & Hlb & >(Hb & Hcl))"; first done.
+ iPoseProof (big_sepL2_length with "Hb") as "%Hlen".
+ rewrite interpret_iml_length in Hlen.
+ specialize (lookup_lt_is_Some_2 rs off) as (r & Hr).
+ { lia. }
+ specialize (lookup_lt_is_Some_2 (interpret_iml (â— ty)%I len iml) off) as (lt & Hlt).
+ { rewrite interpret_iml_length. lia. }
+ iPoseProof (big_sepL2_insert_acc _ _ _ off with "Hb") as "((%Hst' & Hel) & Hcl_b)"; [done.. | ].
+ iPoseProof (ltype_own_make_alias false _ _ r with "Hel [//]") as "(Hel & Halias)".
+ iPoseProof ("Hcl_b" $! (AliasLtype _ (ty_syn_type ty) (base offsetst{st}â‚— off)) r with "[Halias]") as "Ha".
+ { simp_ltypes. iR. rewrite /OffsetLocSt /use_layout_alg' Hst Halg /=. rewrite Hst'. done. }
+ iMod ("Hcl" $! _ ty ((off, AliasLtype rt st (base offsetst{st}â‚— off)) :: iml) rs with "[//] [//] [Ha]") as "Ha".
+ { simpl. rewrite (list_insert_id rs off r); last done. rewrite Hst. done. }
+ iPoseProof ("HT" with "[//] [//]") as "HT".
+ iModIntro. iExists _, _, _, _, _, _, _. iExists _, _. iFrame.
+ rewrite /OffsetLocSt /use_layout_alg' Hst Halg//.
+ Qed.
+ Global Instance typed_array_access_owned_inst π E L base off st {rt} (ty : type rt) len iml rs :
+ TypedArrayAccess π E L base off st (ArrayLtype ty len iml) (#rs) (Owned false) :=
+ λ T, i2p (typed_array_access_array_owned_false π E L base off st ty len iml rs T).
+
+ Lemma typed_array_access_array_shared π E L base off st {rt} (ty : type rt) len iml rs κ (T : typed_array_access_cont_t) :
+ (⌜off < len⌠∗ ⌜st = ty_syn_type ty⌠∗ ∀ lt r, ⌜interpret_iml (◠ty)%I len iml !! off = Some lt⌠-∗ ⌜rs !! off = Some r⌠-∗
+ T _ ty len iml (rs) (Shared κ) _ lt r)
+ ⊢ typed_array_access π E L base off st (ArrayLtype ty len iml) (#rs) (Shared κ) T.
+ Proof.
+ iIntros "(%Hoff & %Hst & HT)".
+ iIntros (??) "#CTX #HE HL Hl".
+ iPoseProof (array_ltype_acc_shared with "Hl") as "(%ly & %Halg & % & % & Hlb & >(#Hb & Hcl))"; first done.
+ iPoseProof (big_sepL2_length with "Hb") as "%Hlen".
+ rewrite interpret_iml_length in Hlen.
+ specialize (lookup_lt_is_Some_2 rs off) as (r & Hr).
+ { lia. }
+ specialize (lookup_lt_is_Some_2 (interpret_iml (â— ty)%I len iml) off) as (lt & Hlt).
+ { rewrite interpret_iml_length. lia. }
+ iPoseProof (big_sepL2_lookup _ _ _ off with "Hb") as "(%Hst' & Hel)"; [done.. | ].
+ iMod ("Hcl" $! ty iml with "[//] Hb") as "(Ha & _)".
+ iPoseProof ("HT" with "[//] [//]") as "HT".
+ iModIntro. iExists _, _, _, _, _, _, _. iExists _, _. iFrame.
+ rewrite /OffsetLocSt /use_layout_alg' Hst Halg//.
+ Qed.
+ Global Instance typed_array_access_shared_inst π E L base off st {rt} (ty : type rt) len iml rs κ :
+ TypedArrayAccess π E L base off st (ArrayLtype ty len iml) (#rs) (Shared κ) :=
+ λ T, i2p (typed_array_access_array_shared π E L base off st ty len iml rs κ T).
+
+ (* TODO maybe we should also move out the value for the element then?
+ Problem: at the point of the subsumption, this is too late already for function calls, since we already have the evar then...
+ *)
+ Lemma subsume_from_offset_ptr_t π E L step l base off st k {rt} (ty : type rt) r T :
+ find_in_context (FindLoc base π) (λ '(existT rt' (lt', r', k')),
+ typed_array_access π E L base off st lt' r' k' (λ rt2 ty2 len2 iml2 rs2 k2 rte lte re,
+ base â—â‚—[Ï€, k2] #rs2 @ ArrayLtype ty2 len2 iml2 -∗
+ (* TODO maybe this should also stratify? *)
+ subsume_full E L step (l â—â‚—[Ï€, k2] re @ lte) (l â—â‚—[Ï€, k] r @ â— ty) T))
+ ⊢ subsume_full E L step (l â—áµ¥{Ï€} (base, off) @ offset_ptr_t st) (l â—â‚—[Ï€, k] r @ â— ty) T.
+ Proof.
+ rewrite /find_in_context.
+ iDestruct 1 as ([rt' [[lt' r'] k']]) "(Hl & Ha)". simpl.
+ iIntros (???) "#CTX #HE HL Hoffset".
+ iMod ("Ha" with "[//] CTX HE HL Hl") as "(%k2 & %rt2 & %ty2 & %len2 & %iml2 & %rs2 & %rte & %re & %lte & Hb & Hl & HL & HT)".
+ iEval (rewrite /ty_own_val/=) in "Hoffset". iDestruct "Hoffset" as "%Heq".
+ apply val_of_loc_inj in Heq. subst l.
+ iApply ("HT" with "Hb [//] [//] CTX HE HL Hl").
+ Qed.
+ Global Instance subsume_from_offset_ptr_t_inst π E L step (l : loc) base off st k {rt} (ty : type rt) r :
+ SubsumeFull E L step (l â—áµ¥{Ï€} (base, off) @ offset_ptr_t st) (l â—â‚—[Ï€, k] r @ (â— ty)%I) | 50 :=
+ λ T, i2p (subsume_from_offset_ptr_t π E L step l base off st k ty r T).
+
+ (* TODO: also should ideally formulate this so we can share this with the direct array offset rules.
+ Potentially, we should just encode array offset in terms of this.
+
+ Can I formulate this without the deref? Well, then I'd need to have an offset place type.
+ Can I make the recursive part nicer? e.g. by just hooking on top of the alias ptr lemma?
+ *)
+ Lemma typed_place_offset_ptr_owned π E L l st base offset bmin P wl T :
+ find_in_context (FindLoc base π) (λ '(existT rt (lt, r, b)),
+ typed_array_access π E L base offset st lt r b (λ rt2 ty2 len2 iml2 rs2 k2 rte lte re,
+ base â—â‚—[ Ï€, k2] # rs2 @ ArrayLtype ty2 len2 iml2 -∗
+ typed_place π E L (base offsetst{st}ₗ offset) lte re k2 k2 P (λ L2 κs li bi bmin' rti lti ri strong weak,
+ T L2 [] li bi bmin' rti lti ri
+ (match strong with
+ | Some strong => Some $ mk_strong (λ _, _) (λ _ _ _, (â— offset_ptr_t st)) (λ _ _, #(base, offset)) (λ rti2 ltyi2 ri2, (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)
+ | None => None
+ end)
+ (match weak with
+ | Some weak => Some $ mk_weak (λ _ _, (â— offset_ptr_t st)) (λ _, #(base, offset)) (λ ltyi2 ri2, llft_elt_toks κs ∗ (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)
+ | None =>
+ match strong with
+ | Some strong => Some $ mk_weak (λ _ _, (â— offset_ptr_t st)) (λ _, #(base, offset)) (λ ltyi2 ri2, (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)
+ | None => None
+ end
+ end)
+ )))
+ ⊢ typed_place π E L l (◠offset_ptr_t st) (#(base, offset)) bmin (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ rewrite /FindLoc.
+ iDestruct 1 as ([rt [[lt r] b]]) "(Hbase & HT)". simpl.
+ iIntros (????) "#CTX #HE HL Hincl Hl Hcont".
+ iApply fupd_place_to_wp.
+ iMod ("HT" with "[] CTX HE HL Hbase") as "(%k2 & %rt2 & %ty2 & %len2 & %iml2 & %rs2 & %rte & %re & %lte & Hbase & Hoff & HL & HT)"; first done.
+ iApply (typed_place_ofty_access_val_owned with "[Hbase Hoff HT] [//] [//] CTX HE HL Hincl Hl Hcont").
+ { done. }
+ iIntros (F' v ?) "Hoffset".
+ iEval (rewrite /ty_own_val/=) in "Hoffset". iDestruct "Hoffset" as "->".
+ iModIntro. iExists _, _, _, _, _. iR. iFrame "Hoff".
+ iSplitR. { rewrite /ty_own_val. done. }
+ iSpecialize ("HT" with "Hbase").
+ iApply "HT".
+ Qed.
+ Global Instance typed_place_offset_ptr_owned_inst π E L l st base offset bmin P wl :
+ TypedPlace E L π l (◠offset_ptr_t st)%I (#(base, offset)) bmin (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) |30 :=
+ λ T, i2p (typed_place_offset_ptr_owned π E L l st base offset bmin P wl T).
+
+ Lemma typed_place_offset_ptr_uniq π E L l st base offset bmin P κ γ T :
+ find_in_context (FindLoc base π) (λ '(existT rt (lt, r, b)),
+ typed_array_access π E L base offset st lt r b (λ rt2 ty2 len2 iml2 rs2 k2 rte lte re,
+ base â—â‚—[ Ï€, k2] # rs2 @ ArrayLtype ty2 len2 iml2 -∗
+ ⌜lctx_lft_alive E L κ⌠∗
+ typed_place π E L (base offsetst{st}ₗ offset) lte re k2 k2 P (λ L2 κs li bi bmin' rti lti ri strong weak,
+ T L2 κs li bi bmin' rti lti ri
+ (option_map (λ strong, mk_strong (λ _, _) (λ _ _ _, (â— offset_ptr_t st)) (λ _ _, #(base, offset)) (λ rti2 ltyi2 ri2, (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (option_map (λ weak, mk_weak (λ _ _, (â— offset_ptr_t st)) (λ _, #(base, offset)) (λ ltyi2 ri2, (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ )))
+ ⊢ typed_place π E L l (◠offset_ptr_t st) (#(base, offset)) bmin (Uniq κ γ) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ rewrite /FindLoc.
+ iDestruct 1 as ([rt [[lt r] b]]) "(Hbase & HT)". simpl.
+ iIntros (????) "#CTX #HE HL Hincl Hl Hcont".
+ iApply fupd_place_to_wp.
+ iMod ("HT" with "[] CTX HE HL Hbase") as "(%k2 & %rt2 & %ty2 & %len2 & %iml2 & %rs2 & %rte & %re & %lte & Hbase & Hoff & HL & HT)"; first done.
+ iPoseProof ("HT" with "Hbase") as "(%Hal & HT)".
+ iApply (typed_place_ofty_access_val_uniq _ _ _ _ (offset_ptr_t st) with "[Hoff HT] [//] [//] CTX HE HL Hincl Hl Hcont").
+ { done. }
+ iR. iIntros (F' v ?) "Hoffset".
+ iEval (rewrite /ty_own_val/=) in "Hoffset". iDestruct "Hoffset" as "->".
+ iModIntro. iExists _, _, _, _, _. iR. iFrame "Hoff".
+ iSplitR. { rewrite /ty_own_val/=. done. }
+ iApply "HT".
+ Qed.
+ Global Instance typed_place_offset_ptr_uniq_inst π E L l st base offset bmin P κ γ :
+ TypedPlace E L π l (◠offset_ptr_t st)%I (#(base, offset)) bmin (Uniq κ γ) (DerefPCtx Na1Ord PtrOp true :: P) | 30:=
+ λ T, i2p (typed_place_offset_ptr_uniq π E L l st base offset bmin P κ γ T).
+
+ Lemma typed_place_offset_ptr_shared π E L l st base offset bmin P κ T :
+ find_in_context (FindLoc base π) (λ '(existT rt (lt, r, b)),
+ typed_array_access π E L base offset st lt r b (λ rt2 ty2 len2 iml2 rs2 k2 rte lte re,
+ base â—â‚—[ Ï€, k2] # rs2 @ ArrayLtype ty2 len2 iml2 -∗
+ ⌜lctx_lft_alive E L κ⌠∗
+ typed_place π E L (base offsetst{st}ₗ offset) lte re k2 k2 P (λ L2 κs li bi bmin' rti lti ri strong weak,
+ T L2 κs li bi bmin' rti lti ri
+ (option_map (λ strong, mk_strong (λ _, _) (λ _ _ _, (â— offset_ptr_t st)) (λ _ _, #(base, offset)) (λ rti2 ltyi2 ri2, (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (option_map (λ weak, mk_weak (λ _ _, (â— offset_ptr_t st)) (λ _, #(base, offset)) (λ ltyi2 ri2, (base offsetst{st}â‚— offset) â—â‚—[Ï€, k2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ )))
+ ⊢ typed_place π E L l (◠offset_ptr_t st) (#(base, offset)) bmin (Shared κ) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ rewrite /FindLoc.
+ iDestruct 1 as ([rt [[lt r] b]]) "(Hbase & HT)". simpl.
+ iIntros (????) "#CTX #HE HL Hincl Hl Hcont".
+ iApply fupd_place_to_wp.
+ iMod ("HT" with "[] CTX HE HL Hbase") as "(%k2 & %rt2 & %ty2 & %len2 & %iml2 & %rs2 & %rte & %re & %lte & Hbase & Hoff & HL & HT)"; first done.
+ iPoseProof ("HT" with "Hbase") as "(%Hal & HT)".
+ iApply (typed_place_ofty_access_val_shared with "[Hoff HT] [//] [//] CTX HE HL Hincl Hl Hcont").
+ { done. }
+ iR. iIntros (F' v ?) "Hoffset".
+ iEval (rewrite /ty_own_val/=) in "Hoffset". iDestruct "Hoffset" as "->".
+ iModIntro. iExists _, _, _, _, _. iR. iFrame "Hoff".
+ iSplitR. { rewrite /ty_own_val/=. done. }
+ iApply "HT".
+ Qed.
+ Global Instance typed_place_offset_ptr_shared_inst π E L l st base offset bmin P κ :
+ TypedPlace E L π l (◠offset_ptr_t st)%I (#(base, offset)) bmin (Shared κ) (DerefPCtx Na1Ord PtrOp true :: P) |30 :=
+ λ T, i2p (typed_place_offset_ptr_shared π E L l st base offset bmin P κ T).
+
+ Lemma owned_subtype_offset_alias π E L pers l (offset : nat) l2 st T :
+ ⌜l2 = l offsetst{st}ₗ offset⌠∗ T L
+ ⊢ owned_subtype π E L pers (l, offset) l2 (offset_ptr_t st) (alias_ptr_t) T.
+ Proof.
+ iIntros "(-> & HT)".
+ iIntros (???) "#CTX #HE HL". iExists L. iFrame.
+ iModIntro. iApply bi.intuitionistically_intuitionistically_if.
+ iModIntro.
+ iSplitR; last iSplitR.
+ - iPureIntro. simpl. iIntros (ly1 ly2 Hst1 Hst2).
+ f_equiv. by eapply syn_type_has_layout_inj.
+ - done.
+ - iIntros (v) "Hv". rewrite /ty_own_val/=. done.
+ Qed.
+ Global Instance owned_subtype_offset_alias_inst π E L pers l (offset : nat) l2 st :
+ OwnedSubtype π E L pers (l, offset) l2 (offset_ptr_t st) (alias_ptr_t) :=
+ λ T, i2p (owned_subtype_offset_alias π E L pers l offset l2 st T).
+
+ Lemma owned_subtype_alias_offset π E L pers l l2 offset st T :
+ ⌜l2 = l⌠∗ ⌜offset = 0⌠∗ T L
+ ⊢ owned_subtype π E L pers l (l2, offset) (alias_ptr_t) (offset_ptr_t st) T.
+ Proof.
+ iIntros "(-> & -> & HT)".
+ iIntros (???) "#CTX #HE HL". iExists L. iFrame.
+ iModIntro. iApply bi.intuitionistically_intuitionistically_if.
+ iModIntro.
+ iSplitR; last iSplitR.
+ - iPureIntro. simpl. iIntros (ly1 ly2 Hst1 Hst2).
+ f_equiv. by eapply syn_type_has_layout_inj.
+ - done.
+ - iIntros (v) "->". rewrite /ty_own_val/=.
+ rewrite /OffsetLocSt. rewrite Z.mul_0_r shift_loc_0//.
+ Qed.
+ Global Instance owned_subtype_alias_offset_inst π E L pers l (offset : nat) l2 st :
+ OwnedSubtype π E L pers l (l2, offset) (alias_ptr_t) (offset_ptr_t st) :=
+ λ T, i2p (owned_subtype_alias_offset π E L pers l l2 offset st T).
+
+ Lemma offset_ptr_simplify_hyp (v : val) π (l : loc) st (off : nat) T :
+ (⌜v = l offsetst{st}â‚— off⌠-∗ introduce_direct (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st) -∗ T)
+ ⊢ simplify_hyp (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st) T.
+ Proof.
+ iIntros "HT %Hv". rewrite /introduce_direct. by iApply "HT".
+ Qed.
+ Global Instance offset_ptr_simplify_hyp_inst (v : val) π l st (off : nat) :
+ SimplifyHypVal v π (offset_ptr_t st) (l, off) (Some 0%N) :=
+ λ T, i2p (offset_ptr_simplify_hyp v π l st off T).
+
+ Lemma offset_ptr_simplify_goal (v : val) π (l : loc) st (off : nat) T :
+ (⌜v = l offsetst{st}â‚— offâŒ) ∗ T ⊢ simplify_goal (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st) T.
+ Proof.
+ iIntros "(-> & HT)". iFrame. done.
+ Qed.
+ Global Instance offset_ptr_simplify_goal_inst v π l st off :
+ SimplifyGoalVal v π (offset_ptr_t st) (l, off) (Some 50%N) :=
+ λ T, i2p (offset_ptr_simplify_goal v π l st off T).
+
+ (*
+ prove l +â‚— ... â—
+
+ subsume (v â—áµ¥ offset_ptr_t) (l â—â‚—[Ï€, ..] .. )
+
+
+ *)
+
+
+
+ (* Want:
+ - find type assingment
+ - subtype to array
+ this should potentially also be able to move it back in.
+ just subsume_full with a step is probably right.
+ - then we need that the offset is valid, prove it. okay.
+ - then we can provide the array with aliased ownership and get the ownership for that offset out.
+ for that we are going to need a step, if it is Owned true.
+
+ On the other side, when we need to move in again:
+ subtyping here should be able to put in aliases again.
+ so this needs to be owned_subltype_step/subsume_full with a step if it is Owned true, and for Owned false doesn't need a step.
+ in general, we won't have a step.
+ but how do we formulate the lemmas to enable that?
+ well, we basically need the stratification parts for that also in subtyping now...
+ why, well, because we consciously destroy it first.
+
+ but we also get that issue when we first do
+ ptr::write (moving an element out)
+ and then
+ ptr::copy (needs everything in place)
+ Maybe we should stratify place arguments in the precondition first?
+
+ i.e. prove_with_subtype (l â—â‚—[...] ...) should find assignment for l and then stratify it, if it gets a step.
+ I'm not sure if that is a good idea in general though.
+ TODO
+
+ I guess in principle, maybe that is just something that should also be doable by subtyping, not by stratification.
+
+ Maybe all the value instances for joining values should also be put in there.
+ *)
+ Lemma type_extract_value_annot_offset π E L n v l (off : nat) st (T : typed_annot_expr_cont_t) :
+ (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st -∗ T L v _ (offset_ptr_t st) (l, off))
+ ⊢ typed_annot_expr Ï€ E L n ExtractValueAnnot v (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st) T.
+ Proof.
+ iIntros "HT #CTX #HE HL #Hv".
+ iApply step_fupdN_intro; first done. iNext. iModIntro. iExists _, _, _, _. iFrame.
+ iR. by iApply "HT".
+ Qed.
+ Global Instance type_extract_value_annot_offset_inst π E L n v l off st :
+ TypedAnnotExpr Ï€ E L n ExtractValueAnnot v (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st)%I :=
+ λ T, i2p (type_extract_value_annot_offset π E L n v l off st T).
+
+ (* Problem:
+ Lithium simplifies only if it cannot find it in the context.
+ Maybe we shou
+
+
+ Now, what is our invariant? Do we want to have offset ptrs in the context as values?
+
+ If so, we get into trouble in some places where we need to go from an aliasptr to an offsetptr.
+
+ If not, we will try to find an assignment and can't find it in the preconditions we have.
+ Ideally, I'd like to be able to introduce something into the context without simplification at some points.
+ Or have simplification for gaining information.
+
+
+ *)
+
+
+
+ (*
+ Lemma type_extract_value_annot_offset π E L n v l (off : nat) st (T : typed_annot_expr_cont_t) :
+ ⌜n > 0⌠∗ find_in_context (FindLoc l π) (λ '(existT rt (lt, r, bk)),
+ (* TODO this is a pretty big hack currently and will break once we e.g. first move out the value. The problem is that we have trouble with the dependent evars *)
+ ∃ rt', ⌜rt = list (place_rfn rt')⌠∗ ∃ (ty : type rt') len iml (xs : list (place_rfn rt')),
+ subsume_full E L true (l â—â‚—[Ï€, bk] r @ lt) (l â—â‚—[Ï€, Owned false] #xs @ ArrayLtype ty len iml) (λ L2 R2,
+ ⌜(off < len)%Z⌠∗
+ ⌜ty_syn_type ty = st⌠∗ (* TODO might generalize this condition *)
+ (∀ x lt,
+ ⌜xs !! off = Some x⌠-∗
+ ⌜interpret_iml (◠ty)%I len iml !! off = Some lt⌠-∗
+ (l offsetst{st}â‚— off) â—â‚—[Ï€, Owned false] x @ lt -∗
+ l â—â‚—[Ï€, Owned false] #xs @ ArrayLtype ty len [(off, AliasLtype _ (ty_syn_type ty) (l offsetst{ty_syn_type ty}â‚— off))] -∗
+ T L v _ (offset_ptr_t st) (l, off)))) -∗
+ typed_annot_expr Ï€ E L n ExtractValueAnnot v (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance type_extract_value_annot_offset_inst π E L n v l off st :
+ TypedAnnotExpr Ï€ E L n ExtractValueAnnot v (v â—áµ¥{Ï€} (l, off) @ offset_ptr_t st)%I :=
+ λ T, i2p (type_extract_value_annot_offset π E L n v l off st T).
+ *)
+End offset_rules.
+
+
+
+
+
+ (*
+
+
+ Lifecycle of an array:
+ - initialization by subsumption from uninit - i.e. uninit -> array (uninit)
+ - array (uninit) -> array (ty)
+ + in Vec: ty = maybe_uninit ty)
+ + in safe Rust: write array value to it.
+ this always has constant size (no VLA); but it may not only contain constants.
+ I.e. this is an expression. We need to typecheck this expression at array_t, and can then assign it.
+ - on access of components: unfold.
+ - accesses of components may generate an override with a new ltype (homo).
+ - eventually, we fold again (stratification). here, we show that everything is coreable to the def type.
+ -
+
+ What about partially initialized arrays?
+ - in safe Rust, these don't exist.
+ - and in other cases, we will usually have maybe_uninit (e.g. Vec).
+
+
+ How do I imagine these lemmas to look?
+
+ For subltyping:
+ - should it take into account refinements, or directly require equality of those?
+ e.g. if we want to do array (T) <: array (maybe_uninit T), we need to take it into account.
+
+ Option 1:
+ - require subtyping for the def type.
+ - for the overrides:
+ + first simplify via tactic hint
+ + then enter a custom judgment that deals with imls (or something more general -- basically a generalization of subsume_list)
+ Option 2:
+ - do a subsumption that looks quite similar to refinedc's subsume_list -- i.e. we first interpret via interpret_iml, and then have a generalization of subsume_list.
+
+ => use Option 2 with relate_list.
+ We basically add a flag describing the operation to match on for instances.
+ In our case, it will also carry the whole refinements.
+ Then the individual instance for us will just do one step by doing a lookup.
+
+
+ For resolve_ghost:
+ - basically should take into account just the overrides.
+ - need to deal with list inserts in the refinement here. Use Lithiums built-in lookup facility.
+ strategy 1: walk over the refinement via syntactic matching on inserts. For each of these, do a resolution.
+ -> I think this is probably more robust.
+ How do I phrase this inductively, though?
+ probably extract the refinement first, converting it into a walkable list via Ltac.
+ then go over that list, and generate new inserts if we do a resolution.
+ Probably that needs a separate judgment.
+ strategy 2: walk over the types. However: we ideally also want to be able to resolve for folded things.
+ This would only suffice if we can get the better refinement contracts to work. (i.e., setting up relations after the fact).
+
+ On strategy1:
+ - ghost_resolve_list
+ Difference to structs: we don't deal with concrete, but with symbolic lists.
+ Is there some more general abstraction we could use?
+
+ For stratify:
+ - first, stratify all components.
+ Basically:
+ def is already a type and fully stratified.
+ for the overrides, for each do a lookup of the refinement, and stratify with that.
+ - then have the stratified components.
+ if all of them satisfy the placecond: go to ofty or coreable
+ + check if all of them are ofty, then require subtyping to the def. then can go to ofty for the array again.
+ + otherwise, go to coreable with the whole thing (?) => this is a choice here.
+ Do we want to completely "finalize" or not?
+ otherwise, keep the current state.
+
+ place access:
+ - how does unfolding of an array work?
+ well, after deref we give it an ofty, from which we can go on and generate an override.
+ - actual access:
+ + either go directly via lookup of the interpreted list.
+ => This is the path to take.
+ + or go via lookup of iml -- needs custom lookup li_tactic then.
+ *)
diff --git a/theories/rust_typing/automation.v b/theories/rust_typing/automation.v
new file mode 100644
index 0000000000000000000000000000000000000000..b145a45b0ac4c401ed97bf1395619dd1fec7fb9e
--- /dev/null
+++ b/theories/rust_typing/automation.v
@@ -0,0 +1,1024 @@
+From iris.proofmode Require Import coq_tactics reduction string_ident.
+From refinedrust Require Export type.
+From lithium Require Export all.
+From lithium Require Import hooks.
+From refinedrust.automation Require Import ident_to_string lookup_definition.
+From refinedrust Require Import int programs program_rules functions references products arrays enum.
+(* Important: import proof_state last as it overrides some Lithium tactics *)
+From refinedrust.automation Require Export simpl solvers proof_state.
+Set Default Proof Using "Type".
+
+(* TODO: move *)
+Lemma Forall2_cons_inv {A B} (P : A → B → Prop) l r x y :
+ Forall2 P (x :: l) (y :: r) →
+ P x y ∧ Forall2 P l r.
+Proof.
+ inversion 1; subst. done.
+Qed.
+
+(** * Registering extensions *)
+(** More automation for modular arithmetics. *)
+Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations.
+
+(*Ltac li_pm_reduce_tac H ::= eval cbv [t2mt mt_type mt_movable] in H.*)
+
+(*
+Ltac custom_exist_tac A protect ::=
+ idtac
+ .
+ *)
+
+Global Hint Transparent ly_size : solve_protected_eq_db.
+Ltac solve_protected_eq_hook ::=
+ lazymatch goal with
+ (* unfold constants for function types *)
+ | |- @eq (_ → fn_params) ?a (λ x, _) =>
+ lazymatch a with
+ | (λ x, _) => idtac
+ | _ =>
+ let h := get_head a in
+ unfold h;
+ (* necessary to reduce after unfolding because of the strict
+ opaqueness settings for unification *)
+ liSimpl
+ end
+ (* Try to simplify as much as possible *)
+ (*| |- pcons _ _ = pcons _ _ => *)
+ (*repeat f_equiv;*)
+ (*match goal with *)
+ (*| |- @pnil _ _ = @pnil _ _ => reflexivity*)
+ (*| |- _ => idtac*)
+ (*end*)
+
+ (* don't fail if nothing matches *)
+ | |- _ => idtac
+ end.
+
+Ltac can_solve_hook ::= first [
+ match goal with
+ | |- _ ≠_ => discriminate
+ end | solve_goal].
+
+Ltac liTrace_hook info ::=
+ add_case_distinction_info info.
+
+Ltac liExtensible_to_i2p_hook P bind cont ::=
+ lazymatch P with
+ | subsume_full ?E ?L ?step ?P ?Q ?T =>
+ cont uconstr:(((_ : SubsumeFull E L step P Q) T))
+ | relate_list ?E ?L ?ig ?l1 ?l2 ?i0 ?R ?T =>
+ cont uconstr:(((_ : RelateList E L ig l1 l2 i0 R) T))
+ | relate_hlist ?E ?L ?ig ?Xs ?l1 ?l2 ?i0 ?R ?T =>
+ cont uconstr:(((_ : RelateHList E L ig Xs l1 l2 i0 R) T))
+ | fold_list ?E ?L ?ig ?l ?i0 ?P ?T =>
+ cont uconstr:(((_ : FoldList E L ig l i0 P) T))
+ | typed_value ?v ?Ï€ ?T =>
+ cont uconstr:(((_ : TypedValue v π) T))
+ | typed_bin_op ?Ï€ ?E ?L ?v1 ?ty1 ?v2 ?ty2 ?o ?ot1 ?ot2 ?T =>
+ cont uconstr:(((_ : TypedBinOp π E L v1 ty1 v2 ty2 o ot1 ot2) T))
+ | typed_un_op ?Ï€ ?E ?L ?v ?ty ?o ?ot ?T =>
+ cont uconstr:(((_ : TypedUnOp π E L v ty o ot) T))
+ | typed_call ?π ?E ?L ?eκs ?v ?P ?vl ?tys ?T =>
+ cont uconstr:(((_ : TypedCall π E L eκs v P vl tys) T))
+ | typed_place ?Ï€ ?E ?L ?l ?lt ?r ?bmin0 ?b ?P ?T =>
+ cont uconstr:(((_ : TypedPlace E L π l lt r bmin0 b P) T))
+ | typed_if ?E ?L ?v ?P ?T1 ?T2 =>
+ cont uconstr:(((_ : TypedIf E L v P) T1 T2))
+ | typed_switch ?Ï€ ?E ?L ?v ?rt ?ty ?r ?it ?m ?ss ?def ?fn ?R =>
+ cont uconstr:(((_ : TypedSwitch π E L v rt ty r it) m ss def fn R))
+ | typed_assert ?Ï€ ?E ?L ?v ?ty ?r ?s ?fn ?R ?Ï =>
+ cont uconstr:(((_ : TypedAssert Ï€ E L v ty r) s fn R Ï))
+ | typed_read_end ?Ï€ ?E ?L ?l ?ty ?r ?b2 ?bmin ?br ?ot ?T =>
+ cont uconstr:(((_ : TypedReadEnd π E L l ty r b2 bmin br ot) T))
+ | typed_write_end ?Ï€ ?E ?L ?ot ?v1 ?ty1 ?r1 ?b2 ?bmin ?br ?l2 ?lt2 ?r2 ?T =>
+ cont uconstr:(((_ : TypedWriteEnd π E L ot v1 ty1 r1 b2 bmin br l2 lt2 r2) T))
+ | typed_borrow_mut_end ?π ?E ?L ?κ ?l ?ty ?r ?b2 ?bmin ?T =>
+ cont uconstr:(((_ : TypedBorrowMutEnd π E L κ l ty r b2 bmin) T))
+ | typed_borrow_shr_end ?π ?E ?L ?κ ?l ?ty ?r ?b2 ?bmin ?T =>
+ cont uconstr:(((_ : TypedBorrowShrEnd π E L κ l ty r b2 bmin) T))
+ | typed_addr_of_mut_end ?Ï€ ?E ?L ?l ?lt ?r ?b2 ?bmin ?T =>
+ cont uconstr:(((_ : TypedAddrOfMutEnd π E L l lt r b2 bmin) T))
+ | cast_ltype_to_type ?E ?L ?lt ?T =>
+ cont uconstr:(((_ : CastLtypeToType E L lt) T))
+ | typed_context_fold ?AI ?Ï€ ?E ?L ?m ?tctx ?acc ?T =>
+ cont uconstr:(((_ : TypedContextFold AI π E L m tctx acc) T))
+ | typed_context_fold_step ?AI ?Ï€ ?E ?L ?m ?l ?lt ?r ?tctx ?acc ?T =>
+ cont uconstr:(((_ : TypedContextFoldStep AI π E L m l lt r tctx acc) T))
+ | typed_annot_expr ?Ï€ ?E ?L ?n ?a ?v ?P ?T =>
+ cont uconstr:(((_ : TypedAnnotExpr π E L n a v P) T))
+ | prove_with_subtype ?E ?L ?step ?pm ?P ?T =>
+ cont uconstr:(((_ : ProveWithSubtype E L step pm P) T))
+ | owned_subtype ?Ï€ ?E ?L ?pers ?r1 ?r2 ?ty1 ?ty2 ?T =>
+ cont uconstr:((_ : OwnedSubtype π E L pers r1 r2 ty1 ty2) T)
+ | owned_subltype_step ?Ï€ ?E ?L ?r1 ?r2 ?lt1 ?lt2 ?T =>
+ cont uconstr:((_ : OwnedSubltypeStep π E L r1 r2 lt1 lt2) T)
+ | weak_subtype ?E ?L ?r1 ?r2 ?ty1 ?ty2 ?T =>
+ cont uconstr:((_ : Subtype E L r1 r2 ty1 ty2) T)
+ | weak_subltype ?E ?L ?k ?r1 ?r2 ?lt1 ?lt2 ?T =>
+ cont uconstr:((_ : SubLtype E L k r1 r2 lt1 lt2) T)
+ | mut_subtype ?E ?L ?ty1 ?ty2 ?T =>
+ cont uconstr:((_ : MutSubtype E L ty1 ty2) T)
+ | mut_eqtype ?E ?L ?ty1 ?ty2 ?T =>
+ cont uconstr:((_ : MutEqtype E L ty1 ty2) T)
+ | mut_subltype ?E ?L ?lt1 ?lt2 ?T =>
+ cont uconstr:((_ : MutSubLtype E L lt1 lt2) T)
+ | mut_eqltype ?E ?L ?lt1 ?lt2 ?T =>
+ cont uconstr:((_ : MutEqLtype E L lt1 lt2) T)
+ | stratify_ltype ?Ï€ ?E ?L ?mu ?mdu ?ma ?ml ?l ?lt ?r ?b ?T =>
+ cont uconstr:(((_ : StratifyLtype π E L mu mdu ma ml l lt r b) T))
+ | stratify_ltype_unblock ?Ï€ ?E ?L ?ma ?l ?lt ?r ?b ?T =>
+ cont uconstr:(((_ : StratifyLtype π E L _ _ _ StratifyUnblockOp l lt r b) T))
+ | stratify_ltype_extract ?π ?E ?L ?Ma ?l ?lt ?r ?b ?κ ?T =>
+ cont uconstr:(((_ : StratifyLtype π E L _ _ _ (StratifyExtractOp κ) l lt r b) T))
+ | stratify_ltype_post_hook ?Ï€ ?E ?L ?ml ?l ?lt ?r ?b ?T =>
+ cont uconstr:(((_ : StratifyLtypePostHook π E L ml l lt r b) T))
+ | resolve_ghost ?Ï€ ?E ?L ?m ?lb ?l ?lt ?b ?r ?T =>
+ cont uconstr:(((_ : ResolveGhost π E L m lb l lt b r) T))
+ | find_observation ?rt ?γ ?mode ?T =>
+ cont uconstr:(((_ : FindObservation rt γ mode) T))
+ | typed_on_endlft ?π ?E ?L ?κ ?worklist ?T =>
+ cont uconstr:(((_ : TypedOnEndlft π E L κ worklist) T))
+ | typed_on_endlft_trigger ?E ?L ?key ?P ?T =>
+ cont uconstr:(((_ : TypedOnEndlftTrigger E L key P) T))
+ | introduce_with_hooks ?E ?L ?P ?T =>
+ cont uconstr:(((_ : IntroduceWithHooks E L P) T))
+ | prove_place_cond ?E ?L ?b ?lt1 ?lt2 ?T =>
+ cont uconstr:(((_ : ProvePlaceCond E L b lt1 lt2) T))
+ | prove_place_rfn_cond ?b ?b1 ?r1 ?r2 ?T =>
+ cont uconstr:(((_ : ProvePlaceRfnCond b b1 r1 r2) T))
+ | typed_option_map ?o ?Φ ?d ?T =>
+ cont uconstr:(((_ : TypedOptionMap o Φ d) T))
+ | stratify_ltype_array_iter ?Ï€ ?E ?L ?mu ?mdu ?ma ?ml ?l ?ig ?def ?len ?iml ?rs ?bk ?T =>
+ cont uconstr:(((_ : StratifyLtypeArrayIter π E L mu mdu ma ml l ig def len iml rs bk) T))
+ | typed_array_access ?Ï€ ?E ?L ?base ?offset ?st ?lt ?r ?k ?T =>
+ cont uconstr:(((_ : TypedArrayAccess π E L base offset st lt r k) T))
+ | resolve_ghost_iter ?Ï€ ?E ?L ?rm ?lb ?l ?st ?lts ?b ?rs ?ig ?i0 ?T =>
+ cont uconstr:(((_ : ResolveGhostIter π E L rm lb l st lts b rs ig i0) T))
+ end.
+
+
+(** * Loopy stuff *)
+(* using our own list type here in order to be able to put iProp's in it (universe troubles) *)
+#[universes(polymorphic)]
+Inductive poly_list (T : Type) : Type :=
+ | PolyNil
+ | PolyCons (x : T) (l : poly_list T).
+Arguments PolyNil {_}.
+Arguments PolyCons {_}.
+
+#[universes(polymorphic)]
+Inductive poly_option (T : Type) : Type :=
+ | PolyNone
+ | PolySome (x : T).
+Arguments PolyNone {_}.
+Arguments PolySome {_}.
+
+(* Wrapper to store predicates of arbitrary arity. *)
+Definition wrap_inv {T} (x : T) := existT (P := id) _ x.
+(* Type of loop invariants: a predicate on the refinements, and a predicate on the lifetime contexts *)
+Definition bb_inv_t := (sigT (@id Type) * sigT (@id Type))%type.
+(* Type of the loop invariant map we keep in the context *)
+Definition bb_inv_map_t := poly_list (var_name * bb_inv_t)%type.
+Inductive bb_inv_map_marker : bb_inv_map_t → Type :=
+ BB_INV_MAP (M : bb_inv_map_t) : bb_inv_map_marker M.
+
+(** Given a [runtime_function] [rfn], get the list of stack locations as a [constr]. *)
+Ltac gather_locals rfn :=
+ match rfn with
+ | Build_runtime_function ?fn ?l =>
+ eval simpl in (map fst l)
+ end.
+
+(** Find the invariant for basic block [loop_bb] in the invariant map [loop_inv_map].
+ Returns a uconstr option with the result. *)
+Ltac find_bb_inv loop_inv_map loop_bb :=
+ match loop_inv_map with
+ | PolyCons (loop_bb, ?inv) _ =>
+ constr:(PolySome inv)
+ | PolyCons (_, _) ?loop_inv_map2 =>
+ find_bb_inv loop_inv_map2 loop_bb
+ | PolyNil =>
+ constr:(@PolyNone bb_inv_t)
+ end.
+
+(** Find the type assignment for the location [loc] in the [env : env], and return it as a [constr]. *)
+Ltac find_type_assign_in_env loc env :=
+ lazymatch env with
+ | Enil => fail 10 "find_type_assign_in_env: no " loc " in env"
+ | Esnoc ?env2 _ (loc â—â‚—[?Ï€, ?b] ?r @ ?lt)%I =>
+ constr:((loc â—â‚—[Ï€, b] r @ lt)%I)
+ | Esnoc ?env2 _ _ => find_type_assign_in_env loc env2
+ end.
+
+(** Making strings from numbers *)
+Definition digit_to_ascii (n : nat) : ascii :=
+ match n with
+ | 0 => Ascii false false false false true true false false
+ | 1 => Ascii true false false false true true false false
+ | 2 => Ascii false true false false true true false false
+ | 3 => Ascii true true false false true true false false
+ | 4 => Ascii false false true false true true false false
+ | 5 => Ascii true false true false true true false false
+ | 6 => Ascii false true true false true true false false
+ | 7 => Ascii true true true false true true false false
+ | 8 => Ascii false false false true true true false false
+ | 9 => Ascii true false false true true true false false
+ | _ => Ascii false false false false true true false false
+ end.
+Definition nat_to_string (n : nat) : string.
+Proof.
+ refine (string_rev _).
+ refine (lt_wf_rec n (λ _, string) _).
+ intros m rec.
+ refine (match m as m' return m = m' → _ with
+ | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 => λ _, String (digit_to_ascii m) EmptyString
+ | _ => λ Heq, _
+ end eq_refl).
+ refine (String (digit_to_ascii (m `mod` 10)) (rec (m `div` 10) _)).
+ abstract(apply Nat.div_lt; lia).
+Defined.
+
+(** Generates [count] successive fresh identifiers as Coq strings with prefix [prefix].
+ Returns a Coq list [list string]. *)
+(* TODO: potentially take a list of suffix strings, so that we can we also get the variable names for the refinements, e.g. x, y? *)
+Ltac get_idents_rec prefix count acc :=
+ match count with
+ | 0%nat => constr:(acc)
+ | (S ?n)%nat =>
+ (* need to prefix with some symbol because just a number is not a valid ident *)
+ let count_str := eval cbv in (append "_" (nat_to_string n)) in
+ string_to_ident_cps count_str ltac:(fun count_ident =>
+ (* make a fresh identifier *)
+ let Hident := fresh prefix count_ident in
+ (* convert to string so we can store it *)
+ let Hident_str := constr:(ident_to_string! Hident) in
+ let acc := constr:(Hident_str :: acc) in
+ get_idents_rec prefix constr:(n) constr:(acc))
+ end.
+
+(** Finds the type assignments for the locations [local_locs] in the spatial context [spatial_env],
+ and abstracts their refinements to existentials [x_1, ..., x_n] whose names get picked from the list [ex_names : list string].
+ It needs to hold that [length ex_names ≥ length local_locs = n].
+ [base_app] is the name of a context item which will be specialized with the existentially abstracted refinements, to result in a fully applied term [base_app_specialized = base_app x_1 ... x_n] of type [iProp].
+ [base] is a term of type [iProp].
+
+ The tactic instantiates the current goal with the proposition claiming ownership of the locals, [base_app_specialized], and [base], with the existentials quantified in the term.
+
+ The implementation of this is currently quite hacky, mainly to work around Ltac's bad support for working with open terms. *)
+Ltac build_local_sepconj local_locs spatial_env ex_names base base_app :=
+ lazymatch local_locs with
+ | nil =>
+ exact ((base ∗ base_app)%I)
+ | cons ?local ?local_locs2 =>
+ let own_prop := find_type_assign_in_env local spatial_env in
+
+ (* get the name for this *)
+ lazymatch ex_names with
+ | nil => fail 10 "not enough names provided"
+ | ?name :: ?ex_names2 =>
+ string_to_ident_cps name ltac:(fun ident =>
+
+ (* create the type with existentially abstracted refinement *)
+ let abstracted_prop :=
+ lazymatch own_prop with
+ | (?loc â—â‚—[?Ï€, ?b] ?r @ ?lt)%I =>
+ (* crucial: we specialize a hypothesis _below_ the binder here in order to work around Ltac's restrictions for working with open terms *)
+ constr:((∃ ident, loc â—â‚—[Ï€, b] ident @ lt ∗
+ ltac:(specialize (base_app ident); build_local_sepconj local_locs2 spatial_env ex_names2 base base_app))%I)
+ end
+ in
+ exact (abstracted_prop))
+ end
+ end.
+
+(** Composes the loop invariant from the invariant [inv : bb_inv_t] (a constr),
+ the runtime function [FN : runtime_function], the current Iris environment [env : env],
+ and the current contexts [current_E : elctx], [current_L : llctx],
+ and poses it with the identifier [Hinv]. *)
+Ltac pose_loop_invariant Hinv FN inv envs current_E current_L :=
+ (* find Σ *)
+ let Σ :=
+ let tgs := constr:(_ : typeGS _) in
+ match type of tgs with
+ | typeGS ?Σ => Σ
+ end
+ in
+ (* get spatial env *)
+ let envs := eval hnf in envs in
+ let spatial_env :=
+ match envs with
+ | Envs _ ?spatial _ => spatial
+ | _ => fail 10 "infer_loop_invariant: could not determine spatial env"
+ end
+ in
+
+ (* extract the invariants *)
+ let functional_inv := match inv with
+ | (wrap_inv ?inv, _) => uconstr:(inv)
+ end
+ in
+ let llctx_inv := match inv with
+ | (_, wrap_inv ?inv) => uconstr:(inv)
+ end
+ in
+
+ (* find the locals in the context *)
+ let FN := eval hnf in FN in
+ let local_locs := gather_locals FN in
+ (* generate names for the existentially abstracted refinements *)
+ let num_locs := eval cbv in (length local_locs) in
+ let names := get_idents_rec ident:(r) constr:(num_locs) constr:(@nil string) in
+
+ pose (Hinv :=
+ λ (E : elctx) (L : llctx),
+ ltac:(
+ (* specialize the lifetime ctx invariant *)
+ let HEL := fresh "Hel" in
+
+ (*pose (HEL := llctx_inv);*)
+ (*specialize (HEL E L);*)
+
+ pose (HEL := (E = current_E ∧ L = current_L));
+
+ (* pose the loop invariant as a local hypothesis so we can specialize it while building the term *)
+ let Ha := fresh "Hinv" in
+ pose (Ha := functional_inv);
+
+ build_local_sepconj local_locs spatial_env names constr:(((True ∗ ⌜HELâŒ)%I: iProp Σ)) Ha
+ ));
+ (* get rid of all the lets we introduced *)
+ simpl in Hinv.
+
+
+(** * Main automation tactics *)
+Section automation.
+ Context `{!typeGS Σ}.
+
+ Lemma tac_simpl_subst E L Ï€ xs s fn R Ï :
+ typed_stmt Ï€ E L (W.to_stmt (W.subst_stmt xs s)) fn R Ï -∗
+ typed_stmt Ï€ E L (subst_stmt xs (W.to_stmt s)) fn R Ï.
+ Proof. rewrite W.to_stmt_subst. auto. Qed.
+
+ Lemma tac_trigger_tc {A} (a : A) (H : A → Prop) (HP : H a) (T : A → iProp Σ) :
+ T a ⊢ trigger_tc H T.
+ Proof. iIntros "HT". iExists a. iFrame. done. Qed.
+End automation.
+
+Ltac liRIntroduceLetInGoal :=
+ lazymatch goal with
+ | |- @envs_entails ?PROP ?Δ ?P =>
+ let H := fresh "GOAL" in
+ lazymatch P with
+ | @bi_wand ?PROP ?Q ?T =>
+ pose H := (LET_ID T); change_no_check (@envs_entails PROP Δ (@bi_wand PROP Q H))
+ | @typed_val_expr ?Σ ?tG ?π ?E ?L ?e ?T =>
+ pose (H := LET_ID T); change_no_check (@envs_entails PROP Δ (@typed_val_expr Σ tG π E L e H))
+ | @typed_write ?Σ ?tG ?π ?E ?L ?e ?ot ?v ?rt ?ty ?r ?T =>
+ pose (H := LET_ID T); change_no_check (@envs_entails PROP Δ (@typed_write Σ tG π E L e ot v rt ty r H))
+ (* NOTE: these two guys really hurt Qed performance. Not a good idea at all! *)
+ (*| @typed_place ?Σ ?tG ?π ?E ?L ?l ?rto ?lt ?r ?b ?bmin ?P ?T =>*)
+ (*pose (H := LET_ID T); change_no_check (@envs_entails PROP Δ (@typed_place Σ tG π E L l rto lt r b bmin P H))*)
+ (*| @typed_context_fold ?Σ ?tG ?Acc ?P ?M ?π ?E ?L ?m ?tcx ?acc ?T =>*)
+ (*pose (H := LET_ID T);*)
+ (*change_no_check (@envs_entails PROP Δ (@typed_context_fold Σ tG Acc P M π E L m tcx acc H))*)
+ | @typed_bin_op ?Σ ?tG ?π ?E ?L ?v1 ?P1 ?v2 ?P2 ?op ?ot1 ?ot2 ?T =>
+ pose (H := LET_ID T); change_no_check (@envs_entails PROP Δ (@typed_bin_op Σ tG π E L v1 P1 v2 P2 op ot1 ot2 H))
+ end
+ end.
+
+Ltac liRInstantiateEvars_hook := idtac.
+Ltac liRInstantiateEvars :=
+ liRInstantiateEvars_hook;
+ lazymatch goal with
+ | |- (_ < protected ?H)%nat ∧ _ =>
+ (* We would like to use [liInst H (S (protected (EVAR_ID _)))],
+ but this causes a Error: No such section variable or assumption
+ at Qed. time. Maybe this is related to https://github.com/coq/coq/issues/9937 *)
+ instantiate_protected H ltac:(fun H => instantiate (1:=((S (protected (EVAR_ID _))))) in (value of H))
+ (* For some reason [solve_protected_eq] will sometimes not manage to do this.. *)
+ | |- (protected ?a = ?b +:: ?c) ∧ _ =>
+ instantiate_protected a ltac:(fun H => instantiate (1:= (protected (EVAR_ID _) +:: protected (EVAR_ID _))) in (value of H))
+ (* NOTE: Important: We create new evars, instead of instantiating directly with [b] or [c].
+ If [b] or [c] contains another evar, the let-definition for that will not be in scope, which can create trouble at Qed. time *)
+ | |- (protected ?a = ?b -:: ?c) ∧ _ =>
+ instantiate_protected a ltac:(fun H => instantiate (1:= (protected (EVAR_ID _) -:: protected (EVAR_ID _))) in (value of H))
+ (* in this case, we do not want it to instantiate the evar for [a], but rather directly instantiate it with the only possible candidate.
+ (if the other side also contains an evar, we would be instantiating less than we could otherwise) *)
+ | |- (@eq (hlist _ []) _ (protected ?a)) ∧ _ =>
+ instantiate_protected a ltac:(fun H => instantiate (1:= +[]) in (value of H))
+ (*liInst a (+[])*)
+ | |- (@eq (hlist _ []) (protected ?a) _) ∧ _ =>
+ instantiate_protected a ltac:(fun H => instantiate (1 := +[]) in (value of H))
+ (*liInst a (+[])*)
+
+ (* TODO why is this sometimes not done automatically by Lithium? *)
+ (*| |- (protected ?H = ?bla) ∧ _ =>*)
+ (*liInst H bla*)
+
+ (* TODO: figure out how/when to instantiate evars *)
+ | |- envs_entails _ (subsume (_ â—â‚—[?Ï€, ?b] ?r @ ?lt) (_ â—â‚—[_, _] _ @ (protected ?H)) _) => liInst H lt
+ | |- envs_entails _ (subsume (_ â—â‚—[?Ï€, ?b] ?r @ ?lt) (_ â—â‚—[_, protected ?H] _ @ _) _) => liInst H b
+ end.
+
+(** Goto [goto_bb] *)
+Ltac liRGoto goto_bb :=
+ lazymatch goal with
+ | |- envs_entails ?Δ (typed_stmt ?Ï€ ?E ?L (Goto _) ?fn ?R ?Ï) =>
+ first [
+ (* try to find an inductive hypothesis we obtained previously *)
+ notypeclasses refine (tac_fast_apply (type_goto_precond E L Ï€ _ _ fn R Ï) _);
+ progress liFindHyp FICSyntactic
+ | (* if we jump to a loop head, initiate Löb induction *)
+ lazymatch goal with
+ | H : bb_inv_map_marker ?LOOP_INV_MAP |- _ =>
+ let loop_inv_map := eval hnf in LOOP_INV_MAP in
+ (* find the loop invariant *)
+ let inv := find_bb_inv loop_inv_map goto_bb in
+ let inv := match inv with
+ | PolySome ?inv => inv
+ | PolyNone =>
+ (* we are not jumping to a loop head *)
+ fail 1 "infer_loop_invariant: no loop invariant found"
+ end in
+ (* pose the composed loop invariant *)
+ string_to_ident_cps goto_bb ltac:(fun bb_ident =>
+ let Hinv := fresh "Hinv_" bb_ident in
+ pose_loop_invariant Hinv fn inv Δ E L;
+ (* finally initiate Löb *)
+ notypeclasses refine (tac_fast_apply (typed_goto_acc _ _ _ _ _ Hinv goto_bb _ _ _) _);
+ [unfold_code_marker_and_compute_map_lookup| ]
+ )
+ end
+ | (* do a direct jump *)
+ notypeclasses refine (tac_fast_apply (type_goto E L Ï€ _ fn R _ Ï _) _);
+ [unfold_code_marker_and_compute_map_lookup|]
+ ]
+ end.
+
+Ltac liRStmt :=
+ lazymatch goal with
+ | |- envs_entails ?Δ (typed_stmt ?Ï€ ?E ?L ?s ?fn ?R ?Ï) =>
+ lazymatch s with
+ | subst_stmt ?xs ?s =>
+ let s' := W.of_stmt s in
+ change (subst_stmt xs s) with (subst_stmt xs (W.to_stmt s'));
+ refine (tac_fast_apply (tac_simpl_subst E L Ï€ _ _ fn R Ï) _); simpl; unfold W.to_stmt, W.to_expr
+ | _ =>
+ let s' := W.of_stmt s in
+ lazymatch s' with
+ | W.AssignSE _ _ _ _ _ => notypeclasses refine (tac_fast_apply (type_assign E L Ï€ _ _ _ _ fn R _ Ï) _)
+ | W.Return _ => notypeclasses refine (tac_fast_apply (type_return E L Ï€ _ fn R Ï) _)
+ | W.IfS _ _ _ _ => notypeclasses refine (tac_fast_apply (type_if E L Ï€ _ _ _ fn R Ï) _)
+ | W.Switch _ _ _ _ _ => notypeclasses refine (tac_fast_apply (type_switch E L Ï€ _ _ _ _ _ fn R Ï) _)
+ | W.Assert _ _ _ => notypeclasses refine (tac_fast_apply (type_assert E L _ _ fn Ï€ R Ï) _)
+ | W.Goto ?bid => liRGoto bid
+ | W.ExprS _ _ => notypeclasses refine (tac_fast_apply (type_exprs E L _ _ fn R Ï€ Ï) _)
+ | W.SkipS _ => notypeclasses refine (tac_fast_apply (type_skips' E L _ fn R Ï€ Ï) _)
+ | W.StuckS => exfalso
+ | W.AnnotStmt _ (StartLftAnnot ?κ ?κs) _ => notypeclasses refine (tac_fast_apply (type_startlft E L κ κs _ fn R Ï€ Ï) _)
+ | W.AnnotStmt _ (AliasLftAnnot ?κ ?κs) _ => notypeclasses refine (tac_fast_apply (type_alias_lft E L κ κs _ fn R Ï€ Ï) _)
+ | W.AnnotStmt _ (EndLftAnnot ?κ) _ => notypeclasses refine (tac_fast_apply (type_endlft E L Ï€ κ _ fn R Ï) _)
+ | W.AnnotStmt _ (StratifyContextAnnot) _ => notypeclasses refine (tac_fast_apply (type_stratify_context_annot E L Ï€ _ fn R Ï) _)
+ | W.AnnotStmt _ (CopyLftNameAnnot ?n1 ?n2) _ => notypeclasses refine (tac_fast_apply (type_copy_lft_name Ï€ E L n1 n2 _ fn R Ï) _)
+ | W.AnnotStmt _ (DynIncludeLftAnnot ?n1 ?n2) _ => notypeclasses refine (tac_fast_apply (type_dyn_include_lft Ï€ E L n1 n2 _ fn R Ï) _)
+ | W.AnnotStmt _ (ExtendLftAnnot ?κ) _ => notypeclasses refine (tac_fast_apply (type_extendlft E L Ï€ κ _ fn R Ï) _)
+ | _ => fail "do_stmt: unknown stmt" s
+ end
+ end
+ end.
+
+Ltac liRIntroduceTypedStmt :=
+ lazymatch goal with
+ | |- @envs_entails ?PROP ?Δ (introduce_typed_stmt ?Ï€ ?E ?L ?Ï ?fn ?lsa ?lsv ?lya ?lyv ?R) =>
+ iEval (rewrite /introduce_typed_stmt /to_runtime_function /subst_function !fmap_insert fmap_empty; simpl_subst);
+ lazymatch goal with
+ | |- @envs_entails ?PROP ?Δ (@typed_stmt ?Σ ?tG ?Ï€ ?E ?L ?s ?fn ?R ?Ï) =>
+ let Hfn := fresh "FN" in
+ let HR := fresh "R" in
+ pose (Hfn := (CODE_MARKER fn));
+ pose (HR := (RETURN_MARKER R));
+ change_no_check (@envs_entails PROP Δ (@typed_stmt Σ tG Ï€ E L s Hfn HR Ï));
+ iEval (simpl) (* To simplify f_init *)
+ (*notypeclasses refine (tac_fast_apply (tac_simplify_elctx _ _ _ _ _ _ _ _ _) _); [simplify_elctx | ]*)
+ end
+ end.
+
+Ltac liRExpr :=
+ lazymatch goal with
+ | |- envs_entails ?Δ (typed_val_expr ?π ?E ?L ?e ?T) =>
+ let e' := W.of_expr e in
+ lazymatch e' with
+ | W.Val _ => notypeclasses refine (tac_fast_apply (type_val E L _ π T) _)
+ | W.Loc _ => notypeclasses refine (tac_fast_apply (type_val E L _ π T) _)
+ | W.Use _ _ true _ => notypeclasses refine (tac_fast_apply (type_use E L _ T _ _ π) _)
+ | W.Borrow Mut _ _ _ => notypeclasses refine (tac_fast_apply (type_mut_bor E L T _ π _ _) _)
+ | W.Borrow Shr _ _ _ => notypeclasses refine (tac_fast_apply (type_shr_bor E L T _ π _ _) _)
+ | W.AddrOf _ _ => notypeclasses refine (tac_fast_apply (type_mut_addr_of π E L _ T) _)
+ | W.BinOp _ _ _ _ _ => notypeclasses refine (tac_fast_apply (type_bin_op E L _ _ _ _ _ π T) _)
+ | W.UnOp _ _ _ => notypeclasses refine (tac_fast_apply (type_un_op E L _ _ _ π T) _)
+ | W.Call _ _ _ => notypeclasses refine (tac_fast_apply (type_call E L π T _ _ _) _)
+ | W.AnnotExpr _ ?a _ => notypeclasses refine (tac_fast_apply (type_annot_expr E L _ a _ π T) _)
+ | W.StructInit ?sls ?init => notypeclasses refine (tac_fast_apply (type_struct_init π E L sls _ T) _)
+ | W.EnumInit ?els ?variant ?rsty ?init => notypeclasses refine (tac_fast_apply (type_enum_init π E L els variant rsty _ T) _)
+ | W.IfE _ _ _ _ => notypeclasses refine (tac_fast_apply (type_ife E L _ _ _ π T) _)
+ | W.LogicalAnd _ _ _ _ _ => notypeclasses refine (tac_fast_apply (type_logical_and E L _ _ _ _ π T) _)
+ | W.LogicalOr _ _ _ _ _ => notypeclasses refine (tac_fast_apply (type_logical_or E L _ _ _ _ π T) _)
+ | _ => fail "do_expr: unknown expr" e
+ end
+ end.
+
+(* Initialize context folding by gathering up the type context. *)
+Ltac gather_location_list env :=
+ match env with
+ | Enil => uconstr:([])
+ | Esnoc ?env' _ ?p =>
+ let rs := gather_location_list env' in
+ lazymatch p with
+ | (?l â—â‚—[?Ï€, Owned false] ?r @ ?lty)%I =>
+ uconstr:(l :: rs)
+ | _ => uconstr:(rs)
+ end
+ end.
+Ltac liRContextStratifyInit :=
+ lazymatch goal with
+ | |- envs_entails ?envs (typed_pre_context_fold ?Ï€ ?E ?L (CtxFoldStratifyAllInit) ?T) =>
+ let envs := eval hnf in envs in
+ match envs with
+ | Envs _ ?spatial _ =>
+ let tctx := gather_location_list spatial in
+ notypeclasses refine (tac_fast_apply (typed_context_fold_stratify_init tctx π E L T) _)
+ | _ => fail 1000 "gather_tctx: cannot determine Iris context"
+ end
+ end.
+Ltac liRContextStratifyStep :=
+ lazymatch goal with
+ | |- envs_entails _ (typed_context_fold_step ?AI ?Ï€ ?E ?L (CtxFoldStratifyAll) ?l ?lt ?r ?tctx ?acc ?T) =>
+ notypeclasses refine (tac_fast_apply (typed_context_fold_step_stratify π E L l lt r tctx _ _ T) _)
+ end.
+
+Ltac liRContextExtractInit :=
+ lazymatch goal with
+ | |- envs_entails ?envs (typed_pre_context_fold ?π ?E ?L (CtxFoldExtractAllInit ?κ) ?T) =>
+ let envs := eval hnf in envs in
+ match envs with
+ | Envs _ ?spatial _ =>
+ let tctx := gather_location_list spatial in
+ notypeclasses refine (tac_fast_apply (typed_context_fold_extract_init tctx π E L κ T) _)
+ | _ => fail 1000 "gather_tctx: cannot determine Iris context"
+ end
+ end.
+Ltac liRContextExtractStep :=
+ lazymatch goal with
+ | |- envs_entails _ (typed_context_fold_step ?AI ?π ?E ?L (CtxFoldExtractAll ?κ) ?l ?lt ?r ?tctx ?acc ?T) =>
+ notypeclasses refine (tac_fast_apply (typed_context_fold_step_extract π E L l lt r tctx _ _ κ T) _)
+ end.
+
+(** Endlft trigger automation for [Inherit] context items *)
+Ltac gather_on_endlft_worklist κ env :=
+ match env with
+ | Enil => uconstr:([])
+ | Esnoc ?env' _ ?p =>
+ let rs := gather_on_endlft_worklist κ env' in
+ lazymatch p with
+ | (Inherit κ ?key ?P)%I =>
+ uconstr:(((existT _ key : sigT (@id Type)), P) :: rs)
+ | _ => uconstr:(rs)
+ end
+ end.
+Ltac liROnEndlftTriggerInit :=
+ lazymatch goal with
+ | |- envs_entails ?envs (typed_on_endlft_pre ?π ?E ?L ?κ ?T) =>
+ let envs := eval hnf in envs in
+ match envs with
+ | Envs _ ?spatial _ =>
+ let worklist := gather_on_endlft_worklist κ spatial in
+ notypeclasses refine (tac_fast_apply (typed_on_endlft_pre_init worklist π E L κ T) _)
+ | _ => fail 1000 "liROnEndlftTriggerInit: cannot determine Iris context"
+ end
+ end.
+
+Ltac liRJudgement :=
+ lazymatch goal with
+ (* place finish *)
+ | |- envs_entails _ (typed_place_finish ?Ï€ ?E ?L _ _ _ _ _ _ _ _ _ ?T) =>
+ (* simplify eqcasts and the match on strong/weak branch *)
+ cbn
+ (* write *)
+ | |- envs_entails _ (typed_write ?Ï€ ?E ?L _ _ _ ?ty ?r ?T) =>
+ notypeclasses refine (tac_fast_apply (type_write E L T _ _ _ _ _ ty r π _) _); [ solve [refine _ ] |]
+ (* read *)
+ | |- envs_entails _ (typed_read ?Ï€ ?E ?L _ _ ?T) =>
+ notypeclasses refine (tac_fast_apply (type_read π E L T _ _ _ _) _); [ solve [refine _ ] |]
+ (* borrow mut *)
+ | |- envs_entails _ (typed_borrow_mut ?Ï€ ?E ?L _ _ _ ?T) =>
+ notypeclasses refine (tac_fast_apply (type_borrow_mut E L T _ _ _ π _ _) _); [solve [refine _] |]
+ (* borrow shr *)
+ | |- envs_entails _ (typed_borrow_shr ?Ï€ ?E ?L _ _ _ ?T) =>
+ notypeclasses refine (tac_fast_apply (type_borrow_shr E L T _ _ _ _ π _) _); [solve [refine _] |]
+ (* addr_of mut *)
+ | |- envs_entails _ (typed_addr_of_mut ?Ï€ ?E ?L _ ?T) =>
+ notypeclasses refine (tac_fast_apply (type_addr_of_mut π E L _ T _ _) _); [solve [refine _] |]
+ (* end context folding *)
+ | |- envs_entails _ (typed_context_fold_end ?AI ?Ï€ ?E ?L ?acc ?T) =>
+ notypeclasses refine (tac_fast_apply (type_context_fold_end AI E L π acc T) _)
+ (* initialize context folding *)
+ | |- envs_entails _ (typed_pre_context_fold ?Ï€ ?E ?L (CtxFoldStratifyAllInit) ?T) =>
+ liRContextStratifyInit
+ (* unblocking step *)
+ | |- envs_entails _ (typed_context_fold_step ?AI ?Ï€ ?E ?L (CtxFoldStratifyAll) ?l ?lt ?r ?tctx ?acc ?T) =>
+ liRContextStratifyStep
+ (* initialize context folding *)
+ | |- envs_entails _ (typed_pre_context_fold ?π ?E ?L (CtxFoldExtractAllInit ?κ) ?T) =>
+ liRContextExtractInit
+ (* unblocking step *)
+ | |- envs_entails _ (typed_context_fold_step ?AI ?π ?E ?L (CtxFoldExtractAll ?κ) ?l ?lt ?r ?tctx ?acc ?T) =>
+ liRContextExtractStep
+ (* initialize OnEndlft triggers *)
+ | |- envs_entails _ (typed_on_endlft_pre ?π ?E ?L ?κ ?T) =>
+ liROnEndlftTriggerInit
+ (* trigger tc search *)
+ | |- envs_entails _ (trigger_tc ?H ?T) =>
+ notypeclasses refine (tac_fast_apply (tac_trigger_tc _ _ _ _) _); [solve [refine _] | ]
+ (* stratification for structs *)
+ | |- envs_entails _ (@stratify_ltype_struct_iter _ _ ?Ï€ ?E ?L ?mu ?mdu ?ma _ ?m ?l ?i ?sls ?rts ?lts ?rs ?k ?T) =>
+ match rts with
+ | [] =>
+ notypeclasses refine (tac_fast_apply (stratify_ltype_struct_iter_nil π E L mu mdu ma m l sls k i T) _)
+ | _ :: _ =>
+ notypeclasses refine (tac_fast_apply (stratify_ltype_struct_iter_cons π E L mu mdu ma m l sls i _ _ _ k _) _)
+ end
+ end.
+
+(* TODO Maybe this should rather be a part of Lithium? *)
+Ltac unfold_introduce_direct :=
+ lazymatch goal with
+ | |- envs_entails ?E ?G =>
+ let E' := eval unfold introduce_direct in E in
+ change_no_check (envs_entails E' G)
+ end.
+
+(* This does everything *)
+Ltac liRStep :=
+ liEnsureInvariant;
+ try liRIntroduceLetInGoal;
+ (* TODO these are all hacks right now *)
+ simp_ltypes;
+ simplify_layout_goal;
+ first [
+ liRInstantiateEvars (* must be before do_side_cond and do_extensible_judgement *)
+ | liRStmt
+ | liRIntroduceTypedStmt
+ | liRExpr
+ | liRJudgement
+ | liStep
+]; try unfold_introduce_direct; liSimpl.
+
+Tactic Notation "liRStepUntil" open_constr(id) :=
+ repeat lazymatch goal with
+ | |- @environments.envs_entails _ _ ?P =>
+ lazymatch P with
+ | id _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ _ => fail
+ | id _ _ _ _ _ => fail
+ | id _ _ _ _ => fail
+ | id _ _ => fail
+ | id _ => fail
+ | id => fail
+ | _ => liRStep
+ end
+ | _ => liRStep
+ end; liShow.
+
+(** * Tactics for starting a function *)
+(* Recursively destruct a product in hypothesis H, using the given name as template. *)
+Ltac destruct_product_hypothesis name H :=
+ match goal with
+ | H : _ * _ |- _ => let tmp1 := fresh "tmp" in
+ let tmp2 := fresh "tmp" in
+ destruct H as [tmp1 tmp2];
+ destruct_product_hypothesis name tmp1;
+ destruct_product_hypothesis name tmp2
+ | |- _ => let id := fresh name in
+ rename H into id
+ end.
+
+Ltac prepare_initial_coq_context :=
+ (* The automation assumes that all products in the context are destructed, see liForall *)
+ repeat lazymatch goal with
+ | H : _ * _ |- _ => destruct_product_hypothesis H H
+ (*| H : named_binder ?n |- _ =>*)
+ (*let temp := fresh "tmp" in*)
+ (*destruct H as [tmp];*)
+ (*rename_by_string tmp n*)
+ | H : unit |- _ => destruct H
+ end.
+
+Ltac inv_arg_ly_rec Harg_ly :=
+ match type of Harg_ly with
+ | Forall2 _ (?x:: ?L1) (?y :: ?L2) =>
+ let H1 := fresh in let H2 := fresh in
+ apply Forall2_cons_inv in Harg_ly as [H1 Harg_ly];
+ inv_arg_ly_rec Harg_ly
+ | Forall2 _ [] [] =>
+ clear Harg_ly
+ end.
+Ltac inv_arg_ly Harg_ly :=
+ simpl in Harg_ly; unfold fn_arg_layout_assumptions in Harg_ly; inv_arg_ly_rec Harg_ly; simplify_eq.
+
+Ltac inv_local_ly_rec Harg_ly :=
+ match type of Harg_ly with
+ | Forall2 _ (?x:: ?L1) (?y :: ?L2) =>
+ let H1 := fresh in let H2 := fresh in
+ apply Forall2_cons_inv in Harg_ly as [H1 Harg_ly];
+ inv_local_ly_rec Harg_ly
+ | Forall2 _ [] [] =>
+ clear Harg_ly
+ end.
+Ltac inv_local_ly Harg_ly :=
+ simpl in Harg_ly; unfold fn_local_layout_assumptions in Harg_ly; inv_local_ly_rec Harg_ly; simplify_eq.
+
+Section tac.
+ Context `{!typeGS Σ}.
+
+ Lemma intro_typed_function {A} (n : nat) π (fn : function) (local_sts : list syn_type) (fp : prod_vec lft n → A → fn_params) :
+ (∀ κs x (Ï : lft),
+ â–¡ (
+ let lya := fn.(f_args).*2 in
+ let lyv := fn.(f_local_vars).*2 in
+ ⌜fn_arg_layout_assumptions (fp κs x).(fp_atys) lya⌠-∗
+ ⌜fn_local_layout_assumptions local_sts lyv⌠-∗
+ ∀ (lsa : vec loc (length (fp κs x).(fp_atys))) (lsv : vec loc (length fn.(f_local_vars))),
+ let Qinit :=
+ ([∗list] l;t∈lsa;(fp κs x).(fp_atys), let '(existT rt (ty, r)) := t in l â—â‚—[Ï€, Owned false] PlaceIn r @ (â— ty)) ∗
+ ([∗list] l;p∈lsv;local_sts, (l â—â‚—[Ï€, Owned false] (PlaceIn ()) @ (â— (uninit p)))) ∗
+ (fp κs x).(fp_Pa) π in
+ let E := ((fp κs x).(fp_elctx) Ï) in
+ let L := [Ï âŠ‘â‚—{0} []] in
+ ∃ E' E'', ⌜E = E'⌠∗ ⌜E' ≡ₚ E''⌠∗
+ (credit_store 0 0 -∗ introduce_with_hooks E'' L (Qinit) (λ L2,
+ introduce_typed_stmt Ï€ E'' L2 Ï fn lsa lsv lya lyv (fn_ret_prop Ï€ (fp κs x).(fp_fr)))))) -∗
+ typed_function π fn local_sts fp.
+ Proof.
+ iIntros "#Ha".
+ rewrite /typed_function.
+ iIntros (???) "!# Hx1 Hx2".
+ iIntros (lsa lsv) "(Hstore & Hinit)".
+ rewrite /introduce_typed_stmt.
+ iIntros "#CTX #HE HL".
+ iApply fupd_wps.
+ iPoseProof ("Ha" with "Hx1 Hx2") as "HT".
+ iDestruct ("HT" $! lsa lsv) as "(%E' & %E'' & <- & %Heq & HT)".
+ iPoseProof (elctx_interp_permut with "HE") as "HE'". { symmetry. apply Heq. }
+ iMod ("HT" with "Hstore [] HE' HL Hinit") as "(%L2 & HL & HT)"; first done.
+ iApply ("HT" with "CTX HE' HL").
+ Qed.
+End tac.
+
+(* IMPORTANT: We need to make sure to never call simpl while the code
+(fn) is part of the goal, because simpl seems to take exponential time
+in the number of blocks! *)
+(* TODO: don't use i... tactics here *)
+Tactic Notation "start_function" constr(fnname) "(" simple_intropattern(κs) ")" "(" simple_intropattern(x) ")" :=
+ intros;
+ inv_layout_alg;
+ repeat iIntros "#?";
+ iApply (intro_typed_function);
+ iIntros ( κs x Ï ) "!#";
+ let Harg_ly := fresh "Harg_ly" in
+ let Hlocal_ly := fresh "Hlocal_ly" in
+ iIntros (_ _);
+ let lsa := fresh "lsa" in let lsv := fresh "lsv" in
+ iIntros (lsa lsv);
+ prepare_initial_coq_context;
+ iExists _, _; iSplitR;
+ [iPureIntro; solve [simplify_elctx] | ];
+ iSplitR; [iPureIntro; solve[reorder_elctx] | ];
+ inv_vec lsv; inv_vec lsa.
+
+Tactic Notation "prepare_parameters" "(" ident_list(i) ")" :=
+ revert i; repeat liForall.
+
+
+Ltac liRSplitBlocksIntro :=
+ repeat (
+ liEnsureInvariant;
+ first [
+ liSep
+ | liWand
+ | liImpl
+ | liForall
+ | liExist true
+ | liUnfoldLetGoal]; liSimpl);
+ liShow.
+
+
+Ltac sidecond_hook_list :=
+ notypeclasses refine (proj2 (Forall_Forall_cb _ _) _); simpl; (first
+ [ exact I | split_and ! ]);
+ sidecond_hook.
+
+(* TODO : more sideconditions *)
+Ltac sidecond_hook ::=
+ unfold_no_enrich;
+ intros;
+ match goal with
+ | |- Forall ?P ?l =>
+ sidecond_hook_list
+ | |- lctx_lft_alive ?E ?L ?κ =>
+ solve_lft_alive
+ | |- lctx_lft_incl ?E ?L ?κ1 ?κ2 =>
+ solve_lft_incl
+ | |- lctx_bor_kind_incl ?E ?L ?b1 ?b2 =>
+ solve_bor_kind_incl
+ | |- lctx_bor_kind_alive ?E ?L ?b =>
+ solve_bor_kind_alive
+ | |- lctx_bor_kind_direct_incl ?E ?L ?b1 ?b2 =>
+ solve_bor_kind_direct_incl
+ | |- elctx_sat ?E ?L ?E' =>
+ solve_elctx_sat
+ | |- fn_arg_layout_assumptions ?L1 ?L2 =>
+ repeat first [constructor | done]
+ | |- lctx_bor_kind_outlives ?E ?L ?b ?κ =>
+ solve_bor_kind_outlives
+ | |- ty_has_op_type _ _ _ =>
+ solve_ty_has_op_type
+ | |- layout_wf _ =>
+ solve_layout_wf
+ | |- syn_type_compat _ _ =>
+ solve_syn_type_compat
+ | |- _ =>
+ try solve [solve_layout_size | solve_layout_eq | solve_op_alg];
+ try solve_layout_alg
+ end.
+
+
+(** ** Proofmode support for manual proofs *)
+Lemma tac_typed_val_expr_bind' `{!typeGS Σ} π E L K e T :
+ typed_val_expr π E L (W.to_expr e) (λ L' v rt ty r,
+ v â—áµ¥{Ï€} r @ ty -∗ typed_val_expr Ï€ E L' (W.to_expr (W.fill K (W.Val v))) T) -∗
+ typed_val_expr π E L (W.to_expr (W.fill K e)) T.
+Proof.
+ iIntros "He".
+ iIntros (Φ) "#CTX #HE HL Hcont".
+ iApply tac_wp_bind'.
+ iApply ("He" with "CTX HE HL").
+ iIntros (L' v rt ty r) "HL Hv Hcont'".
+ iApply ("Hcont'" with "Hv CTX HE HL"). done.
+Qed.
+Lemma tac_typed_val_expr_bind `{!typeGS Σ} π E L e Ks e' T :
+ W.find_expr_fill e false = Some (Ks, e') →
+ typed_val_expr π E L (W.to_expr e') (λ L' v rt ty r,
+ if Ks is [] then T L' v rt ty r else
+ v â—áµ¥{Ï€} r @ ty -∗ typed_val_expr Ï€ E L' (W.to_expr (W.fill Ks (W.Val v))) T) -∗
+ typed_val_expr π E L (W.to_expr e) T.
+Proof.
+ move => /W.find_expr_fill_correct ->. move: Ks => [|K Ks] //.
+ { auto. }
+ move: (K::Ks) => {K}Ks. by iApply tac_typed_val_expr_bind'.
+Qed.
+
+Tactic Notation "typed_val_expr_bind" :=
+ iStartProof;
+ lazymatch goal with
+ | |- envs_entails _ (typed_val_expr ?Ï€ ?E ?L ?e ?T) =>
+ let e' := W.of_expr e in change (typed_val_expr π E L e T) with (typed_val_expr π E L (W.to_expr e') T);
+ iApply tac_typed_val_expr_bind; [done |];
+ unfold W.to_expr; simpl
+ | _ => fail "typed_val_expr_bind: not a 'typed_val_expr'"
+ end.
+
+Lemma tac_typed_stmt_bind `{!typeGS Σ} Ï€ E L s e Ks fn Ï T :
+ W.find_stmt_fill s = Some (Ks, e) →
+ typed_val_expr π E L (W.to_expr e) (λ L' v rt ty r,
+ v â—áµ¥{Ï€} r @ ty -∗ typed_stmt Ï€ E L' (W.to_stmt (W.stmt_fill Ks (W.Val v))) fn T Ï) -∗
+ typed_stmt Ï€ E L (W.to_stmt s) fn T Ï.
+Proof.
+ move => /W.find_stmt_fill_correct ->. iIntros "He".
+ iIntros "#CTX #HE HL".
+ rewrite stmt_wp_eq. iIntros (? rf ?) "?".
+ have [Ks' HKs']:= W.stmt_fill_correct Ks rf. rewrite HKs'.
+ iApply wp_bind.
+ iApply (wp_wand with "[He HL]").
+ { iApply ("He" with "CTX HE HL").
+ iIntros (L' v rt ty r) "HL Hv Hcont".
+ iApply ("Hcont" with "Hv CTX HE HL"). }
+ iIntros (v) "HWP".
+ rewrite -(HKs' (W.Val _)) /W.to_expr.
+ rewrite stmt_wp_eq /stmt_wp_def.
+ iApply ("HWP" with "[//]"). done.
+Qed.
+
+Tactic Notation "typed_stmt_bind" :=
+ iStartProof;
+ lazymatch goal with
+ | |- envs_entails _ (typed_stmt ?Ï€ ?E ?L ?s ?fn ?R ?Ï) =>
+ let s' := W.of_stmt s in change (typed_stmt Ï€ E L s fn R Ï) with (typed_stmt Ï€ E L (W.to_stmt s') fn R Ï);
+ iApply tac_typed_stmt_bind; [done |];
+ unfold W.to_expr, W.to_stmt; simpl; unfold W.to_expr; simpl
+ | _ => fail "typed_stmt_bind: not a 'typed_stmt'"
+ end.
+
+Lemma intro_typed_stmt `{!typeGS Σ} fn R Ï Ï€ E L s :
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ typed_stmt Ï€ E L s fn R Ï -∗
+ WPs s {{ f_code (rf_fn fn), typed_stmt_post_cond Ï€ Ï fn R}}.
+Proof.
+ iIntros "#CTX #HE HL Hs". iApply ("Hs" with "CTX HE HL").
+Qed.
+
+Ltac to_typed_stmt SPEC :=
+ iStartProof;
+ lazymatch goal with
+ | FN : runtime_function |- envs_entails _ (WPs ?s {{ ?code, ?c }}) =>
+ iApply (intro_typed_stmt FN with SPEC)
+ end.
+
+Lemma fupd_typed_stmt `{!typeGS Σ} Ï€ E L s rf R Ï :
+ ⊢ (|={⊤}=> typed_stmt Ï€ E L s rf R Ï) -∗ typed_stmt Ï€ E L s rf R Ï.
+Proof.
+ iIntros "HT". iIntros "CTX HE HL". iMod ("HT") as "HT". iApply ("HT" with "CTX HE HL").
+Qed.
+
+(** ** Hints for automation *)
+Global Hint Extern 0 (LayoutSizeEq _ _) => rewrite /LayoutSizeEq; solve_layout_size : typeclass_instances.
+Global Hint Extern 0 (LayoutSizeLe _ _) => rewrite /LayoutSizeLe; solve_layout_size : typeclass_instances.
+
+(* This should instead be solved by [solve_ty_has_op_type]. *)
+Global Arguments ty_has_op_type : simpl never.
+
+(* Simplifying this can lead to problems in some cases when used in specifications. *)
+Global Arguments replicate : simpl never.
+(* We don't want this to simplify away the zero case, as that can be a valuable hint. *)
+Global Arguments freeable_nz : simpl never.
+
+(* should not be visible for automation *)
+Global Typeclasses Opaque ty_shr.
+Global Typeclasses Opaque ty_own_val.
+
+Global Arguments plist : simpl never.
+
+Global Typeclasses Opaque Rel2.
+Global Arguments Rel2 : simpl never.
+
+Global Hint Unfold OffsetLocSt : core.
+
+(* In my experience, this has led to more problems with [normalize_autorewrite] rewriting below definitions too eagerly. *)
+Export Unset Keyed Unification.
+
+Create HintDb unfold_tydefs.
+
+(** Lithium hook *)
+Ltac normalize_hook ::=
+ rewrite /size_of_st;
+ (*simplify_layout_goal;*)
+ normalize_autorewrite.
+
+Ltac after_intro_hook ::=
+ inv_layout_alg.
+
+(** Lithium hooks for [solve_goal]: called for remaining sideconditions *)
+Lemma unfold_int_elem_of_it (z : Z) (it : int_type) :
+ z ∈ it = (min_int it ≤ z ∧ z ≤ max_int it)%Z.
+Proof. done. Qed.
+
+Ltac unfold_common_defs :=
+ unfold
+ (* Unfold [aligned_to] and [Z.divide] as lia can work with the underlying multiplication. *)
+ aligned_to,
+ (*Z.divide,*)
+ (* Unfold [addr] since [lia] may get stuck due to [addr]/[Z] mismatches. *)
+ addr,
+ (* Layout *)
+ ly_size, ly_with_align, ly_align_log, layout_wf,
+ unit_sl,
+ (* Integer bounds *)
+ max_int, min_int, int_half_modulus, int_modulus,
+ bits_per_int, bytes_per_int,
+ (* Address bounds *)
+ max_alloc_end, min_alloc_start, bytes_per_addr,
+ (* Other byte-level definitions *)
+ bits_per_byte in *.
+
+
+Ltac solve_goal_normalized_prepare_hook ::=
+ try rewrite -> unfold_int_elem_of_it in *;
+ autounfold in *;
+ simplify_layout_assum;
+ simplify_layout_goal;
+ augment_context;
+ unfold_no_enrich;
+ simpl in *;
+ (*rewrite /ly_size/ly_align_log //= in **)
+ idtac
+.
diff --git a/theories/rust_typing/automation/dune b/theories/rust_typing/automation/dune
new file mode 100644
index 0000000000000000000000000000000000000000..2afd4c4b79788d4ba9c625845ab79b7bb829c1dd
--- /dev/null
+++ b/theories/rust_typing/automation/dune
@@ -0,0 +1,6 @@
+(coq.theory
+ (name refinedrust.automation)
+ (package refinedrust)
+ (flags -w -notation-overridden -w -redundant-canonical-projection)
+ (synopsis "RefinedRust automation components")
+ (theories caesium refinedrust lithium))
diff --git a/theories/rust_typing/automation/ident_to_string.v b/theories/rust_typing/automation/ident_to_string.v
new file mode 100644
index 0000000000000000000000000000000000000000..3c6f91692cb80a3c35cca580be7cb1a2a5fea0ad
--- /dev/null
+++ b/theories/rust_typing/automation/ident_to_string.v
@@ -0,0 +1,134 @@
+(* from https://github.com/mit-plv/coqutil/blob/master/src/coqutil/Macros/ident_to_string.v *)
+(* LICENSE:
+The MIT License (MIT)
+
+Copyright (c) 2018-2019 the coqutil authors (see the AUTHORS file).
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+ *)
+(* AUTHORS:
+Massachusetts Institute of Technology
+ *)
+
+Require Import Coq.Strings.String.
+Require Import Ltac2.Ltac2.
+Require Ltac2.Option.
+
+Module Import IdentToStringImpl .
+ (* Takes a list of powers instead of one power and dividing because
+ Ltac2 does not have integer division: https://github.com/coq/coq/issues/13802 *)
+ Ltac2 rec int_to_bits_rec(powers: int list)(val: int) :=
+ match powers with
+ | p :: rest =>
+ if Int.le p val
+ then true :: int_to_bits_rec rest (Int.sub val p)
+ else false :: int_to_bits_rec rest val
+ | [] => []
+ end.
+
+ (* [2^(n-1); ..., 2^0] *)
+ Ltac2 rec powers_of_two(n: int) :=
+ if Int.equal n 1 then [1] else
+ let r := powers_of_two (Int.sub n 1) in
+ match r with
+ | h :: t => Int.mul 2 h :: r
+ | [] => []
+ end.
+
+ Ltac2 char_to_bits(c: char) :=
+ int_to_bits_rec (powers_of_two 8) (Char.to_int c).
+
+ Ltac2 bool_to_coq(b: bool) :=
+ if b then constr:(true) else constr:(false).
+
+ Ltac2 mkApp(f: constr)(args: constr array) :=
+ Constr.Unsafe.make (Constr.Unsafe.App f args).
+
+ Ltac2 char_to_ascii(c: char) :=
+ mkApp constr:(Ascii.Ascii)
+ (Array.of_list (List.rev (List.map bool_to_coq (char_to_bits c)))).
+
+ Ltac2 rec string_to_coq_rec(s: string)(i: int)(acc: constr) :=
+ if Int.lt i 0 then acc else
+ let c := char_to_ascii (String.get s i) in
+ string_to_coq_rec s (Int.sub i 1) constr:(String.String $c $acc).
+
+ Ltac2 string_to_coq(s: string) :=
+ string_to_coq_rec s (Int.sub (String.length s) 1) constr:(String.EmptyString).
+
+ Ltac2 ident_to_coq(i: ident) := string_to_coq (Ident.to_string i).
+
+ Ltac2 varconstr_to_coq(c: constr) :=
+ match Constr.Unsafe.kind c with
+ | Constr.Unsafe.Var i => ident_to_coq i
+ | _ => Control.throw_invalid_argument "not a Constr.Unsafe.Var"
+ end.
+
+ (* Test:
+ Ltac2 Eval string_to_coq "hello world".
+ Goal forall a: nat, a = a. intros.
+ Ltac2 Eval varconstr_to_coq constr:(a).
+ *)
+
+ Ltac2 exact_varconstr_as_string(c: constr) :=
+ let s := varconstr_to_coq c in exact $s.
+
+ Ltac exact_varconstr_as_string :=
+ ltac2:(c |- exact_varconstr_as_string (Option.get (Ltac1.to_constr c))).
+
+ Inductive PassStringFromLtac2ToLtac1 := mkPassStringFromLtac2ToLtac1 (s: string).
+
+ Ltac2 pose_varconstr_as_wrapped_string(c: constr) :=
+ let s := varconstr_to_coq c in pose (mkPassStringFromLtac2ToLtac1 $s).
+
+ Ltac pose_varconstr_as_wrapped_string :=
+ ltac2:(s |- pose_varconstr_as_wrapped_string (Option.get (Ltac1.to_constr s))).
+
+ Ltac varconstr_to_string c :=
+ let __ := match constr:(Set) with
+ | _ => pose_varconstr_as_wrapped_string c
+ end in
+ match goal with
+ | x := mkPassStringFromLtac2ToLtac1 ?s |- _ =>
+ let __ := match constr:(Set) with _ => clear x end in s
+ end.
+
+ Local Open Scope string_scope.
+ Set Default Proof Mode "Classic".
+ Goal forall my_var: nat, my_var = my_var.
+ intros.
+ match goal with
+ | |- _ = ?x => let r := varconstr_to_string x in pose r
+ end.
+ Abort.
+
+ Inductive Ltac2IdentToPass := mkLtac2IdentToPass.
+
+ (* Trick from https://pit-claudel.fr/clement/papers/koika-dsls-CoqPL21.pdf *)
+ Ltac serialize_ident_in_context :=
+ ltac2:(match! goal with
+ | [ h: Ltac2IdentToPass |- _ ] =>
+ let s := ident_to_coq h in exact $s
+ end).
+End IdentToStringImpl.
+
+Notation "ident_to_string! a" :=
+ (match mkLtac2IdentToPass return string with
+ | a => ltac:(serialize_ident_in_context)
+ end) (at level 10, only parsing).
diff --git a/theories/rust_typing/automation/loc_eq.v b/theories/rust_typing/automation/loc_eq.v
new file mode 100644
index 0000000000000000000000000000000000000000..7c254cfe70ad4316f0c382093a547b7b781c54a1
--- /dev/null
+++ b/theories/rust_typing/automation/loc_eq.v
@@ -0,0 +1,138 @@
+(** Adapted from RefinedC *)
+From lithium Require Import all.
+From caesium Require Import base lang.
+From refinedrust Require Import programs program_rules.
+
+(** This file contains a solver for location (semantic) equality based on [lia]
+and an [autorewrite] hint database [refinedrust_loc_eq_rewrite] that the user can
+extend with more rewriting rules. *)
+
+(** * Hint database *)
+
+Create HintDb refinedrust_loc_eq_rewrite discriminated.
+
+(** Rules to inject [nat] operations in to [Z]. *)
+#[export] Hint Rewrite Nat2Z.inj_mul : refinedrust_loc_eq_rewrite.
+#[export] Hint Rewrite Nat2Z.inj_add : refinedrust_loc_eq_rewrite.
+#[export] Hint Rewrite Nat2Z.inj_sub using lia : refinedrust_loc_eq_rewrite.
+#[export] Hint Rewrite Z2Nat.id using lia : refinedrust_loc_eq_rewrite.
+
+(** Rule to eliminate [Z.shiftl]. *)
+#[export] Hint Rewrite Z.shiftl_mul_pow2 using lia : refinedrust_loc_eq_rewrite.
+
+(** * Tactics *)
+
+Lemma eq_loc (l1 l2 : loc): l1.1 = l2.1 → l1.2 = l2.2 → l1 = l2.
+Proof. destruct l1, l2 => /= -> -> //. Qed.
+
+(** Turns an equality over locations into an equality over physical addresses
+(in type [Z]) that has been simplified with [autorewrite]. This tactics only
+succeeds if the compared locations have convertible allocation ids. *)
+Ltac prepare_loc_eq :=
+ (* Sanity check on the goal. *)
+ lazymatch goal with
+ | |- @eq val (val_of_loc _) (val_of_loc _) => f_equal
+ | |- @eq ?A _ _ => unify A loc
+ | |- @eq _ _ _ => fail "[simpl_loc_eq]: goal not an equality between locations"
+ | |- _ => fail "[simpl_loc_eq]: goal not an equality"
+ end;
+ (* Remove all [offset_loc] and [shift_loc]. *)
+ rewrite ?/offset_loc ?shift_loc_assoc; rewrite ?/shift_loc;
+ (* Checking that both sides have the same [alloc_id]. *)
+ notypeclasses refine (eq_loc _ _ _ _); [ reflexivity | simpl ];
+ (* Unfold [addr] (useful if we use [ring]) and rewrite with the hints. *)
+ unfold addr in *; autorewrite with refinedrust_loc_eq_rewrite.
+
+(** Solver for location equality. *)
+Ltac solve_loc_eq :=
+ (* We try [reflexivity] first since it very often suffices. *)
+ first [ reflexivity | prepare_loc_eq; lia ].
+
+
+Section test.
+ Context (l : loc).
+ Context (id : prov).
+ Context (a : addr).
+ Context (n n1 n2 n3 : Z).
+ Context (i j : nat).
+ Context (PAGE_SIZE : Z := 4096).
+
+ Goal (l = l)%Z.
+ solve_loc_eq. Qed.
+
+ Goal (@eq loc (id, a) (id, a))%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l.1, l.2) = l)%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l.1, l.2 + n)%Z = l +â‚— n)%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l +â‚— n1 +â‚— n2) = (l +â‚— (n1 + n2)))%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l +â‚— 0%nat * n) = l)%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((id, a + n1 + n2) = (id, a + (n1 + n2)))%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l +â‚— (n + (i + j)%nat)) = (l +â‚— (n + i + j)))%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l +ₗ (n * PAGE_SIZE + i ≪ 12)) = (l +ₗ (n + i) * PAGE_SIZE))%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l +â‚— (n1 + 0%nat) * n2) = (l +â‚— (n1 * n2)))%Z.
+ solve_loc_eq. Qed.
+
+ Goal ((l +â‚— (n1 + (i + j)%nat) * n2) = (l +â‚— (n1 + i + j) * n2))%Z.
+ solve_loc_eq. Qed.
+
+ Goal (l = (l.1, l.2 * 1))%Z.
+ solve_loc_eq. Qed.
+
+ (*Goal (l +â‚— offset) = l +â‚— (len * size_of *)
+End test.
+
+(** ** Typing rules using the semantic equality solver*)
+Inductive FICLocSemantic : Set :=.
+Lemma tac_solve_loc_eq `{!typeGS Σ} π {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) k1 k2 l1 l2 r1 r2 :
+ l1 = l2 →
+ FindHypEqual FICLocSemantic (l1 â—â‚—[Ï€, k1] r1 @ lt1) (l2 â—â‚—[Ï€, k2] r2 @ lt2) (l1 â—â‚—[Ï€, k2] r2 @ lt2).
+Proof. by move => ->. Qed.
+
+Global Hint Extern 10 (FindHypEqual FICLocSemantic (_ â—â‚—[_, _] _ @ _) (_ â—â‚—[_, _] _ @ _) _) =>
+ (notypeclasses refine (tac_solve_loc_eq _ _ _ _ _ _ _ _ _ _); solve_loc_eq) : typeclass_instances.
+
+Lemma tac_loc_in_bounds_solve_loc_eq `{!typeGS Σ} l1 l2 pre1 pre2 suf1 suf2:
+ l1 = l2 →
+ FindHypEqual FICLocSemantic (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) (loc_in_bounds l1 pre2 suf2).
+Proof. by move => ->. Qed.
+
+Global Hint Extern 10 (FindHypEqual FICLocSemantic (loc_in_bounds _ _ _) (loc_in_bounds _ _ _) _) =>
+ (notypeclasses refine (tac_loc_in_bounds_solve_loc_eq _ _ _ _ _ _ _); solve_loc_eq) : typeclass_instances.
+
+Global Instance find_in_context_type_loc_semantic_inst `{!typeGS Σ} π l :
+ FindInContext (FindLoc l π) FICLocSemantic | 20 :=
+ λ T, i2p (find_in_context_type_loc_id l π T).
+Global Instance find_in_context_type_locp_semantic_inst `{!typeGS Σ} π l :
+ FindInContext (FindLocP l π) FICLocSemantic | 20 :=
+ λ T, i2p (find_in_context_type_locp_loc l π T).
+Global Instance find_in_context_type_loc_with_rt_semantic_inst `{!typeGS Σ} rt π l :
+ FindInContext (FindLocWithRt rt l π) FICLocSemantic | 20 :=
+ λ T, i2p (find_in_context_type_loc_with_rt_id l π T).
+
+(*
+Global Instance find_in_context_type_val_P_loc_semantic_inst `{!typeG Σ} (l : loc) :
+ FindInContext (FindValP l) FICLocSemantic | 20 :=
+ λ T, i2p (find_in_context_type_val_P_loc_id l T).
+Global Instance find_in_context_loc_in_bounds_semantic_inst `{!typeG Σ} l :
+ FindInContext (FindLocInBounds l) FICLocSemantic | 20 :=
+ λ T, i2p (find_in_context_loc_in_bounds l T).
+Global Instance find_in_context_loc_in_bounds_type_semantic_inst `{!typeG Σ} l :
+ FindInContext (FindLocInBounds l) FICLocSemantic | 30 :=
+ λ T, i2p (find_in_context_loc_in_bounds_loc l T).
+
+ *)
diff --git a/theories/rust_typing/automation/loc_related.v b/theories/rust_typing/automation/loc_related.v
new file mode 100644
index 0000000000000000000000000000000000000000..7c524e24f69f278088cd8e24b216f42b04455c26
--- /dev/null
+++ b/theories/rust_typing/automation/loc_related.v
@@ -0,0 +1,144 @@
+From lithium Require Import all.
+From caesium Require Import base lang.
+From refinedrust Require Import programs program_rules.
+
+(** This file contains a solver for finding related locations. *)
+
+(** * Definitions *)
+
+(** Asserts that [l .. l +â‚— l_sz] is in range [l1 .. l1 +â‚— l1_sz].
+ We have a range [l_sz] for the accessed part in order to support zero-sized accesses, which should be valid even if [l1_sz] is zero. *)
+Definition loc_in_range (l : loc) (l_sz : nat) (l1 : loc) (l1_sz : nat) :=
+ l.1 = l1.1 ∧ ((l.2 >= l1.2)%Z ∧ (l.2 + l_sz <= l1.2 + l1_sz)%Z).
+
+(** * Tactics *)
+
+(**
+ Limitations for now:
+ - assume that [l] and [l1] are of the form [l'] (for symbolic [l']) or [l' +â‚— o], where [o] may be one of:
+ + [n] for a literal number [n]
+ + [size_of_st st] for some syntype st
+ +
+
+ Strategy:
+ - first show that they both are in the same allocation (first conjunct)
+ + reflexivity? If they are both symbolic locations, it should be able to see through offsets etc.
+ + for concrete locations (e.g. obtained from ptr::dangling): same -- they have no provenance, which should be trivially okay by refl.
+ - for showing that the offset is in range:
+ + unfold offset in locations and sz.
+ + simplify [size_of_st] occurrences
+ * for trivial syntypes, simplify to concrete number
+ * for array, simplify
+ * for struct/enum/.., leave
+ + compute with [simpl]
+ + then call lia
+*)
+
+Ltac prove_prov_eq :=
+ idtac.
+
+Ltac prove_offset_in_range :=
+ idtac.
+
+Ltac solve_loc_in_range :=
+ match goal with
+ | |- loc_in_range _ _ _ _ =>
+ split; [prove_prov_eq | prove_offset_in_range]
+ end.
+
+Section test.
+ Context `{!typeGS Σ}.
+
+ Lemma lir_test_1 l :
+ loc_in_range l 1 l 1.
+ Proof.
+ solve_loc_in_range.
+ Abort.
+
+ Lemma lir_test_2 l :
+ loc_in_range (l +â‚—2) 1 l 4.
+ Proof.
+ solve_loc_in_range.
+ Abort.
+
+ (* TODO move *)
+ Definition mkloc (p : prov) (a : addr) : loc := (p, a).
+
+ Lemma lir_test_3 :
+ loc_in_range (mkloc (ProvAlloc None) 4) 0 (mkloc (ProvAlloc None) 4) 0.
+ Proof.
+ solve_loc_in_range.
+ Abort.
+
+ (*Lemma lir_test_4 T_st l : *)
+ (*loc_in_range (l +â‚— size_of_st T_st) 1 *)
+
+
+End test.
+
+(** ** Typing rules using the semantic equality solver*)
+Inductive FICLocRelated (l : loc) : Set :=.
+
+(* TODO need a notion of size for ltypes i.e. lt1 here *)
+(*
+Lemma tac_solve_loc_related_eq `{!typeGS Σ} π {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) k1 k2 l l1 l2 r1 r2 :
+ l1 = l2 ∧ loc_in_range l l1 1 →
+ FindHypEqual (FICLocRelated l) (l1 â—â‚—[Ï€, k1] r1 @ lt1) (l2 â—â‚—[Ï€, k2] r2 @ lt2) (l1 â—â‚—[Ï€, k2] r2 @ lt2).
+Proof. by move => [-> _]. Qed.
+ *)
+
+(** Issues with zero-sized allocations:
+ - in case of Vec: when we have the two chunks in the context, how do we decide which one to take anyways?
+ Based on the the actual locations, we cannot possibly decide this since everything zeroes out.
+ However, we can decide it by looking at the types + offset before doing the zero-sized multiplication.
+ In our case, by looking at the arrays and their semantic length.
+
+ Have a semantic judgment with custom rules for deciding whether a type and location/offset match?
+ We could have a rule for array + offset by multiple of array_elsize.
+ However, that seems a bit fragile, since it would match syntactically -- but the whole point is that syntactic matching is all we can do, because semantically there's no hint to be found here.
+ This might help with duplicate/overlapping type assignments in general
+ (I'm looking at you, MutexGuard)
+
+
+ What if I had only one type assignment?
+ Then I would have a offset rule just for arrays. At that point, we would also rely on the offset not having been simplified yet.
+ But that would already be much easier.
+ In general, though, especially with potential Uniq/Sharing overlap with custom types like Mutex, I won't be able to maintain that.
+ This overlap is even more critical for the Mutex thing though: if we access the second field of the struct, we won't know that we should not find the base location, because we don't know yet which other place ops (e.g. offset to the data pointer) we will do.
+
+ Can I synthesize some hints for that in some other way?
+ - maybe one point is that I simply don't know that the size is zero at the point, if I don't make a case distinction.
+ So it will not simplify anyways.
+ But still, I need to syntactically extract some information then.
+ Also: I should not rely on that too much. Gaining additional information (like size_of T = 0) should not break automation.
+
+
+
+ More flexible multimatch context search, with custom rules to guide selection.
+ - based on the context folder
+ - input: FindMode, location
+
+
+
+ But: This will not solve the issue with MutexGuard. There, we would need to find a new assignment in the middle of a place operation.
+ - one thing we could try there is to find a new assignment in the context whenever as part of a place access rule. If we can find something stronger, use that instead. But that does not seem right.
+ Also, we'd do spurious invariant unfolds in the Mutex Guard case (open the Mutex invariant to do the field access).
+ - make place accesses operate on alias_ptr_t at least as far as offsets + field accesses are concerned?
+
+
+ *)
+
+(*Global Hint Extern 10 (FindHypEqual FICLocSemantic (_ â—â‚—[_, _] _ @ _) (_ â—â‚—[_, _] _ @ _) _) =>*)
+ (*(notypeclasses refine (tac_solve_loc_eq _ _ _ _ _ _ _ _ _ _); solve_loc_eq) : typeclass_instances.*)
+
+(** This triggers search without any constraints -- the above FindHypEqual instance is what's relevant to ensure relatedness, because Lithium will remember the [FICLocRelated l] key.
+ It's important that we don't have any [FICSyntactic] or otherwise instances, since these would be too unconstrained and just match arbitrary location assignments. *)
+Lemma find_in_context_type_loc_related_id `{!typeGS Σ} π T :
+ (∃ (l' : loc) rt (lt : ltype rt) r (b : bor_kind), l' â—â‚—[Ï€, b] r @ lt ∗ T (existT _ ((l', lt, r, b))))
+ ⊢ find_in_context (FindRelatedLoc π) T.
+Proof. iDestruct 1 as (l' rt lt r b) "[Hl HT]". iExists _ => /=. iFrame. Qed.
+Global Instance find_in_context_type_loc_related_inst `{!typeGS Σ} π l :
+ FindInContext (FindRelatedLoc π) (FICLocRelated l) | 20 :=
+ λ T, i2p (find_in_context_type_loc_related_id π T).
+
+
diff --git a/theories/rust_typing/automation/lookup_definition.v b/theories/rust_typing/automation/lookup_definition.v
new file mode 100644
index 0000000000000000000000000000000000000000..c30280b8c44c5939a5f9cf606945d092bbe223eb
--- /dev/null
+++ b/theories/rust_typing/automation/lookup_definition.v
@@ -0,0 +1,86 @@
+(** * Lookup definitions *)
+From Ltac2 Require Ltac2.
+From iris Require string_ident.
+Module StringConstr.
+ Import Ltac2 string_ident.
+
+ Local Ltac2 rec make_message (s : (Std.reference) list) := match s with
+ | [] => Message.of_string "]"
+ | x :: s =>
+ let cstr := Env.instantiate x in
+ Message.concat (Message.of_constr cstr)
+ (Message.concat (Message.of_string "; ") (make_message s))
+ end.
+ Ltac2 Type exn ::= [ MultipleMatches(message) | NoMatches | NotAConstr ].
+ Ltac2 ident_to_constr (s : ident list) :=
+ let ref := Env.expand s in
+ match ref with
+ | msg :: rs =>
+ match rs with
+ | [] => ()
+ | _ =>
+ let msg := make_message rs in
+ Control.throw (MultipleMatches (Message.concat (Message.of_string "other matches: [") msg))
+ end;
+ let cstr := Env.instantiate msg in
+ Some(cstr)
+ | _ => None
+ end.
+
+ Ltac2 rec list_string_to_ident (s : constr) : (ident list) :=
+ match! s with
+ | nil => []
+ | cons ?str ?rest =>
+ let ident := StringToIdent.coq_string_to_ident str in
+ let rest_ident := list_string_to_ident rest in
+ ident :: rest_ident
+ end.
+
+ Ltac2 coq_string_list_to_constr (s : constr) : constr :=
+ let idents := list_string_to_ident s in
+ let cstr := ident_to_constr idents in
+ match cstr with
+ | Some cstr =>
+ cstr
+ | None =>
+ Control.throw NoMatches
+ end.
+
+ Ltac2 run_ltac1_with_constr (cont : Ltac1.t) (x : constr) :=
+ Ltac1.apply cont ([(Ltac1.of_constr x)])
+ (fun (x : Ltac1.t) => Ltac1.run x).
+ Ltac2 string_to_ltac1_constr (cont : Ltac1.t) (x : constr) :=
+ run_ltac1_with_constr cont (StringConstr.coq_string_list_to_constr x).
+
+ Ltac2 ltac1_constr_to_constr (cont : Ltac1.t) (x : Ltac1.t) :=
+ match Ltac1.to_constr x with
+ | Some s => string_to_ltac1_constr cont s
+ | None => Control.throw NotAConstr
+ end.
+End StringConstr.
+
+(** Looks up a definition with name [s].
+ [cont] is a continuation that will be called with the looked-up term of form [@s]
+ (i.e. all arguments are expected to be given explicitly).
+ [s] is a constr of [list string] type giving a suffix of the fully qualified path.
+
+ This will fail if there are multiple possible matches of [s].
+ *)
+Ltac lookup_definition cont s :=
+ let run := ltac2:(s cont |- StringConstr.ltac1_constr_to_constr cont s) in
+ run s cont.
+
+(*
+Require Import String.
+From stdpp Require Import base.
+Local Open Scope string_scope.
+Goal True.
+Proof.
+ lookup_definition ltac:(fun x => idtac x) constr:(["list"]).
+
+ (* NOTE: fails due to ambiguity! *)
+ (*lookup_definition ltac:(fun x => idtac x) constr:(["concat"]).*)
+
+ lookup_definition ltac:(fun x => idtac x) constr:(["List"; "concat"]).
+Abort.
+ *)
diff --git a/theories/rust_typing/automation/proof_state.v b/theories/rust_typing/automation/proof_state.v
new file mode 100644
index 0000000000000000000000000000000000000000..23506a3ff51b558d857c5db53786097a56eb5373
--- /dev/null
+++ b/theories/rust_typing/automation/proof_state.v
@@ -0,0 +1,177 @@
+From refinedrust Require Import type programs.
+From lithium Require Import hooks all.
+
+(* Initialize the [named_lfts] assertion with external lifetimes.
+ Usually called after [start_function].
+ *)
+Tactic Notation "init_lfts" uconstr(map) :=
+ unshelve iPoseProof (named_lfts_init (map : gmap string lft)) as "-#?"; [apply _ .. |].
+ (*specialize (tt : LFT_MAP map) as lfts.*)
+
+Tactic Notation "init_tyvars" uconstr(M) :=
+ specialize (tt : TYVAR_MAP M) as tyvars.
+
+Definition BLOCK_PRECOND `{!typeGS Σ} (bid : label) (P : iProp Σ) : Set := unit.
+Arguments BLOCK_PRECOND : simpl never.
+
+Definition CASE_DISTINCTION_INFO {B} (info : B) (* (i : list location_info) *) : Set := unit.
+Arguments CASE_DISTINCTION_INFO : simpl never.
+
+Definition CODE_MARKER (rf : runtime_function) : runtime_function := rf.
+Notation "'HIDDEN'" := (CODE_MARKER _) (only printing).
+Arguments CODE_MARKER : simpl never.
+Ltac unfold_code_marker_and_compute_map_lookup :=
+ unfold CODE_MARKER in *;
+ match goal with
+ | |- f_code (rf_fn ?FN) !! _ = Some _ => unfold rf_fn, f_code, FN
+ end;
+ compute_map_lookup.
+
+Definition RETURN_MARKER `{!typeGS Σ} (R : @typed_stmt_R_t Σ) : @typed_stmt_R_t Σ := R.
+Notation "'HIDDEN'" := (RETURN_MARKER _) (only printing).
+(* simplify RETURN_MARKER as soon as it is applied enough in the goal *)
+Arguments RETURN_MARKER _ _ /.
+
+(** marker for tactics that have already exploited a particular fact *)
+Definition NO_ENRICH {A} (a : A) := a.
+Global Typeclasses Opaque NO_ENRICH.
+Arguments NO_ENRICH : simpl never.
+Lemma dont_enrich {A} : A → NO_ENRICH A.
+Proof. apply NO_ENRICH. Defined.
+Ltac unfold_no_enrich :=
+ repeat match goal with
+ | H : context[NO_ENRICH ?a] |- _ => unfold NO_ENRICH in H
+ end.
+
+Ltac add_case_distinction_info info :=
+ let Hcase := fresh "HCASE" in
+ have Hcase := (() : (CASE_DISTINCTION_INFO info))
+ (*get_loc_info ltac:(fun icur =>*)
+ (*let Hcase := fresh "HCASE" in*)
+ (*have Hcase := (() : (CASE_DISTINCTION_INFO hint info icur)))*)
+.
+
+(** * Tactics cleaning the proof state *)
+Ltac clear_unused_vars :=
+ repeat match goal with
+ | H : ?T |- _ =>
+ (* Keep current location and case distinction info. *)
+ lazymatch T with
+ (*| CURRENT_LOCATION _ _ => fail*)
+ (*| CASE_DISTINCTION_INFO _ _ _ => fail*)
+ | _ => idtac
+ end;
+ let ty := (type of T) in
+ match ty with | Type => clear H | Set => clear H end
+ end.
+
+Ltac prepare_sideconditions :=
+ li_unfold_lets_in_context;
+ unfold_instantiated_evars;
+ repeat match goal with | H : BLOCK_PRECOND _ _ |- _ => clear H end;
+ (* get rid of Q *)
+ repeat match goal with | H := CODE_MARKER _ |- _ => clear H end;
+ repeat match goal with | H := RETURN_MARKER _ |- _ => clear H end;
+ unfold_no_enrich;
+ clear_unused_vars.
+
+Ltac solve_goal_prepare_hook ::=
+ prepare_sideconditions;
+ repeat match goal with | H : CASE_DISTINCTION_INFO _ |- _ => clear H end.
+
+(** * Tactics for showing failures to the user *)
+
+(*Ltac print_current_location :=*)
+ (*try lazymatch reverse goal with*)
+ (*| H : CURRENT_LOCATION ?l ?up_to_date |- _ =>*)
+ (*let rec print_loc_info l :=*)
+ (*match l with*)
+ (*| ?i :: ?l =>*)
+ (*lazymatch eval unfold i in i with*)
+ (*| LocationInfo ?f ?ls ?cs ?le ?ce =>*)
+ (*let f := eval unfold f in f in*)
+ (*idtac "Location:" f "[" ls ":" cs "-" le ":" ce "]";*)
+ (*print_loc_info l*)
+ (*end*)
+ (*| [] => idtac "up to date:" up_to_date*)
+ (*end in*)
+ (*print_loc_info l;*)
+ (*clear H*)
+ (*end.*)
+
+Ltac print_case_distinction_info :=
+ repeat lazymatch reverse goal with
+ | H : CASE_DISTINCTION_INFO ?hint ?i (* ?l *) |- _ =>
+ lazymatch i with
+ | (?a, ?b) => idtac "Case distinction" a "->" b
+ | ?a => idtac "Case distinction" a
+ end;
+ (*
+ lazymatch l with
+ | ?i :: ?l =>
+ lazymatch eval unfold i in i with
+ | LocationInfo ?f ?ls ?cs ?le ?ce =>
+ let f := eval unfold f in f in
+ idtac "at" f "[" ls ":" cs "-" le ":" ce "]"
+ end
+ | [] => idtac
+ end;
+ *)
+ clear H
+ end.
+
+Ltac print_coq_hyps :=
+ try match reverse goal with
+ | H : ?X |- _ =>
+ lazymatch X with
+ | BLOCK_PRECOND _ _ => fail
+ | gFunctors => fail
+ | typeGS _ => fail
+ | ghost_varG _ _ => fail
+ (*| globalGS _ => fail*)
+ | _ => idtac H ":" X; fail
+ end
+ end.
+
+Ltac print_goal :=
+ (*print_current_location;*)
+ print_case_distinction_info;
+ idtac "Goal:";
+ print_coq_hyps;
+ idtac "---------------------------------------";
+ match goal with
+ | |- ?G => idtac G
+ end;
+ idtac "";
+ idtac "".
+
+Ltac print_typesystem_goal fn :=
+ lazymatch goal with
+ | |- ?P ∧ ?Q =>
+ idtac "Cannot instantiate evar in" fn "!";
+ (*print_current_location;*)
+ (*print_case_distinction_info;*)
+ idtac "Goal:";
+ print_coq_hyps;
+ idtac "---------------------------------------";
+ idtac P;
+ (* TODO: Should we print the continuation? It might confuse the user and
+ it usually is not helpful. *)
+ (* idtac ""; *)
+ (* idtac "Continuation:"; *)
+ (* idtac Q; *)
+ idtac "";
+ idtac "";
+ admit
+ | |- _ =>
+ idtac "Type system got stuck in function" fn "!";
+ print_goal; admit
+ end.
+
+Ltac print_sidecondition_goal fn :=
+ idtac "Cannot solve side condition in function" fn "!";
+ print_goal; admit.
+
+Ltac print_remaining_shelved_goal fn :=
+ idtac "Shelved goal remaining in " fn "!";
+ print_goal; admit.
diff --git a/theories/rust_typing/automation/simpl.v b/theories/rust_typing/automation/simpl.v
new file mode 100644
index 0000000000000000000000000000000000000000..f99f406bd016adf6d5feac4079ef430cebc0474d
--- /dev/null
+++ b/theories/rust_typing/automation/simpl.v
@@ -0,0 +1,108 @@
+From refinedrust Require Export base hlist type ltypes.
+From lithium Require Export all.
+Set Default Proof Using "Type".
+
+(** ** Additional Simpl instances *)
+Global Instance simpl_eq_hlist_cons A {F} (X : A) (XS : list A) (x : F X) (y : F X) (xs ys : hlist F XS) :
+ SimplAnd ((x +:: xs) = (y +:: ys)) (λ T, x = y ∧ xs = ys ∧ T).
+Proof.
+ split.
+ - intros (-> & -> & HT). done.
+ - intros (Heq & HT). injection Heq.
+ intros ->%existT_inj ->%existT_inj. done.
+Qed.
+
+Global Instance simpl_eq_plist_cons A {F} (X : A) (XS : list A) (x : F X) (y : F X) (xs ys : plist F XS) :
+ SimplAnd ((x -:: xs) = (y -:: ys)) (λ T, x = y ∧ xs = ys ∧ T).
+Proof.
+ split.
+ - intros (-> & -> & HT). done.
+ - intros (Heq & HT). injection Heq. done.
+Qed.
+
+Global Instance simpl_eq_phd {A} {F : A → Type} (Xs : list A) (X : A) (xs : plist F (X :: Xs)) (x : F X) :
+ SimplBothRel (eq) (x) (phd xs) (∃ c : plist F Xs, xs = pcons x c).
+Proof.
+ split.
+ - intros ->. destruct xs as [? ?]. eauto.
+ - intros (c & ->). done.
+Qed.
+Global Instance simpl_eq_ptl {A} {F : A → Type} (Xs : list A) (X : A) (xs : plist F (X :: Xs)) (xs' : plist F Xs) :
+ SimplBothRel (eq) (xs') (ptl xs) (∃ c : F X, xs = pcons c xs').
+Proof.
+ split.
+ - intros ->. destruct xs as [? ?]. eauto.
+ - intros (c & ->). done.
+Qed.
+
+Global Instance simpl_hmap_nil {A} {F G : A → Type} (f : ∀ x : A, F x → G x) (l : hlist F []) (l2 : hlist G []) :
+ SimplBothRel eq (f +<$> l) l2 (l = +[] ∧ l2 = +[]).
+Proof.
+ split.
+ - inv_hlist l; done.
+ - intros [-> ->]; done.
+Qed.
+Global Instance simpl_hmap_cons_impl {A} {F G : A → Type} (f : ∀ x : A, F x → G x) (X : A) (Xs : list A) (x : G X) (l2 : hlist G Xs) (l : hlist F (X :: Xs)) :
+ SimplImplRel eq true (f +<$> l) (x +:: l2) (λ T : Prop,
+ ∀ (x' : F X) (l2' : hlist F Xs), l = x' +:: l2' → f _ x' = x → f +<$> l2' = l2 → T).
+Proof.
+ intros T. split.
+ - inv_hlist l => x0 xl0 Hf /=.
+ injection 1 => Heq1 Heq2.
+ apply existT_inj in Heq1. apply existT_inj in Heq2. subst.
+ eapply Hf; reflexivity.
+ - intros Hf x' l2' -> <- <-. apply Hf. done.
+Qed.
+Global Instance simpl_hmap_cons_and {A} {F G : A → Type} (f : ∀ x : A, F x → G x) (X : A) (Xs : list A) (x : G X) (l2 : hlist G Xs) (l : hlist F (X :: Xs)) :
+ SimplAndRel eq (f +<$> l) (x +:: l2) (λ T : Prop,
+ ∃ (x' : F X) (l2' : hlist F Xs), l = x' +:: l2' ∧ f _ x' = x ∧ f +<$> l2' = l2 ∧ T).
+Proof.
+ intros T. split.
+ - intros (x' & l2' & -> & <- & <- & HT). done.
+ - intros (Ha & HT). inv_hlist l => x0 xl0 Ha.
+ injection Ha => Heq1 Heq2. apply existT_inj in Heq1. apply existT_inj in Heq2. subst.
+ eexists _, _. done.
+Qed.
+
+Global Instance simpl_and_list_lookup_total_unsafe {A} `{!Inhabited A} (l : list A) i (x : A) :
+ SimplAndUnsafe (l !!! i = x) (λ T, l !! i = Some x ∧ T).
+Proof.
+ intros T [Hlook HT]. split; last done. by apply list_lookup_total_correct.
+Qed.
+
+(** Try to find a lookup proof with some abstract condition [P] *)
+Lemma simpl_list_lookup_assum {A} {P : nat → Prop} {E : nat → A} (l : list A) j x :
+ (∀ i, P i → l !! i = Some (E i)) →
+ CanSolve (P j) →
+ SimplBothRel (=) (l !! j) (Some x) (x = E j).
+Proof.
+ unfold SimplBothRel, CanSolve, TCDone in *; subst.
+ intros HL HP.
+ apply HL in HP. rewrite HP. naive_solver.
+Qed.
+Global Hint Extern 50 (SimplBothRel (=) (?l !! ?j) (Some ?x) (_)) =>
+ (* Important: we backtrack in case there are multiple matching facts in the context. *)
+ match goal with
+ | H : ∀ i, _ → l !! i = Some _ |- _ =>
+ notypeclasses refine (simpl_list_lookup_assum l j x H _);
+ apply _
+ end : typeclass_instances.
+
+Global Instance simpl_eq_PlaceIn {rt} (n m : rt) : SimplBothRel (=) (A := place_rfn rt) (#n) (#m) (n = m).
+Proof. split; naive_solver. Qed.
+Global Instance simpl_eq_PlaceGhost {rt} (γ1 γ2 : gname) : SimplBothRel (=) (A := place_rfn rt) (PlaceGhost γ1) (PlaceGhost γ2) (γ1 = γ2).
+Proof. split; naive_solver. Qed.
+
+Global Instance simpl_replicate_eq' {A} (x x' : A) n n' :
+ SimplAndUnsafe (replicate n x = replicate n' x') (λ b, n = n' ∧ x = x' ∧ b).
+Proof.
+ intros ? (-> & -> & ?). done.
+Qed.
+
+Global Instance simpl_eq_OffsetSt `{!LayoutAlg} st i i' x : SimplAndUnsafe (x offsetst{st}ₗ i = x offsetst{st}ₗ i') (λ T, i = i' ∧ T).
+Proof.
+ intros T [-> ?]. done.
+Qed.
+
+(** ** Additional normalization instances *)
+#[export] Hint Rewrite Nat.add_sub : lithium_rewrite.
diff --git a/theories/rust_typing/automation/solvers.v b/theories/rust_typing/automation/solvers.v
new file mode 100644
index 0000000000000000000000000000000000000000..dd76b31162c02140410412b8a12ef3c459d60528
--- /dev/null
+++ b/theories/rust_typing/automation/solvers.v
@@ -0,0 +1,2552 @@
+From iris.proofmode Require Import coq_tactics reduction string_ident.
+From refinedrust Require Export type ltypes hlist.
+From lithium Require Export all.
+From lithium Require Import hooks.
+From refinedrust.automation Require Import ident_to_string lookup_definition proof_state.
+From refinedrust Require Import int programs program_rules functions uninit references products value arrays.
+Set Default Proof Using "Type".
+
+
+(** * Automation for solving sideconditions *)
+
+(* TODO sometimes this diverges, so we put a timeout on it.
+ Should really fix the refined_solver though. *)
+Ltac hammer :=
+ first [timeout 4 lia | timeout 4 nia | timeout 4 refined_solver lia].
+Ltac solve_goal_final_hook ::= refined_solver lia.
+
+(** The main hook for solving sideconditions, will be re-defined later. *)
+Ltac sidecond_hook := idtac.
+Ltac unsolved_sidecond_hook := idtac.
+
+Tactic Notation "unfold_opaque" constr(c) := with_strategy 0 [c] (unfold c).
+
+(** ** interpret_rust_type solver *)
+
+(** Since [lookup_definition] will give us a term that requires us to
+ explicitly give all implicit arguments, we need some hackery to
+ apply the arguments of literal type terms that would usually be implicit.
+ Basically, we handle the case that the literal term expects a [typeGS] assumption
+ and then a number of [Type]s that are later determined by the parameters we instantiate. *)
+Ltac count_in_term' term acc :=
+ match type of term with
+ | ∀ _ : Type, _ =>
+ count_in_term' constr:(term nat) constr:(S acc)
+ | _ => acc
+ end.
+Ltac count_in_term term :=
+ count_in_term' term constr:(0).
+Ltac instantiate_universal_evars term count :=
+ match count with
+ | 0 => uconstr:(term)
+ | S ?n =>
+ instantiate_universal_evars uconstr:(term _) constr:(n)
+ end.
+Ltac instantiate_benign_universals term :=
+ lazymatch type of term with
+ | ∀ (_ : gFunctors) (_ : typeGS _), _ =>
+ instantiate_benign_universals uconstr:(term _ _)
+ | ∀ _ : typeGS _, _ =>
+ instantiate_benign_universals uconstr:(term ltac:(refine _))
+ | _ =>
+ constr:(term)
+ end.
+Ltac instantiate_universals term :=
+ let term := instantiate_benign_universals term in
+ let count := count_in_term term in
+ instantiate_universal_evars term count.
+Ltac apply_term_het term apps :=
+ match apps with
+ | +[] => constr:(term)
+ | ?app +:: ?apps =>
+ apply_term_het uconstr:(term app) apps
+ end.
+Ltac apply_term_het_evar term apps :=
+ let term := instantiate_universals term in
+ apply_term_het term apps.
+
+(** This interprets syntactic Rust types used in some annotations into semantic RefinedRust types *)
+(* NOTE: Be REALLY careful with this. The Ltac2 for looking up definitions will easily go haywire, and we cannot properly handle the exceptions here or show them.
+ In particular, if this fails for some unknown reason, make sure that there are NO other definitions with the same name in scope, even below other modules! *)
+Ltac interpret_rust_type_core lfts env ty := idtac.
+Ltac interpret_rust_type_list lfts env tys :=
+ match tys with
+ | [] => exact +[]
+ | ?ty :: ?tys =>
+ refine (_ +:: _);
+ [ interpret_rust_type_core lfts env ty
+ | interpret_rust_type_list lfts env tys ]
+ end.
+Ltac interpret_rust_type_core lfts env ty ::=
+ lazymatch ty with
+ | RSTTyVar ?name =>
+ let sty := eval vm_compute in (env !! name) in
+ match sty with
+ | Some (existT _ ?sty) =>
+ exact sty
+ | None =>
+ fail 3 "Failed to find type variable " name " in the context"
+ end
+ | RSTLitType ?name ?apps =>
+ (* interpret the arguments *)
+ let Ha := fresh in
+ refine (let Ha : hlist type _ := ltac:(interpret_rust_type_list lfts env apps) in _);
+ let Hb := eval hnf in Ha in
+
+ (* CAVEAT: This only works if a unique identifier can be found! *)
+ lookup_definition
+ ltac:(fun term =>
+ let applied_term := apply_term_het_evar term Hb in
+ exact applied_term
+ )
+ name || fail 1000 "definition lookup for " name " failed"
+ | RSTInt ?it =>
+ exact (int (IntType_to_it it))
+ | RSTBool =>
+ exact bool_t
+ | RSTUnit =>
+ exact unit_t
+ | RSTStruct ?sls ?tys =>
+ refine (struct_t sls ltac:(interpret_rust_type_list lfts env tys))
+ | RSTArray ?len ?ty =>
+ fail 2 "not implemented"
+ | RSTRef ?mut ?κ ?ty =>
+ (* TODO not great *)
+ let κ := eval vm_compute in (lfts !! κ) in
+ match κ with
+ | Some ?κ =>
+ match mut with
+ | Mut =>
+ refine (mut_ref _ κ); interpret_rust_type_core lfts env ty
+ | Shr =>
+ refine (shr_ref _ κ); interpret_rust_type_core lfts env ty
+ end
+ | None =>
+ fail 3 "did not find lifetime"
+ end
+ end.
+Tactic Notation "interpret_rust_type" constr(lfts) constr(env) constr(ty) :=
+ interpret_rust_type_core lfts env ty .
+
+Ltac solve_interpret_rust_type ::=
+ match goal with
+ | |- interpret_rust_type_pure_goal ?lfts ?st ?ty =>
+ match goal with
+ | H : TYVAR_MAP ?M |- _ =>
+ let Hc := fresh in
+ refine (let Hc := ltac:(interpret_rust_type lfts M st) in _);
+ assert (ty = Hc) by reflexivity;
+ exact I
+ end
+ end.
+
+
+(** ** lifetime inclusion solver *)
+(* relevant lemmas : lctx_lft_incl_refl, lctx_lft_incl_preorder *)
+(*
+ Note: we _need_ to be able to deal with the case that the the lhs and rhs are intersections.
+ (consider the case of subtyping annotations for instance)
+ (but these intersections will always be intersections of "atomic" lifetimes or external lifetimes)
+
+ strategy here: convert intersection to list of lifetimes.
+ We need to dispatch all lifetimes on the RHS by finding a matching lifetime on the LHS, essentially.
+ use the following rules in the given order:
+ - if the LHS or RHS contains static, remove it [static is implicit]
+ - if a LHS lifetime is also contained on the LHS, remove it from the LHS.
+ - if there is a LHS lifetime on the LHS of a ⊑ₗ, remove it from the LHS and put the RHS of the inclusion there. [this is terminating since there are no cycles here, see below]
+ - if there is a LHS lifetime on the LHS of a ⊑ₑ, put the RHS of the inclusion there, if it is not already there. [this ensures that we do not run into cycles]
+ - fail with an error.
+
+ [[[- if an RHS lifetime is on the RHS of a ⊑ₗ, reduce to the LHS. [problem: introduces a disjunction if there are multiple such inclusions.] ]]]
+
+ alternative formulation of this:
+ in a graph-based representation of the lifetimes, this question reduces to: is every conjunct of the RHS reachable from one conjunct of the LHS?
+ but implementing that in a certified way seems quite annoying.
+ -> can this graph have cycles?
+ -> no for the local context. the atomic lifetimes in the local context should automatically break cycles.
+ -> it can have cycles in the external context -> we must not carelessly propagate along external edges.
+
+
+ Slightly problematic point here: lifetime intersection is not idempotent.
+ this means: I cannot use the same element on the LHS twice.
+
+ Note: this solver relies on the fact that each lifetime can only be contained once on the lhs in the local lifetime context.
+*)
+
+Section incl_tac.
+ Context `{typeGS Σ}.
+ Definition lctx_lft_incl_list (E : elctx) (L : llctx) (κs1 κs2 : list lft) :=
+ lctx_lft_incl E L (lft_intersect_list κs1) (lft_intersect_list κs2).
+
+ Lemma tac_lctx_lft_incl_init_list E L κ1 κ2 :
+ lctx_lft_incl_list E L [κ1] [κ2] → lctx_lft_incl E L κ1 κ2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ by rewrite !lft_intersect_right_id.
+ Qed.
+
+ Lemma tac_lctx_lft_incl_list_nil_r E L κs1 :
+ lctx_lft_incl_list E L κs1 [].
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ iIntros (?) "HL !> HE".
+ iApply lft_incl_static.
+ Qed.
+
+ (* should be applied by automation only if κ2 cannot be decomposed further *)
+ Lemma tac_lctx_lft_incl_list_intersect_l E L κ1 κ2 κs1 κs2 :
+ lctx_lft_incl_list E L (κ1 :: κ2 :: κs1) κs2 →
+ lctx_lft_incl_list E L (κ1 ⊓ κ2 :: κs1) κs2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ by rewrite lft_intersect_assoc.
+ Qed.
+ Lemma tac_lctx_lft_incl_list_intersect_r E L κ1 κ2 κs1 κs2 :
+ lctx_lft_incl_list E L κs1 (κ1 :: κ2 :: κs2) →
+ lctx_lft_incl_list E L κs1 (κ1 ⊓ κ2 :: κs2).
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ by rewrite lft_intersect_assoc.
+ Qed.
+
+ (* used for normalizing the head *)
+ Lemma tac_lctx_lft_incl_list_head_assoc_l E L κ1 κ2 κ3 κs1 κs2 :
+ lctx_lft_incl_list E L ((κ1 ⊓ κ2) ⊓ κ3 :: κs1) κs2 →
+ lctx_lft_incl_list E L (κ1 ⊓ (κ2 ⊓ κ3) :: κs1) κs2.
+ Proof. by rewrite lft_intersect_assoc. Qed.
+ Lemma tac_lctx_lft_incl_list_head_assoc_r E L κ1 κ2 κ3 κs1 κs2 :
+ lctx_lft_incl_list E L κs1 ((κ1 ⊓ κ2) ⊓ κ3 :: κs2) →
+ lctx_lft_incl_list E L κs1 (κ1 ⊓ (κ2 ⊓ κ3) :: κs2).
+ Proof. by rewrite lft_intersect_assoc. Qed.
+ Lemma tac_lctx_lft_incl_list_head_static_l E L κ1 κs1 κs2 :
+ lctx_lft_incl_list E L (κ1 :: κs1) κs2 →
+ lctx_lft_incl_list E L (κ1 ⊓ static :: κs1) κs2.
+ Proof. rewrite lft_intersect_right_id //. Qed.
+ Lemma tac_lctx_lft_incl_list_head_static_r E L κ1 κs1 κs2 :
+ lctx_lft_incl_list E L κs1 (κ1 :: κs2) →
+ lctx_lft_incl_list E L κs1 (κ1 ⊓ static :: κs2).
+ Proof. rewrite lft_intersect_right_id //. Qed.
+ Lemma tac_lctx_lft_incl_list_static_l E L κs1 κs2 :
+ lctx_lft_incl_list E L κs1 κs2 →
+ lctx_lft_incl_list E L (static :: κs1) κs2.
+ Proof. rewrite /lctx_lft_incl_list /= lft_intersect_left_id //. Qed.
+ Lemma tac_lctx_lft_incl_list_static_r E L κs1 κs2 :
+ lctx_lft_incl_list E L κs1 κs2 →
+ lctx_lft_incl_list E L κs1 (static :: κs2).
+ Proof. rewrite /lctx_lft_incl_list /= lft_intersect_left_id //. Qed.
+
+ (* applied when a matching lifetime is found on left and right *)
+ Lemma tac_lctx_lft_incl_list_dispatch_r E L i j κ κs1 κs2 :
+ κs1 !! i = Some κ →
+ κs2 !! j = Some κ →
+ lctx_lft_incl_list E L (delete i κs1) (delete j κs2) →
+ lctx_lft_incl_list E L κs1 κs2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ rewrite !delete_take_drop.
+ intros H1 H2.
+ rewrite -{3}(take_drop_middle κs1 _ _ H1).
+ rewrite -{3}(take_drop_middle κs2 _ _ H2).
+ rewrite !lft_intersect_list_app. simpl. intros Ha.
+ rewrite !lft_intersect_assoc.
+ rewrite ![lft_intersect_list _ ⊓ κ]lft_intersect_comm.
+ rewrite -!lft_intersect_assoc.
+ apply lctx_lft_incl_intersect; done.
+ Qed.
+
+ (* augment lhs with a local inclusion *)
+ Lemma tac_lctx_lft_incl_list_augment_local_owned E L κs1 κs2 κ κs i j c :
+ L !! j = Some (κ ⊑ₗ{c} κs) →
+ κs1 !! i = Some κ →
+ lctx_lft_incl_list E L (κs ++ delete i κs1) κs2 →
+ lctx_lft_incl_list E L κs1 κs2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ rewrite !delete_take_drop.
+ intros HL%elem_of_list_lookup_2 H1. rewrite -{3}(take_drop_middle κs1 _ _ H1).
+ rewrite !lft_intersect_list_app. simpl. intros Ha.
+ rewrite lft_intersect_assoc. rewrite [lft_intersect_list _ ⊓ κ]lft_intersect_comm.
+ rewrite -lft_intersect_assoc.
+ eapply lctx_lft_incl_local_owned_full; done.
+ Qed.
+
+ Lemma tac_lctx_lft_incl_list_augment_local_alias E L κs1 κs2 κ κs i j :
+ L !! j = Some (κ ≡ₗ κs) →
+ κs1 !! i = Some κ →
+ lctx_lft_incl_list E L (κs ++ delete i κs1) κs2 →
+ lctx_lft_incl_list E L κs1 κs2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ rewrite !delete_take_drop.
+ intros HL%elem_of_list_lookup_2 H1. rewrite -{3}(take_drop_middle κs1 _ _ H1).
+ rewrite !lft_intersect_list_app. simpl. intros Ha.
+ rewrite lft_intersect_assoc. rewrite [lft_intersect_list _ ⊓ κ]lft_intersect_comm.
+ rewrite -lft_intersect_assoc.
+ eapply lctx_lft_incl_local_alias_full; done.
+ Qed.
+
+ (* For direct equivalences in the local context, just also rewrite on the RHS. *)
+ Lemma tac_lctx_lft_incl_list_augment_local_alias_rhs E L κs1 κs2 κ κ' i j :
+ L !! j = Some (κ ≡ₗ [κ']) →
+ κs2 !! i = Some κ →
+ lctx_lft_incl_list E L (κs1) (κ' :: delete i κs2) →
+ lctx_lft_incl_list E L κs1 κs2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ rewrite !delete_take_drop.
+ intros HL%elem_of_list_lookup_2 H1. rewrite -{3}(take_drop_middle κs2 _ _ H1).
+ rewrite !lft_intersect_list_app. simpl. intros Ha.
+ rewrite lft_intersect_assoc. rewrite [lft_intersect_list _ ⊓ κ]lft_intersect_comm.
+ rewrite -lft_intersect_assoc.
+ etrans; first apply Ha.
+ eapply lctx_lft_incl_intersect; last done.
+ eapply lctx_lft_incl_local_alias_reverse; [done.. | ].
+ simpl. rewrite right_id. done.
+ Qed.
+
+ (* augment lhs with an external inclusion *)
+ Lemma tac_lctx_lft_incl_list_augment_external E L κ1 κ2 κs1 κs2 i :
+ (κ1 ⊑ₑ κ2) ∈ E →
+ κs1 !! i = Some κ1 →
+ lctx_lft_incl_list E L (κ2 :: delete i κs1) κs2 →
+ lctx_lft_incl_list E L κs1 κs2.
+ Proof.
+ rewrite /lctx_lft_incl_list /=.
+ rewrite !delete_take_drop.
+ intros HE H1. rewrite -{3}(take_drop_middle κs1 _ _ H1).
+ rewrite !lft_intersect_list_app. simpl. intros Ha.
+ rewrite lft_intersect_assoc. rewrite [lft_intersect_list _ ⊓ κ1]lft_intersect_comm.
+ rewrite -lft_intersect_assoc.
+ eapply lctx_lft_incl_external_full; done.
+ Qed.
+
+ (*Lemma tac_lctx_lft_incl_list_augment_external E L κ1 κs κs1 κs2 i j :*)
+ (*E !! j = Some (κ1 ⊑ₑ κs) →*)
+ (*κs1 !! i = Some κ1 →*)
+ (*lctx_lft_incl_list E L (κs ++ delete i κs1) κs2 →*)
+ (*lctx_lft_incl_list E L κs1 κs2.*)
+ (*Proof.*)
+ (*rewrite /lctx_lft_incl_list /=.*)
+ (*rewrite !delete_take_drop.*)
+ (*intros HE%elem_of_list_lookup_2 H1. rewrite -{3}(take_drop_middle κs1 _ _ H1).*)
+ (*rewrite !foldr_app. simpl. intros Ha.*)
+ (*rewrite foldr_lft_intersect_shift_eq.*)
+ (*rewrite -lft_intersect_assoc. rewrite -foldr_lft_intersect_shift_eq.*)
+ (*eapply lctx_lft_incl_external_full; first done.*)
+ (*revert Ha.*)
+ (*rewrite foldr_lft_intersect_shift_eq.*)
+ (*rewrite lft_intersect_comm. done.*)
+ (*Qed.*)
+
+End incl_tac.
+
+(* Execute an ltac tactical [cont] for each element of a list [l].
+ [cont] gets the elements of the list as argument.
+ Breaks if [cont] succeeds.
+ *)
+Ltac list_find_tac' cont l i :=
+ match l with
+ | [] => fail
+ | ?h :: ?l => first [cont i h | list_find_tac' cont l constr:(S i)]
+ end.
+Ltac list_find_tac cont l := list_find_tac' cont l constr:(0).
+
+Ltac list_find_tac_noindex' cont l :=
+ match l with
+ | [] => fail
+ | ?h :: ?l => first [cont h | list_find_tac_noindex' cont l]
+ | _ ++ ?l => list_find_tac_noindex' cont l
+ end.
+Ltac list_find_tac_noindex cont l := list_find_tac_noindex' cont l.
+
+(* Very simple list containment solver, tailored for the goals we usually get around external lifetime contexts. *)
+Ltac elctx_list_elem_solver :=
+ repeat lazymatch goal with
+ | |- ?a ∈ ?a :: ?L =>
+ apply elem_of_cons; by left
+ | |- ?a ∈ _ :: ?L =>
+ apply elem_of_cons; right
+ | |- ?a ∈ _ ++ ?L =>
+ apply elem_of_app; right
+ end.
+
+(** Basic algorithm: Want to eliminate the RHS to [], so that the inclusion to [static] holds trivially.
+ For that, expand inclusions on the LHS, until we can eliminate one lifetime on the RHS *)
+Ltac solve_lft_incl_list_step :=
+ match goal with
+ (* normalize the head if it is an intersection *)
+ | |- lctx_lft_incl_list ?E ?L ((?κ1 ⊓ (?κ2 ⊓ ?κ3)) :: ?κs1) ?κs2 =>
+ notypeclasses refine (tac_lctx_lft_incl_list_head_assoc_l E L _ _ _ κs1 κs2 _)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 ((?κ1 ⊓ (?κ2 ⊓ ?κ3)) :: ?κs2) =>
+ notypeclasses refine (tac_lctx_lft_incl_list_head_assoc_r E L _ _ _ κs1 κs2 _)
+ (* remove the atomic rhs static of an intersection *)
+ | |- lctx_lft_incl_list ?E ?L (?κ1 ⊓ static :: ?κs1) ?κs2 =>
+ notypeclasses refine (tac_lctx_lft_incl_list_head_static_l E L _ κs1 κs2 _)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 (?κ1 ⊓ static :: ?κs2) =>
+ notypeclasses refine (tac_lctx_lft_incl_list_head_static_r E L _ κs1 κs2 _)
+ (* shift the atomic rhs conjunct of an intersection *)
+ | |- lctx_lft_incl_list ?E ?L (?κ1 ⊓ ?κ2 :: ?κs1) ?κs2 =>
+ is_var κ2;
+ notypeclasses refine (tac_lctx_lft_incl_list_intersect_l E L _ _ κs1 κs2 _)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 (?κ1 ⊓ ?κ2 :: ?κs2) =>
+ is_var κ2;
+ notypeclasses refine (tac_lctx_lft_incl_list_intersect_r E L _ _ κs1 κs2 _)
+ (* eliminate static at the head *)
+ | |- lctx_lft_incl_list ?E ?L (static :: ?κs1) ?κs2 =>
+ notypeclasses refine (tac_lctx_lft_incl_list_static_l E L κs1 κs2 _)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 (static :: ?κs2) =>
+ notypeclasses refine (tac_lctx_lft_incl_list_static_r E L κs1 κs2 _)
+ (* goal is solved if RHS is empty *)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 [] =>
+ notypeclasses refine (tac_lctx_lft_incl_list_nil_r E L κs1)
+
+ (* Normalize a direct local equivalence [κ ≡ₗ [κ']] on the RHS *)
+ (* TODO this is a hack and doesn't work in all cases, because we don't use any other (external) inclusions on the RHS.
+ Really, the proper way to do this would be to eliminate all such equivalences before starting the solver on a normalized goal + lifetime context. *)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 ?κs2 =>
+ let find_in_llctx := fun j κ =>
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | κ ≡ₗ [?κ'] =>
+ notypeclasses refine (tac_lctx_lft_incl_list_augment_local_alias_rhs E L κs1 κs2 κ κ' j i _ _ _);
+ [ reflexivity | reflexivity | simpl ]
+ | _ => fail
+ end
+ ) L
+ in
+ list_find_tac find_in_llctx κs2
+
+ (* eliminate a lifetime on the RHS that also occurs on the LHS *)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 ?κs2 =>
+ let check_equality := fun j κ2 => ltac:(fun i κ1 =>
+ first [unify κ1 κ2;
+ notypeclasses refine (tac_lctx_lft_incl_list_dispatch_r E L i j κ1 κs1 κs2 _ _ _);
+ [reflexivity | reflexivity | simpl ]
+ | fail ]
+ ) in
+ let check_left := (fun j κ2 => list_find_tac ltac:(check_equality j κ2) κs1) in
+ list_find_tac check_left κs2
+
+ (* Expand a local lifetime on the LHS *)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 ?κs2 =>
+ let find_in_llctx := fun j κ =>
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | κ ⊑ₗ{_} ?κs =>
+ (* only do this if the RHS is non-empty---otherwise, this cannot serve to make progress *)
+ assert_fails (unify κs (@nil lft));
+ notypeclasses refine (tac_lctx_lft_incl_list_augment_local_owned E L κs1 κs2 κ κs j i _ _ _ _);
+ [ reflexivity | reflexivity | simpl ]
+ | κ ≡ₗ ?κs =>
+ (* only do this if the RHS is non-empty---otherwise, this cannot serve to make progress *)
+ assert_fails (unify κs (@nil lft));
+ notypeclasses refine (tac_lctx_lft_incl_list_augment_local_alias E L κs1 κs2 κ κs j i _ _ _);
+ [ reflexivity | reflexivity | simpl ]
+ | _ => fail
+ end
+ ) L
+ in
+ list_find_tac find_in_llctx κs1
+
+
+ (* expand an external lifetime on the LHS *)
+ (* TODO: we cannot always make this expansion safely and may need backtracking (there might be multiple possible expansions);
+ alternatively, think about representing the elctx similar to llctx (with unique LHS).
+ [works, but would cause problems in the procedure for lctx_lft_alive below...]
+ also, this might loop, since there can be cycles in the elctx. we need to keep track of that.
+ *)
+ | |- lctx_lft_incl_list ?E ?L ?κs1 ?κs2 =>
+ let find_in_elctx := fun j κ =>
+ list_find_tac_noindex ltac:(fun el =>
+ match el with
+ | κ ⊑ₑ ?κ' =>
+ notypeclasses refine (tac_lctx_lft_incl_list_augment_external E L κ κ' κs1 κs2 j _ _ _);
+ [ elctx_list_elem_solver | reflexivity | simpl ]
+ | _ => fail
+ end
+ ) E
+ in
+ list_find_tac find_in_elctx κs1
+ end.
+Ltac solve_lft_incl_list := repeat solve_lft_incl_list_step.
+Ltac solve_lft_incl :=
+ match goal with
+ | |- lctx_lft_incl ?E ?L ?κ1 ?κ2 =>
+ first [unify κ1 κ2; refine (lctx_lft_incl_refl E L κ1) |
+ refine (tac_lctx_lft_incl_init_list E L κ1 κ2 _);
+ solve_lft_incl_list
+ ]
+ end.
+
+(** lifetime alive solver *)
+(*
+ desired invariant:
+ - every lifetime on the lhs of ⊑ₗ should be alive (because we should end lifetimes in a well-nested way, ending (and removing) shorter lifetimes first.
+ -> if we can find a lifetime on the lhs in the local context, it should always be safe to apply [lctx_lft_alive_local] and reduce to smaller subgoals.
+ - if a lifetime is external, it should be alive, because it outlives the local function lifetime, which should always be in the local context.
+ -> if we can find a lifetime on the RHS of a ⊑ₑ, it should always be safe to apply [lctx_lft_alive_external]
+ - for intersections, we should split to both sides. This should always be safe as the lifetime contexts should only contain atoms on the LHS.
+ *)
+
+Section alive_tac.
+ Context `{typeGS Σ}.
+
+
+ Lemma tac_lctx_lft_alive_intersect E L κ κ' :
+ lctx_lft_alive E L κ →
+ lctx_lft_alive E L κ' →
+ lctx_lft_alive E L (κ ⊓ κ').
+ Proof. apply lctx_lft_alive_intersect. Qed.
+
+ Lemma tac_lctx_lft_alive_local_owned E L κ κs i c :
+ L !! i = Some (κ ⊑ₗ{c} κs) →
+ Forall_cb (lctx_lft_alive E L) κs →
+ lctx_lft_alive E L κ.
+ Proof.
+ intros ?%elem_of_list_lookup_2 ?%Forall_Forall_cb.
+ by eapply lctx_lft_alive_local_owned.
+ Qed.
+
+ Lemma tac_lctx_lft_alive_local_alias E L κ κs i :
+ L !! i = Some (κ ≡ₗ κs) →
+ Forall_cb (lctx_lft_alive E L) κs →
+ lctx_lft_alive E L κ.
+ Proof.
+ intros ?%elem_of_list_lookup_2 ?%Forall_Forall_cb.
+ by eapply lctx_lft_alive_local_alias.
+ Qed.
+
+ (* This weakens the elctx by removing the inclusion we used.
+ This should ensure termination of the solver without making goals unprovable.
+ (once we need to prove liveness of an external lifetime, the only local lifetime we should
+ need is Ï)
+ *)
+ Lemma tac_lctx_lft_alive_external E L κ κ' i :
+ E !! i = Some (κ' ⊑ₑ κ) →
+ lctx_lft_alive (delete i E) L κ' →
+ lctx_lft_alive E L κ.
+ Proof.
+ intros ?%elem_of_list_lookup_2 H'.
+ eapply lctx_lft_alive_external; first done.
+ iIntros (F ??) "#HE HL".
+ iApply H'; [ done | | done].
+ iApply (big_sepL_submseteq with "HE").
+ apply submseteq_delete.
+ Qed.
+End alive_tac.
+
+Ltac solve_lft_alive :=
+ repeat match goal with
+ | |- Forall (lctx_lft_alive ?E ?L) ?κs =>
+ notypeclasses refine (proj2 (Forall_Forall_cb _ _) _);
+ simpl; first [exact I | split_and! ]
+ | |- lctx_lft_alive ?E ?L static =>
+ notypeclasses refine (lctx_lft_alive_static E L)
+ | |- lctx_lft_alive ?E ?L (?κ ⊓ ?κ') =>
+ notypeclasses refine (tac_lctx_lft_alive_intersect _ _ _ _ _ _);
+ [solve_lft_alive | solve_lft_alive]
+ | |- lctx_lft_alive ?E ?L ?κ =>
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | κ ⊑ₗ{_} ?κs =>
+ notypeclasses refine (tac_lctx_lft_alive_local_owned E L κ κs i _ _ _);
+ [ reflexivity | simpl; first [exact I | split_and! ] ]
+ | κ ≡ₗ ?κs =>
+ notypeclasses refine (tac_lctx_lft_alive_local_alias E L κ κs i _ _);
+ [ reflexivity | simpl; first [exact I | split_and! ] ]
+ | _ => fail
+ end) L
+ | |- lctx_lft_alive ?E ?L ?κ =>
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | ?κ' ⊑ₑ κ =>
+ notypeclasses refine (tac_lctx_lft_alive_external E L κ κ' i _ _);
+ [reflexivity | simpl; solve[solve_lft_alive]]
+ | _ => fail
+ end) E
+ end; fast_done.
+
+(** simplify_elctx *)
+
+Global Arguments ty_lfts : simpl never.
+Global Arguments ty_wf_E : simpl never.
+Global Arguments ty_outlives_E : simpl never.
+(*Global Arguments tyl_outlives_E : simpl never.*)
+(*Global Arguments tyl_wf_E : simpl never.*)
+
+(* Otherwise [simpl] will unfold too much despite [simpl never], breaking the solver *)
+Global Opaque ty_outlives_E.
+
+Section tac.
+ Context `{!typeGS Σ}.
+ Lemma simplify_app_head_tac (E1 E1' E2 E : elctx) :
+ E1 = E1' →
+ E1' ++ E2 = E →
+ E1 ++ E2 = E.
+ Proof.
+ intros <- <-. done.
+ Qed.
+
+ Lemma simplify_app_head_init_tac (E E' : elctx) :
+ E ++ [] = E' →
+ E = E'.
+ Proof.
+ rewrite app_nil_r. done.
+ Qed.
+
+ Lemma lfts_outlives_cons κ1 κs2 κ :
+ lfts_outlives_E (κ1 :: κs2) κ = lfts_outlives_E [κ1] κ ++ lfts_outlives_E κs2 κ.
+ Proof.
+ rewrite /lfts_outlives_E fmap_cons//.
+ Qed.
+ Lemma lfts_outlives_app κs1 κs2 κ :
+ lfts_outlives_E (κs1 ++ κs2) κ = lfts_outlives_E κs1 κ ++ lfts_outlives_E κs2 κ.
+ Proof.
+ rewrite /lfts_outlives_E fmap_app//.
+ Qed.
+ Lemma lfts_outlives_nil κ :
+ lfts_outlives_E [] κ = [].
+ Proof. done. Qed.
+ Lemma lfts_outlives_singleton κ2 κ :
+ lfts_outlives_E [κ2] κ = [κ ⊑ₑ κ2].
+ Proof. done. Qed.
+ Lemma ty_outlives_E_eq {rt} (ty : type rt) κ :
+ ty_outlives_E ty κ = lfts_outlives_E (ty_lfts ty) κ.
+ Proof.
+ unfold_opaque @ty_outlives_E. done.
+ Qed.
+End tac.
+
+Ltac simplify_elctx_subterm :=
+ match goal with
+ | |- ty_wf_E ?ty = _ =>
+ assert_fails (is_var ty);
+ rewrite [ty_wf_E ty]/ty_wf_E/=;
+ cbn;
+ reflexivity
+ (*autounfold with tyunfold; cbn*)
+ | |- ty_outlives_E ?ty _ = _ =>
+ assert_fails (is_var ty);
+ unfold_opaque (@ty_outlives_E);
+ rewrite [ty_outlives_E ty]/ty_outlives_E/=;
+ first [rewrite lfts_outlives_app | autounfold with tyunfold; rewrite /ty_lfts ]; cbn;
+ reflexivity
+ | |- lfts_outlives_E (ty_lfts ?ty) _ = _ =>
+ (*(is_var ty);*)
+ (*rewrite [ty_outlives_E ty]/ty_outlives_E/=;*)
+ first [is_var ty | rewrite lfts_outlives_app | autounfold with tyunfold; rewrite /ty_lfts ]; cbn;
+ reflexivity
+ | |- lfts_outlives_E [?κ2] _ = _ =>
+ rewrite lfts_outlives_singleton;
+ reflexivity
+ | |- lfts_outlives_E (?κs1 ++ ?κs2) _ = _ =>
+ (*assert_fails (is_var κs);*)
+ rewrite lfts_outlives_app; cbn;
+ reflexivity
+ | |- lfts_outlives_E (?κ1 :: ?κs2) _ = _ =>
+ (*assert_fails (is_var κs);*)
+ rewrite lfts_outlives_cons; cbn;
+ reflexivity
+ (*| |- lfts_outlives_E (ty_lfts ?ty) _ = _ =>*)
+ (*idtac*)
+ end.
+
+Ltac simplify_elctx_step :=
+cbn;
+rewrite -?app_assoc;
+match goal with
+| |- ty_wf_E ?ty ++ _ = _ =>
+ assert_fails (is_var ty);
+ refine (simplify_app_head_tac _ _ _ _ _ _);
+ [ simplify_elctx_subterm | ]
+| |- ty_wf_E ?ty ++ _ = _ =>
+ is_var ty; f_equiv
+| |- ty_outlives_E ?ty _ ++ _ = _ =>
+ assert_fails (is_var ty);
+ unfold_opaque (@ty_outlives_E);
+ refine (simplify_app_head_tac _ _ _ _ _ _);
+ [ simplify_elctx_subterm | ]
+| |- ty_outlives_E ?ty _ ++ _ = _ =>
+ is_var ty; f_equiv
+| |- lfts_outlives_E (ty_lfts ?T) ?κ ++ _ = _ =>
+ is_var T;
+ (*fold (ty_outlives_E T κ);*)
+ rewrite -(ty_outlives_E_eq T κ);
+ f_equiv
+| |- lfts_outlives_E [] _ ++ _ = _ =>
+ rewrite lfts_outlives_nil
+| |- lfts_outlives_E ?κs _ ++ _ = _ =>
+ assert_fails (is_var κs);
+ refine (simplify_app_head_tac _ _ _ _ _ _);
+ [ simplify_elctx_subterm | ]
+| |- _ :: _ = _ =>
+ f_equiv
+| |- [] = _ =>
+ reflexivity
+end.
+
+Ltac simplify_elctx :=
+ match goal with
+ | |- ?E = ?E' =>
+ is_evar E';
+ (* Unfold here. Important: do not use [simpl] after that, because it will unfold too much so that stuff breaks. *)
+ (*unfold_opaque (@ty_outlives_E);*)
+ cbn;
+ refine (simplify_app_head_init_tac _ _ _);
+ rewrite -?app_assoc;
+ repeat simplify_elctx_step
+ end.
+
+(** Reordering an [elctx] so that all the opaque inclusions from generics are at the tail,
+ while directly known inclusions appear at the head. This makes life easier for the lifetime solvers. *)
+Section reorder_elctx.
+ Context `{!typeGS Σ}.
+
+ Lemma reorder_elctx_tac Ï€ E E' L s fn R Ï :
+ E ≡ₚ E' →
+ typed_stmt Ï€ (E') L s fn R Ï -∗
+ typed_stmt Ï€ E L s fn R Ï.
+ Proof.
+ iIntros (HP) "Hs".
+ iIntros "#CTX #HE HL".
+ iApply ("Hs" with "CTX [] HL").
+ iApply elctx_interp_permut; done.
+ Qed.
+
+ Lemma reorder_elctx_init_tac (E E0 E' E'' : elctx) :
+ E ≡ₚ E' ++ E'' →
+ E0 = E' ++ E'' →
+ E ≡ₚ E0.
+ Proof.
+ intros -> ->. done.
+ Qed.
+
+ Lemma reorder_elctx_shuffle_left_tac E E' E1' E'' κ1 κ2 :
+ E' = (κ1 ⊑ₑ κ2) :: E1' →
+ E ≡ₚ E1' ++ E'' →
+ (κ1 ⊑ₑ κ2) :: E ≡ₚ E' ++ E''.
+ Proof.
+ intros -> Hp. simpl. f_equiv. done.
+ Qed.
+
+ Lemma reorder_elctx_shuffle_right_tac (E E' E1'' E'' E0 : elctx) :
+ E'' = E0 ++ E1'' →
+ E ≡ₚ E' ++ E1'' →
+ E0 ++ E ≡ₚ E' ++ E''.
+ Proof.
+ intros -> ->.
+ rewrite [E0 ++ _]assoc [E0 ++ _]comm - [(E' ++ E0) ++ E1'']assoc.
+ done.
+ Qed.
+End reorder_elctx.
+
+(** The invariant is that we shuffle all the opaque parts into [E''],
+ while the concrete parts get shuffled into [E']. *)
+Ltac reorder_elctx_step :=
+ match goal with
+ | |- ?E ≡ₚ ?E' ++ ?E'' =>
+ match E with
+ | _ :: ?E =>
+ refine (reorder_elctx_shuffle_left_tac E E' _ E'' _ _ _ _);
+ [reflexivity | ]
+ | ?E0 ++ ?E =>
+ refine (reorder_elctx_shuffle_right_tac E E' _ E'' E0 _ _);
+ [reflexivity | ]
+ | [] => unify E' ([] : elctx); unify E'' ([] : elctx); reflexivity
+ | ?E =>
+ unify E' ([] : elctx); unify E'' (E); reflexivity
+ end
+ end.
+
+Ltac reorder_elctx :=
+ match goal with
+ | |- ?E ≡ₚ ?E' =>
+ is_evar E';
+ refine (reorder_elctx_init_tac E E' _ _ _ _);
+ [ solve [repeat reorder_elctx_step]
+ | rewrite ?app_nil_r; reflexivity ]
+ end.
+
+(** elctx_sat solver *)
+Section elctx_sat.
+ Context `{typeGS Σ}.
+
+ Lemma tac_elctx_sat_cons_r E E' L κ κ' i :
+ E !! i = Some (κ ⊑ₑ κ') →
+ elctx_sat E L (E') →
+ elctx_sat E L ((κ ⊑ₑ κ') :: E').
+ Proof.
+ intros ?%elem_of_list_lookup_2 Hr.
+ eapply (elctx_sat_app _ _ [_]); last done.
+ eapply elctx_sat_submseteq.
+ by apply singleton_submseteq_l.
+ Qed.
+
+ Lemma tac_elctx_sat_simpl E1 E2 L E1' E2' :
+ (E1 = E1') →
+ (E2 = E2') →
+ elctx_sat E1' L E2' →
+ elctx_sat E1 L E2.
+ Proof.
+ intros -> ->. done.
+ Qed.
+
+ Lemma tac_elctx_app_ty_wf_E E1 L {rt} (ty : type rt) :
+ ty_wf_E ty ⊆+ E1 →
+ elctx_sat E1 L (ty_wf_E ty).
+ Proof.
+ intros Hsub Hsat.
+ apply elctx_sat_submseteq; done.
+ Qed.
+
+ Lemma tac_elctx_app_ty_outlives_E E1 L κ κ' {rt} (ty : type rt) :
+ ty_outlives_E ty κ' ⊆+ E1 →
+ lctx_lft_incl E1 L κ κ' →
+ elctx_sat E1 L (ty_outlives_E ty κ).
+ Proof.
+ intros Houtl Hincl.
+ eapply (elctx_sat_submseteq _ _ L) in Houtl.
+ iIntros (qL) "HL".
+ iPoseProof (Hincl with "HL") as "#Hincl".
+ iPoseProof (Houtl with "HL") as "#Houtl".
+ iModIntro. iIntros "#HE".
+ iPoseProof ("Hincl" with "HE") as "Hincl'".
+ iPoseProof ("Houtl" with "HE") as "Houtl'".
+ iClear "Hincl Houtl HE".
+ unfold_opaque @ty_outlives_E.
+ rewrite /ty_outlives_E /lfts_outlives_E.
+ generalize (ty_lfts ty) => κs. clear.
+ iInduction κs as [ | κ0 κs] "IH"; simpl; first done.
+ rewrite /elctx_interp. simpl.
+ iDestruct "Houtl'" as "(Ha & Houtl)".
+ iPoseProof ("IH" with "Houtl") as "$".
+ rewrite /elctx_elt_interp/=.
+ iApply lft_incl_trans; done.
+ Qed.
+
+ Lemma tac_submseteq_skip_app_r {A} (K E0 E1 : list A) :
+ K ⊆+ E1 →
+ K ⊆+ (E0 ++ E1).
+ Proof.
+ intros ?. apply submseteq_app_r.
+ exists [], K. split_and!; [done | | done].
+ apply submseteq_nil_l.
+ Qed.
+
+ Lemma tac_submseteq_find_app_r {A} (K E0 E1 : list A) :
+ K = E0 →
+ K ⊆+ (E0 ++ E1).
+ Proof.
+ intros ->. apply submseteq_app_r.
+ eexists E0, []. rewrite app_nil_r.
+ split_and!; [done.. | ]. apply submseteq_nil_l.
+ Qed.
+
+ Lemma tac_submseteq_init {A} (K E : list A) :
+ K ⊆+ E ++ [] →
+ K ⊆+ E.
+ Proof.
+ rewrite app_nil_r//.
+ Qed.
+End elctx_sat.
+
+Ltac solve_elctx_submseteq_step :=
+ simpl;
+ lazymatch goal with
+ | |- _ ⊆+ _ :: _ =>
+ notypeclasses refine (submseteq_cons _ _ _ _)
+ | |- _ ⊆+ (_ ++ _) ++ _ =>
+ rewrite -app_assoc
+ | |- ty_outlives_E ?ty ?κ ⊆+ (ty_outlives_E ?ty' ?κ') ++ ?E =>
+ first [
+ unify ty ty';
+ notypeclasses refine (tac_submseteq_find_app_r _ _ _ _); reflexivity
+ | notypeclasses refine (tac_submseteq_skip_app_r _ _ _ _)
+ ]
+ | |- ty_wf_E ?ty ⊆+ (ty_wf_E ?ty') ++ ?E =>
+ first [
+ unify ty ty';
+ notypeclasses refine (tac_submseteq_find_app_r _ _ _ _); reflexivity
+ | notypeclasses refine (tac_submseteq_skip_app_r _ _ _ _)
+ ]
+ | |- _ ⊆+ _ ++ _ =>
+ notypeclasses refine (tac_submseteq_skip_app_r _ _ _ _)
+ end.
+Ltac solve_elctx_submseteq :=
+ notypeclasses refine (tac_submseteq_init _ _ _);
+ repeat solve_elctx_submseteq_step.
+
+Ltac solve_elctx_sat_step :=
+ match goal with
+ | |- elctx_sat ?E ?L [] =>
+ notypeclasses refine (elctx_sat_nil _ _)
+ | |- elctx_sat ?E ?L ?E =>
+ notypeclasses refine (elctx_sat_refl _ _)
+ | |- elctx_sat ?E ?L (?E1 ++ ?E2) =>
+ notypeclasses refine (elctx_sat_app E L E1 E2 _ _)
+ (* dispatch as many elements as possible via direct inclusion *)
+ | |- elctx_sat ?E ?L ((?κ ⊑ₑ ?κ') :: ?E') =>
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | (κ ⊑ₑ κ') =>
+ notypeclasses refine (tac_elctx_sat_cons_r E L κ κ' i _ _);
+ [reflexivity | ]
+ | _ => fail
+ end) E
+ (* dispatch remaining elements via lifetime inclusion solving *)
+ | |- elctx_sat ?E ?L ((?κ ⊑ₑ ?κ') :: ?E') =>
+ notypeclasses refine (elctx_sat_lft_incl E L E' κ κ' _ _);
+ [solve_lft_incl | ]
+ (* dispatch assumptions for generic type parameters *)
+ | |- elctx_sat ?E ?L (ty_wf_E ?ty) =>
+ notypeclasses refine (tac_elctx_app_ty_wf_E E L ty _);
+ solve_elctx_submseteq
+ | |- elctx_sat ?E ?L (ty_outlives_E ?ty ?κ) =>
+ notypeclasses refine (tac_elctx_app_ty_outlives_E E L κ _ ty _ _);
+ [ solve_elctx_submseteq | solve_lft_incl ]
+ end.
+
+Ltac solve_elctx_sat :=
+ (* first unfold stuff is commonly included in these conditions *)
+ (*let esimpl := (unfold ty_outlives_E, tyl_outlives_E; simpl; notypeclasses refine eq_refl) in*)
+ lazymatch goal with
+ | |- elctx_sat ?E ?L ?E' =>
+ notypeclasses refine (tac_elctx_sat_simpl _ _ _ _ _ _ _ _);
+ [ simplify_elctx | simplify_elctx | ]
+ end;
+ repeat solve_elctx_sat_step
+ .
+
+(** lctx_bor_kind_alive solver *)
+Section bor_kind_alive_tac.
+ Context `{typeGS Σ}.
+
+ Lemma tac_lctx_bor_kind_alive_simpl E L b b' :
+ (∀ (b'':=b'), b = b'') →
+ lctx_bor_kind_alive E L b' →
+ lctx_bor_kind_alive E L b.
+ Proof.
+ intros ->. done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_alive_shared E L κ:
+ lctx_lft_alive E L κ →
+ lctx_bor_kind_alive E L (Shared κ).
+ Proof. done. Qed.
+
+ Lemma tac_lctx_bor_kind_alive_uniq E L κ γ :
+ lctx_lft_alive E L κ →
+ lctx_bor_kind_alive E L (Uniq κ γ).
+ Proof. done. Qed.
+
+ Lemma tac_lctx_bor_kind_alive_owned E L wl :
+ lctx_bor_kind_alive E L (Owned wl).
+ Proof. done. Qed.
+End bor_kind_alive_tac.
+
+Global Arguments lctx_bor_kind_alive : simpl never.
+Ltac solve_bor_kind_alive :=
+ (* first compute [bor_kind_min] *)
+ let simp_min := let x := fresh in intros x; unfold bor_kind_min; simpl; unfold x; notypeclasses refine eq_refl in
+ match goal with
+ | |- lctx_bor_kind_alive ?E ?L ?b =>
+ refine (tac_lctx_bor_kind_alive_simpl _ _ _ _ _ _);
+ [ simp_min
+ | ]
+ | |- _ =>
+ fail 1000 "solve_bor_kind_alive: not an lctx_bor_kind_alive"
+ end;
+ match goal with
+ | |- lctx_bor_kind_alive ?E ?L (Uniq _ _) =>
+ refine (tac_lctx_bor_kind_alive_uniq _ _ _ _ _); [solve_lft_alive]
+ | |- lctx_bor_kind_alive ?E ?L (Shared _) =>
+ refine (tac_lctx_bor_kind_alive_shared _ _ _ _); [solve_lft_alive]
+ | |- lctx_bor_kind_alive ?E ?L (Owned _) =>
+ refine (tac_lctx_bor_kind_alive_owned _ _ _); solve[fail]
+ | |- lctx_bor_kind_alive _ _ _ =>
+ fail 1000 "solve_bor_kind_alive: cannot determine bor_kind shape"
+ end.
+
+(** lctx_bor_kind_incl solver *)
+(* this essentially reduces to solve_lft_incl *)
+Section bor_kind_incl_tac.
+ Context `{typeGS Σ}.
+
+ Lemma tac_lctx_bor_kind_incl_simpl E L b1 b1' b2 b2' :
+ (∀ (b1'':=b1'), b1 = b1'') →
+ (∀ (b2'':=b2'), b2 = b2'') →
+ lctx_bor_kind_incl E L b1' b2' →
+ lctx_bor_kind_incl E L b1 b2.
+ Proof.
+ intros -> ->. done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_incl_any_owned E L b wl :
+ lctx_bor_kind_incl E L b (Owned wl).
+ Proof.
+ iIntros (?) "HL !> HE". destruct b; done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_incl_uniq_uniq E L κ γ κ' γ' :
+ lctx_lft_incl E L κ κ' →
+ lctx_bor_kind_incl E L (Uniq κ γ) (Uniq κ' γ').
+ Proof.
+ iIntros (Hincl ?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iIntros "!> HE". iDestruct ("Hincl" with "HE") as "#Hincl'".
+ done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_incl_shared_uniq E L κ κ' γ' :
+ lctx_lft_incl E L κ κ' →
+ lctx_bor_kind_incl E L (Shared κ) (Uniq κ' γ').
+ Proof.
+ iIntros (Hincl ?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iIntros "!> HE". iDestruct ("Hincl" with "HE") as "#Hincl'".
+ done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_incl_shared_shared E L κ κ' :
+ lctx_lft_incl E L κ κ' →
+ lctx_bor_kind_incl E L (Shared κ) (Shared κ').
+ Proof.
+ iIntros (Hincl ?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iIntros "!> HE". iDestruct ("Hincl" with "HE") as "#Hincl'".
+ done.
+ Qed.
+End bor_kind_incl_tac.
+Ltac solve_bor_kind_incl :=
+ (* first compute [bor_kind_min] *)
+ let simp_min := let x := fresh in intros x; unfold bor_kind_min; simpl; unfold x; notypeclasses refine eq_refl in
+ match goal with
+ | |- lctx_bor_kind_incl ?E ?L ?b1 ?b2 =>
+ refine (tac_lctx_bor_kind_incl_simpl _ _ _ _ _ _ _ _ _);
+ [ simp_min
+ | simp_min
+ | ]
+ | |- _ =>
+ fail 1000 "solve_bor_kind_incl: not an lctx_bor_kind_incl"
+ end;
+ match goal with
+ | |- lctx_bor_kind_incl ?E ?L _ (Owned _) =>
+ refine (tac_lctx_bor_kind_incl_any_owned _ _ _ _); solve[fail]
+ | |- lctx_bor_kind_incl ?E ?L (Uniq _ _) (Uniq _ _) =>
+ refine (tac_lctx_bor_kind_incl_uniq_uniq _ _ _ _ _ _ _); [solve_lft_incl]
+ | |- lctx_bor_kind_incl ?E ?L (Shared _) (Uniq _ _) =>
+ refine (tac_lctx_bor_kind_incl_shared_uniq _ _ _ _ _ _); [solve_lft_incl]
+ | |- lctx_bor_kind_incl ?E ?L (Shared _) (Shared _) =>
+ refine (tac_lctx_bor_kind_incl_shared_shared _ _ _ _ _); [solve_lft_incl]
+ | |- lctx_bor_kind_incl ?E ?L ?b1 ?b2 =>
+ fail 1000 "solve_bor_kind_incl: unable to solve inclusion"
+ end.
+
+(** llctx_bor_kind_direct_incl solver *)
+Section bor_kind_direct_incl_tac.
+ Context `{typeGS Σ}.
+
+ Lemma tac_lctx_bor_kind_direct_incl_simpl E L b1 b2 b1' b2' :
+ (∀ (b1'':=b1'), b1 = b1'') →
+ (∀ (b2'':=b2'), b2 = b2'') →
+ lctx_bor_kind_direct_incl E L b1' b2' →
+ lctx_bor_kind_direct_incl E L b1 b2.
+ Proof.
+ intros -> ->. done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_direct_incl_owned_owned E L wl :
+ lctx_bor_kind_direct_incl E L (Owned wl) (Owned wl).
+ Proof.
+ iIntros (?) "HL !> HE". done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_direct_incl_uniq_uniq E L κ γ κ' :
+ lctx_lft_incl E L κ κ' →
+ lctx_bor_kind_direct_incl E L (Uniq κ γ) (Uniq κ' γ).
+ Proof.
+ iIntros (Hincl ?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iIntros "!> HE". iDestruct ("Hincl" with "HE") as "#Hincl'".
+ iSplitR; done.
+ Qed.
+
+ Lemma tac_lctx_bor_kind_direct_incl_shared_shared E L κ κ' :
+ lctx_lft_incl E L κ κ' →
+ lctx_bor_kind_direct_incl E L (Shared κ) (Shared κ').
+ Proof.
+ iIntros (Hincl ?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iIntros "!> HE". iDestruct ("Hincl" with "HE") as "#Hincl'".
+ done.
+ Qed.
+End bor_kind_direct_incl_tac.
+Ltac solve_bor_kind_direct_incl :=
+ (* first compute [bor_kind_min] *)
+ let simp_min := let x := fresh in intros x; unfold bor_kind_min; simpl; unfold x; notypeclasses refine eq_refl in
+ match goal with
+ | |- lctx_bor_kind_direct_incl ?E ?L ?b1 ?b2 =>
+ refine (tac_lctx_bor_kind_direct_incl_simpl _ _ _ _ _ _ _ _ _);
+ [ simp_min
+ | simp_min
+ | ]
+ | |- _ =>
+ fail 1000 "solve_bor_kind_direct_incl: not an lctx_bor_kind_direct_incl"
+ end;
+ match goal with
+ | |- lctx_bor_kind_direct_incl ?E ?L (Owned _) (Owned _) =>
+ refine (tac_lctx_bor_kind_direct_incl_owned_owned _ _ _); solve[fail]
+ | |- lctx_bor_kind_direct_incl ?E ?L (Uniq _ _) (Uniq _ _) =>
+ refine (tac_lctx_bor_kind_direct_incl_uniq_uniq _ _ _ _ _ _); [solve_lft_incl]
+ | |- lctx_bor_kind_direct_incl ?E ?L (Shared _) (Shared _) =>
+ refine (tac_lctx_bor_kind_direct_incl_shared_shared _ _ _ _ _); [solve_lft_incl]
+ | |- lctx_bor_kind_direct_incl ?E ?L ?b1 ?b2 =>
+ fail 1000 "solve_bor_kind_direct_incl: unable to solve inclusion"
+ end.
+
+(** lctx_lft_alive_count *)
+Section alive_tac.
+ Context `{typeGS Σ}.
+
+ Lemma tac_lctx_lft_alive_count_local_owned i c κs E L κ κs' κs'' L' L'' :
+ lctx_lft_alive_count_iter E L κs κs' L' →
+ L' !! i = Some (κ ⊑ₗ{c} κs) →
+ κs'' = κ :: κs' →
+ L'' = (<[i:=κ ⊑ₗ{ S c} κs]> L') →
+ lctx_lft_alive_count E L κ κs'' L''.
+ Proof.
+ intros ? ? -> ->. by eapply lctx_lft_alive_count_local_owned.
+ Qed.
+
+ Lemma tac_lctx_lft_alive_count_local_alias i κs E L κ κs' L' :
+ lctx_lft_alive_count_iter E L κs κs' L' →
+ L !! i = Some (κ ≡ₗ κs) →
+ lctx_lft_alive_count E L κ κs' L'.
+ Proof.
+ intros ? ?. eapply lctx_lft_alive_count_local_alias; last done.
+ by eapply elem_of_list_lookup_2.
+ Qed.
+
+ Lemma tac_lctx_lft_alive_count_iter_cons E L κ κs κs1 κs2 κs3 L1 L2 :
+ lctx_lft_alive_count E L κ κs1 L1 →
+ lctx_lft_alive_count_iter E L1 κs κs2 L2 →
+ κs3 = κs1 ++ κs2 →
+ lctx_lft_alive_count_iter E L (κ :: κs) κs3 L2.
+ Proof.
+ intros ? ? ->. simpl. eexists _, _, _. done.
+ Qed.
+ Lemma tac_lctx_lft_alive_count_iter_nil E L :
+ lctx_lft_alive_count_iter E L [] [] L.
+ Proof. done. Qed.
+
+ Lemma tac_lctx_lft_alive_count_intersect E L κ κ' κs1 κs2 κs3 L1 L2 :
+ lctx_lft_alive_count E L κ κs1 L1 →
+ lctx_lft_alive_count E L1 κ' κs2 L2 →
+ κs3 = κs1 ++ κs2 →
+ lctx_lft_alive_count E L (κ ⊓ κ') κs3 L2.
+ Proof. intros ?? ->. by eapply lctx_lft_alive_count_intersect. Qed.
+
+ (* This weakens the elctx by removing the inclusion we used.
+ This should ensure termination of the solver without making goals unprovable.
+ (once we need to prove liveness of an external lifetime, the only local lifetime we should
+ need is Ï)
+ *)
+ Lemma tac_lctx_lft_alive_count_external i E L κ κ' κs L' :
+ E !! i = Some (κ' ⊑ₑ κ) →
+ lctx_lft_alive_count (delete i E) L κ' κs L' →
+ lctx_lft_alive_count E L κ κs L'.
+ Proof.
+ intros ?%elem_of_list_lookup_2 H'.
+ eapply lctx_lft_alive_count_external; first done.
+ iIntros (F ?) "#HE HL".
+ iApply H'; [ done | | done].
+ iApply (big_sepL_submseteq with "HE").
+ apply submseteq_delete.
+ Qed.
+
+End alive_tac.
+
+(* redefined below *)
+Ltac solve_lft_alive_count_iter :=
+ idtac.
+
+Ltac solve_lft_alive_count ::=
+ repeat match goal with
+ | |- lctx_lft_alive_count ?E ?L static _ _ =>
+ notypeclasses refine (lctx_lft_alive_count_static E L)
+ | |- lctx_lft_alive_count ?E ?L (?κ ⊓ ?κ') _ _ =>
+ notypeclasses refine (tac_lctx_lft_alive_count_intersect E L κ κ' _ _ _ _ _ _ _ _);
+ [solve_lft_alive_count | solve_lft_alive_count | simpl; reflexivity ]
+ (* local inclusion *)
+ | |- lctx_lft_alive_count ?E ?L ?κ _ _ =>
+ (** Here, the solver relies on the fact that the indices of lifetimes should not change when increasing the counts. *)
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | κ ⊑ₗ{?c} ?κs =>
+ notypeclasses refine (tac_lctx_lft_alive_count_local_owned i c κs E L κ _ _ _ _ _ _ _ _);
+ [ solve_lft_alive_count_iter
+ | simpl; reflexivity
+ | simpl; reflexivity
+ | simpl; reflexivity ]
+ | κ ≡ₗ?κs =>
+ notypeclasses refine (tac_lctx_lft_alive_count_local_alias i κs E L κ _ _ _ _);
+ [ solve_lft_alive_count_iter
+ | simpl; reflexivity ]
+ | _ => fail
+ end) L
+ (* external inclusion *)
+ | |- lctx_lft_alive_count ?E ?L ?κ _ _ =>
+ list_find_tac ltac:(fun i el =>
+ match el with
+ | ?κ' ⊑ₑ κ =>
+ notypeclasses refine (tac_lctx_lft_alive_count_external i E L κ κ' _ _ _ _);
+ [reflexivity | simpl; solve[solve_lft_alive_count]]
+ | _ => fail
+ end) E
+ end; fast_done.
+
+Ltac solve_lft_alive_count_iter ::=
+ match goal with
+ | |- lctx_lft_alive_count_iter ?E ?L [] _ _ =>
+ notypeclasses refine (tac_lctx_lft_alive_count_iter_nil E L)
+ | |- lctx_lft_alive_count_iter ?E ?L (?κ :: ?κs) _ _ =>
+ notypeclasses refine (tac_lctx_lft_alive_count_iter_cons E L κ κs _ _ _ _ _ _ _ _);
+ [ solve_lft_alive_count
+ | solve_lft_alive_count_iter
+ | simpl; reflexivity ]
+ end.
+
+Section return_tac.
+ Context `{!invGS Σ, !lctxGS Σ, !lftGS Σ lft_userE}.
+
+ Lemma tac_llctx_release_toks_nil L :
+ llctx_release_toks L [] L.
+ Proof. done. Qed.
+
+ Lemma tac_llctx_release_toks_cons i c κs' L κ κs L1 L2 :
+ L !! i = Some (κ ⊑ₗ{c} κs') →
+ L1 = <[i := κ ⊑ₗ{pred c} κs']> L →
+ llctx_release_toks L1 κs L2 →
+ llctx_release_toks L (κ :: κs) L2.
+ Proof.
+ intros ? -> ?. simpl. left. eexists _, _, _. done.
+ Qed.
+
+ Lemma tac_llctx_release_toks_cons_skips κ κs L1 L2 :
+ llctx_release_toks L1 κs L2 →
+ llctx_release_toks L1 (κ :: κs) L2.
+ Proof.
+ intros ?. simpl. right. done.
+ Qed.
+End return_tac.
+
+Ltac solve_llctx_release_toks ::=
+ match goal with
+ | |- llctx_release_toks ?L [] _ =>
+ notypeclasses refine (tac_llctx_release_toks_nil L)
+ | |- llctx_release_toks ?L (?κ :: ?κs) _ =>
+ first [list_find_tac ltac:(fun i el =>
+ match el with
+ | κ ⊑ₗ{?c} ?κs' =>
+ notypeclasses refine (tac_llctx_release_toks_cons i c κs' L κ κs _ _ _ _ _);
+ [ simpl; reflexivity
+ | simpl; reflexivity
+ | solve_llctx_release_toks ]
+ | _ => fail
+ end) L
+ | notypeclasses refine (tac_llctx_release_toks_cons_skips κ κs _ _ _);
+ solve_llctx_release_toks ]
+ end.
+
+
+(** llctx_find_llft *)
+Section llctx_lft_split.
+ Lemma tac_llctx_find_llft_solve_step_skip L L' κ κ' κs κs' oc key :
+ llctx_find_llft L κ' key κs' L' →
+ llctx_find_llft ((oc, κ, κs) :: L) κ' key κs' ((oc, κ, κs) :: L').
+ Proof.
+ intros (A & B & ? & -> & -> & ?).
+ eexists ((oc, κ, κs) :: A), B, _. done.
+ Qed.
+
+ Lemma tac_llctx_find_llft_solve_step_find L κ κs κs' key oc :
+ llctx_find_lft_key_interp key κ oc →
+ κs' = κs →
+ llctx_find_llft ((oc, κ, κs) :: L) κ key κs' L.
+ Proof.
+ intros ? ->.
+ eexists [], L, _. split; first done. done.
+ Qed.
+End llctx_lft_split.
+
+Ltac solve_llctx_find_llft ::=
+ repeat match goal with
+ | |- llctx_find_llft ((?oc, ?κ, ?κs) :: ?L) ?κ ?key ?κs' ?L' =>
+ (notypeclasses refine (tac_llctx_find_llft_solve_step_find L κ κs κs' key oc _ _);
+ [first [done | eexists _; done] | done]) || fail 1000 "llctx_find_llft_solver: cannot find lifetime " κ " because there are still " oc " open tokens"
+ | |- llctx_find_llft ((?oc, ?κ, ?κs) :: ?L) ?κ' ?key ?κs' ?L' =>
+ refine (tac_llctx_find_llft_solve_step_skip L _ κ κ' κs κs' oc key _)
+ end.
+
+
+(** solve_map_lookup *)
+(* this extends the Lithium solver with support for goals where the lookup is None *)
+Ltac compute_map_lookup :=
+ unfold_opaque @named_lft_delete;
+ unfold_opaque @named_lft_update;
+ lazymatch goal with
+ | |- ?Q !! _ = Some _ => try (is_var Q; unfold Q)
+ | |- ?Q !! _ = ?e => idtac
+ | _ => fail "unknown goal for compute_map_lookup"
+ end; (solve
+ [ repeat
+ lazymatch goal with
+ | |- <[?x:=?s]> ?Q !! ?y = ?res =>
+ lazymatch x with
+ | y => change_no_check (Some s = res); reflexivity
+ | _ => change_no_check (Q !! y = res)
+ end
+ | |- ∅ !! _ = ?res =>
+ change_no_check (None = res); reflexivity
+ end ]).
+Ltac solve_compute_map_lookup ::=
+ compute_map_lookup.
+Ltac solve_compute_map_lookup_nofail ::=
+ compute_map_lookup.
+
+Lemma compute_map_lookups_cons_tac (M : gmap string lft) (ns : list string) (n : string) (κs κs' : list lft) κ :
+ M !! n = Some κ →
+ Forall2 (λ x y, M !! x = Some y) ns κs' →
+ κs = κ :: κs' →
+ Forall2 (λ x y, M !! x = Some y) (n :: ns) κs.
+Proof.
+ intros Hlook Hall ->.
+ econstructor; done.
+Qed.
+
+Ltac compute_map_lookups :=
+ lazymatch goal with
+ | |- Forall2 _ [] ?out =>
+ unify out (@nil lft); by apply (Forall2_nil)
+ | |- Forall2 _ (?x :: ?xs) ?out =>
+ refine (compute_map_lookups_cons_tac _ xs x _ _ _ _ _ _);
+ [ compute_map_lookup | compute_map_lookups | reflexivity]
+ end.
+Ltac solve_compute_map_lookups_nofail ::=
+ compute_map_lookups.
+
+
+(** solve_simplify_map *)
+
+Section simplify_gmap.
+ Context `{!typeGS Σ}.
+
+ Lemma simplify_gmap_tac `{Countable K} {V} (M M' E : gmap K V) :
+ map_to_list M' = map_to_list M →
+ M' = E →
+ M = E.
+ Proof.
+ intros Heq <-.
+ eapply map_to_list_inj. rewrite Heq. done.
+ Qed.
+
+ Lemma simplify_lft_map_tac `{Countable K} {V} (M M' E : gmap K V) :
+ E = M' →
+ opaque_eq M E.
+ Proof.
+ Local Transparent opaque_eq.
+ rewrite /opaque_eq. done.
+ Qed.
+End simplify_gmap.
+
+(* keeps the invariant that the term contains no deletes *)
+Ltac simplify_gmap M :=
+ lazymatch M with
+ (* push down deletes *)
+ | delete ?x (<[?y := ?s]> ?Q) =>
+ lazymatch x with
+ | y =>
+ simplify_gmap constr:(Q)
+ | _ =>
+ let M' := simplify_gmap constr:(delete x Q) in
+ uconstr:(<[y := s]> M')
+ end
+ (* skip over inserts without deletes *)
+ | <[?y := ?s]> ?Q =>
+ let M' := simplify_gmap constr:(Q) in
+ uconstr:(<[y := s]> M')
+ (* remove a delete from an empty map *)
+ | delete _ ∅ =>
+ uconstr:(∅)
+ | _ =>
+ constr:(M)
+ end.
+Ltac solve_simplify_gmap ::=
+ match goal with
+ | |- ?Q = ?e => try (is_var Q; unfold Q); is_evar e
+ | |- ?e = ?Q => try (is_var Q; unfold Q); is_evar e; symmetry
+ | _ => fail "unknown goal for simplify_gmap"
+ end;
+ lazymatch goal with
+ | |- ?Q = ?e =>
+ let Q' := simplify_gmap constr:(Q) in
+ (* NOTE: this relies on the simplification being order-preserving *)
+ refine (simplify_gmap_tac Q Q' e _ _);
+ [abstract (vm_compute; reflexivity) | reflexivity ]
+ end.
+
+Ltac simplify_lft_map M :=
+ lazymatch M with
+ (* push down deletes *)
+ | named_lft_delete ?x (named_lft_update ?y ?s ?Q) =>
+ lazymatch x with
+ | y =>
+ simplify_lft_map constr:(Q)
+ | _ =>
+ let M' := simplify_lft_map constr:(named_lft_delete x Q) in
+ uconstr:(named_lft_update y s M')
+ end
+ (* skip over inserts without deletes *)
+ | named_lft_update ?y ?s ?Q =>
+ let M' := simplify_lft_map constr:(Q) in
+ uconstr:(named_lft_update y s M')
+ (* remove a delete from an empty map *)
+ | named_lft_delete _ ∅ =>
+ uconstr:(∅)
+ | _ =>
+ constr:(M)
+ end.
+Ltac solve_simplify_lft_map ::=
+ match goal with
+ | |- opaque_eq ?Q ?e => try (is_var Q; unfold Q); is_evar e
+ | |- opaque_eq ?e ?Q => try (is_var Q; unfold Q); is_evar e; change_no_check (opaque_eq Q e)
+ (*symmetry*)
+ | _ => fail "unknown goal for simplify_lft_map"
+ end;
+ lazymatch goal with
+ | |- opaque_eq ?Q ?e =>
+ let Q' := simplify_lft_map constr:(Q) in
+ refine (simplify_lft_map_tac Q Q' e _);
+ [reflexivity ]
+ end.
+
+(** ** Layout sidecondition solver *)
+Section solve_layout_alg_tac.
+ Context `{!LayoutAlg}.
+
+ Lemma use_layout_alg'_layout_tac st ly :
+ syn_type_has_layout st ly → use_layout_alg' st = ly.
+ Proof.
+ rewrite /syn_type_has_layout /use_layout_alg'.
+ move => -> //.
+ Qed.
+
+ Lemma syn_type_is_layoutable_layout_tac st ly :
+ syn_type_has_layout st ly →
+ syn_type_is_layoutable st.
+ Proof. intros. eexists. done. Qed.
+
+ Lemma use_layout_alg_layout_tac st ly :
+ syn_type_has_layout st ly → use_layout_alg st = Some ly.
+ Proof. done. Qed.
+
+ Local Definition syn_type_has_layout_multi_pred : (var_name * syn_type) → (var_name * layout) → Prop :=
+ λ '(field_name, field_spec) res,
+ ∃ field_name2 field_ly,
+ use_layout_alg field_spec = Some field_ly ∧ field_name = field_name2 ∧ res = (field_name2, field_ly).
+
+ (* structs *)
+ Lemma syn_type_has_layout_struct_tac name fields fields' ly ly' :
+ Forall2 syn_type_has_layout_multi_pred fields fields' →
+ struct_layout_alg name fields' = Some ly' →
+ ly = layout_of ly' →
+ syn_type_has_layout (StructSynType name fields) ly.
+ Proof.
+ intros Ha Hb ->.
+ eapply syn_type_has_layout_struct; last done.
+ eapply Forall2_impl; first apply Ha.
+ intros [] [] (? & ? & ? & -> & [= -> ->]). eauto.
+ Qed.
+ Lemma struct_layout_spec_has_layout_tac (sls : struct_layout_spec) fields' (sl sl' : struct_layout) :
+ Forall2 syn_type_has_layout_multi_pred sls.(sls_fields) fields' →
+ struct_layout_alg sls.(sls_name) fields' = Some sl' →
+ sl = sl' →
+ struct_layout_spec_has_layout sls sl.
+ Proof.
+ intros Ha Hb ->.
+ eapply use_struct_layout_alg_Some; last done.
+ eapply Forall2_impl; first apply Ha.
+ intros [] [] (? & ? & ? & -> & [= -> ->]). eauto.
+ Qed.
+ Lemma use_struct_layout_alg_layout_tac (sls : struct_layout_spec) (sl : struct_layout) :
+ struct_layout_spec_has_layout sls sl → use_struct_layout_alg sls = Some sl.
+ Proof. done. Qed.
+
+ (* enums *)
+ Lemma syn_type_has_layout_enum_tac name variants variants' (it : IntType) ly ul sl :
+ Forall2 syn_type_has_layout_multi_pred variants variants' →
+ union_layout_alg name variants' = Some ul →
+ struct_layout_alg name [("discriminant", it_layout it); ("data", ul : layout)] = Some sl →
+ ly = layout_of sl →
+ syn_type_has_layout (EnumSynType name it variants) ly.
+ Proof.
+ intros Ha Hb Hc ->.
+ eapply syn_type_has_layout_enum; [ | done..].
+ eapply Forall2_impl; first apply Ha.
+ intros [] [] (? & ? & ? & -> & [= -> ->]). eauto.
+ Qed.
+ Lemma enum_layout_spec_has_layout_tac (els : enum_layout_spec) variants' (ul : union_layout) (sl sl' : struct_layout) :
+ Forall2 syn_type_has_layout_multi_pred els.(els_variants) variants' →
+ union_layout_alg els.(els_name) variants' = Some ul →
+ struct_layout_alg els.(els_name) [("discriminant", it_layout els.(els_tag_it)); ("data", ul : layout)] = Some sl' →
+ sl = sl' →
+ enum_layout_spec_has_layout els sl.
+ Proof.
+ intros Ha Hb Hc ->.
+ eapply use_enum_layout_alg_Some; [ | done..].
+ eapply Forall2_impl; first apply Ha.
+ intros [] [] (? & ? & ? & -> & [= -> ->]). eauto.
+ Qed.
+ Lemma use_enum_layout_alg_layout_tac (els : enum_layout_spec) (el : struct_layout) :
+ enum_layout_spec_has_layout els el → use_enum_layout_alg els = Some el.
+ Proof. done. Qed.
+
+ (* unions *)
+ Lemma syn_type_has_layout_union_tac name variants variants' ly ul :
+ Forall2 syn_type_has_layout_multi_pred variants variants' →
+ union_layout_alg name variants' = Some ul →
+ ly = ul_layout ul →
+ syn_type_has_layout (UnionSynType name variants) ly.
+ Proof.
+ intros Ha Hb ->.
+ eapply syn_type_has_layout_union; [ | done..].
+ eapply Forall2_impl; first apply Ha.
+ intros [] [] (? & ? & ? & -> & [= -> ->]). eauto.
+ Qed.
+ Lemma union_layout_spec_has_layout_tac (uls : union_layout_spec) variants' (ul ul' : union_layout) :
+ Forall2 syn_type_has_layout_multi_pred uls.(uls_variants) variants' →
+ union_layout_alg uls.(uls_name) variants' = Some ul' →
+ ul = ul' →
+ union_layout_spec_has_layout uls ul.
+ Proof.
+ intros Ha Hb ->.
+ eapply use_union_layout_alg_Some; [ | done..].
+ eapply Forall2_impl; first apply Ha.
+ intros [] [] (? & ? & ? & -> & [= -> ->]). eauto.
+ Qed.
+ Lemma use_union_layout_alg_layout_tac (uls : union_layout_spec) (ul : union_layout) :
+ union_layout_spec_has_layout uls ul → use_union_layout_alg uls = Some ul.
+ Proof. done. Qed.
+
+ Lemma syn_type_has_layout_untyped_alg_tac st ly ly' :
+ ly = ly' →
+ syn_type_has_layout st ly →
+ syn_type_has_layout (UntypedSynType (use_layout_alg' st)) ly'.
+ Proof.
+ intros <- Hst. eapply (syn_type_has_layout_make_untyped st).
+ - rewrite /use_layout_alg' Hst //.
+ - rewrite /use_layout_alg' Hst//.
+ Qed.
+ Lemma syn_type_has_layout_untyped_struct_alg_tac sls sl ly' :
+ ly' = sl →
+ struct_layout_spec_has_layout sls sl →
+ syn_type_has_layout (UntypedSynType (use_struct_layout_alg' sls)) ly'.
+ Proof.
+ intros -> Hst. eapply (syn_type_has_layout_make_untyped sls).
+ - rewrite /use_struct_layout_alg' Hst //.
+ - rewrite /use_struct_layout_alg' Hst.
+ by apply use_struct_layout_alg_Some_inv.
+ Qed.
+End solve_layout_alg_tac.
+
+Section simplify_layout_tac.
+ Context `{!LayoutAlg}.
+
+ Lemma simplify_use_layout_alg' T_st T_ly :
+ use_layout_alg T_st = Some T_ly →
+ use_layout_alg' T_st = T_ly.
+ Proof.
+ rewrite /use_layout_alg' => -> //.
+ Qed.
+
+ Lemma simplify_use_struct_layout_alg' sls sl :
+ use_struct_layout_alg sls = Some sl →
+ use_struct_layout_alg' sls = sl.
+ Proof.
+ rewrite /use_struct_layout_alg' => -> //.
+ Qed.
+
+ Lemma simplify_use_enum_layout_alg' els el :
+ use_enum_layout_alg els = Some el →
+ use_enum_layout_alg' els = el.
+ Proof.
+ rewrite /use_enum_layout_alg' => -> //.
+ Qed.
+
+ Lemma simplify_use_union_layout_alg' uls ul :
+ use_union_layout_alg uls = Some ul →
+ use_union_layout_alg' uls = ul.
+ Proof.
+ rewrite /use_union_layout_alg' => -> //.
+ Qed.
+End simplify_layout_tac.
+
+(** Solve goals of the forms
+ - [use_layout_alg st = Some ?ly]
+ - [use_layout_alg' st = ?ly]
+ - [syn_type_has_layout st ?ly]
+ where [ly] may or may not be an evar.
+ *)
+(* Declaration, definition is below. *)
+Ltac solve_layout_alg := idtac.
+
+(* We assume a let-binding [H_ly] has been introduced into the context in which we can rewrite *)
+Ltac simplify_layout' H_ly :=
+ repeat match type of H_ly with
+ | _ = use_layout_alg' ?st =>
+ erewrite (simplify_use_layout_alg' st) in H_ly;
+ [ | solve_layout_alg]
+ | _ = use_struct_layout_alg' ?sls =>
+ erewrite (simplify_use_struct_layout_alg' sls) in H_ly;
+ [ | solve_layout_alg]
+ | _ = use_enum_layout_alg' ?els =>
+ erewrite (simplify_use_enum_layout_alg' els) in H_ly;
+ [ | solve_layout_alg]
+ | _ = use_union_layout_alg' ?uls =>
+ erewrite (simplify_use_union_layout_alg' uls) in H_ly;
+ [ | solve_layout_alg]
+ | _ => idtac
+ end.
+(** Simplify a layout [ly] in the goal. *)
+Ltac simplify_layout_go ly :=
+ let Hly := fresh in
+ let ly_term := fresh in
+ remember ly as ly_term eqn:Hly;
+ simplify_layout' Hly;
+ subst ly_term.
+Ltac simplify_layout ly :=
+ match ly with
+ | ?ly => is_var ly
+ | layout_of (?sl) => is_var sl
+ | ul_layout ?ul => is_var ul
+ | it_layout ?it => idtac
+ | _ => simplify_layout_go ly
+ end.
+
+Ltac maybe_simplify_layout ly :=
+ match ly with
+ | use_layout_alg' _ => simplify_layout_go ly
+ | use_struct_layout_alg' _ => simplify_layout_go ly
+ | use_enum_layout_alg' _ => simplify_layout_go ly
+ | use_union_layout_alg' _ => simplify_layout_go ly
+ end.
+Ltac simplify_layout_goal :=
+ repeat match goal with
+ | |- context[?ly] =>
+ match type of ly with
+ | layout => maybe_simplify_layout ly
+ end
+ end.
+Ltac simplify_layout_assum :=
+ repeat match goal with
+ | H: context[?ly] |- _ =>
+ match type of ly with
+ | layout => maybe_simplify_layout ly
+ end
+ end.
+
+(** Solve goals of the form [layout_wf ly]. *)
+Section layout.
+ Lemma layout_wf_unit :
+ layout_wf unit_sl.
+ Proof.
+ rewrite /layout_wf/ly_align/ly_size/=.
+ apply Z.divide_0_r.
+ Qed.
+ Lemma layout_wf_ptr :
+ layout_wf void*.
+ Proof.
+ rewrite /layout_wf/ly_align/ly_size/=.
+ rewrite /bytes_per_addr/bytes_per_addr_log/=.
+ done.
+ Qed.
+ Lemma layout_wf_bool :
+ layout_wf bool_layout.
+ Proof.
+ rewrite /layout_wf/ly_align/ly_size/=.
+ done.
+ Qed.
+End layout.
+Ltac solve_layout_wf :=
+ unfold_no_enrich;
+ match goal with
+ | |- layout_wf ?ly =>
+ simplify_layout ly
+ end;
+ match goal with
+ | |- layout_wf ?ly =>
+ is_var ly;
+ refine (use_layout_alg_wf _ _ _);
+ [solve_layout_alg]
+ | |- layout_wf (it_layout ?it) =>
+ refine (int_type_layout_wf it)
+ | |- layout_wf (mk_array_layout _ _) =>
+ refine (array_layout_wf _ _ _);
+ solve_layout_wf
+ | |- layout_wf (layout_of unit_sl) =>
+ notypeclasses refine layout_wf_unit
+ | |- layout_wf void* =>
+ notypeclasses refine layout_wf_ptr
+ | |- layout_wf bool_layout =>
+ notypeclasses refine layout_wf_bool
+ | |- _ =>
+ (* TODO *)
+ try done
+ end.
+
+Ltac solve_ly_align_ib :=
+ unfold_no_enrich;
+ match goal with
+ | |- ly_align_in_bounds ?ly =>
+ simplify_layout ly
+ end;
+ match goal with
+ | |- ly_align_in_bounds ?ly =>
+ is_var ly;
+ refine (use_layout_alg_align _ _ _);
+ [solve_layout_alg]
+ | |- _ => idtac
+ end;
+ first [eassumption | done | shelve].
+
+(** Solve equalities and inequalities involving [ly_size]. *)
+Ltac solve_layout_size :=
+ unfold_no_enrich;
+ (* unfold [size_of_st] in the context *)
+ repeat match goal with
+ | H : context[size_of_st ?st] |- _ =>
+ rewrite /size_of_st in H;
+ simplify_layout (use_layout_alg' st)
+ end;
+ (* unfold [size_of_st] in the goal *)
+ rewrite /size_of_st;
+ (* simplify layouts by abstracting them into variables *)
+ repeat match goal with
+ | |- context[ly_size ?ly] =>
+ assert_fails (is_var ly);
+ let Hly := fresh in
+ let ly_term := fresh in
+ remember ly as ly_term eqn:Hly;
+ simplify_layout' Hly
+ end;
+ (* substitute the equalities again as lia can't deal with that *)
+ subst;
+ (* simplify simple layout sizes *)
+ simpl;
+ (* enrich the context *)
+ (*
+ repeat match goal with
+ | H : use_layout_alg ?st = Some ?ly |- _ =>
+ specialize (use_layout_alg_size _ _ H) as ?;
+ apply dont_enrich in H
+ end;
+ *)
+ (* call into lia *)
+ try lia.
+
+Global Arguments ly_size : simpl nomatch.
+
+(** Solve goals of the form [Forall2 syn_type_has_layout_multi_pred xs ?fields], by instantiating [?fields]. *)
+(* Definition below. *)
+Ltac solve_layout_alg_forall :=
+ idtac.
+
+(** Solve goals of the form [ly1 = ly2]. *)
+Ltac solve_layout_eq :=
+ unfold_no_enrich;
+ (* simplify both sides *)
+ match goal with
+ | |- ?ly1 = ?ly2 =>
+ simplify_layout ly1;
+ simplify_layout ly2
+ end;
+ (* TODO *)
+ try reflexivity.
+
+Global Arguments enum_layout_spec_is_layoutable : simpl never.
+Global Arguments struct_layout_spec_is_layoutable : simpl never.
+Global Arguments union_layout_spec_is_layoutable : simpl never.
+
+Ltac solve_layout_alg ::=
+ unfold_no_enrich;
+ (* normalize goal *)
+ lazymatch goal with
+ | |- syn_type_is_layoutable ?st => refine (syn_type_is_layoutable_layout_tac st _ _)
+ | |- use_layout_alg ?st = Some ?ly => refine (use_layout_alg_layout_tac st ly _)
+ | |- use_layout_alg' ?st = ?ly => refine (use_layout_alg'_layout_tac st ly)
+ | |- syn_type_has_layout ?st ?ly => idtac
+ (* structs *)
+ | |- use_struct_layout_alg ?sls = ?Some ?sl => refine (use_struct_layout_alg_layout_tac _ _ _)
+ | |- struct_layout_spec_has_layout ?sls ?sl => idtac
+ | |- struct_layout_spec_is_layoutable ?sls => eexists; refine (use_struct_layout_alg_layout_tac _ _ _)
+ (* enums *)
+ | |- use_enum_layout_alg ?els = ?Some ?el => refine (use_enum_layout_alg_layout_tac _ _ _)
+ | |- enum_layout_spec_has_layout ?els ?el => idtac
+ | |- enum_layout_spec_is_layoutable ?els => eexists; refine (use_enum_layout_alg_layout_tac _ _ _)
+ (* unions *)
+ | |- use_union_layout_alg ?uls = ?Some ?ul => refine (use_union_layout_alg_layout_tac _ _ _)
+ | |- union_layout_spec_has_layout ?uls ?ul => idtac
+ | |- union_layout_spec_is_layoutable ?uls => eexists; refine (use_union_layout_alg_layout_tac _ _ _)
+ end;
+ try match goal with
+ | |- syn_type_has_layout ?st ?ly =>
+ match st with
+ | ty_syn_type ?T => is_var T
+ | _ =>
+ let st_eval := eval hnf in st in
+ change_no_check st with st_eval
+ end;
+ simplify_layout ly
+ end;
+ try eassumption;
+ (* match on st *)
+ lazymatch goal with
+ | |- syn_type_has_layout (IntSynType ?it) ?ly =>
+ refine (syn_type_has_layout_int _ _ _ _);
+ [ solve_layout_eq | done ]
+ | |- syn_type_has_layout BoolSynType ?ly =>
+ refine (syn_type_has_layout_bool _ _);
+ [solve_layout_eq ]
+ | |- syn_type_has_layout PtrSynType ?ly =>
+ refine (syn_type_has_layout_ptr _ _);
+ [solve_layout_eq ]
+ | |- syn_type_has_layout FnPtrSynType ?ly =>
+ refine (syn_type_has_layout_fnptr _ _);
+ [solve_layout_eq ]
+ | |- syn_type_has_layout (StructSynType ?name ?fields) ?ly =>
+ refine (syn_type_has_layout_struct_tac name fields _ _ _ _ _ _);
+ [solve_layout_alg_forall | eassumption | solve_layout_eq]
+ | |- struct_layout_spec_has_layout ?sls ?sl =>
+ refine (struct_layout_spec_has_layout_tac sls _ sl _ _ _ _);
+ [solve_layout_alg_forall | eassumption | solve_layout_eq]
+ | |- syn_type_has_layout UnitSynType ?ly =>
+ refine (syn_type_has_layout_unit _ _);
+ [solve_layout_eq ]
+ | |- syn_type_has_layout (ArraySynType ?st ?len) ?ly =>
+ refine (syn_type_has_layout_array st len _ ly _ _ _);
+ [ solve_layout_eq | solve_layout_alg | solve_layout_size ]
+ | |- syn_type_has_layout (UnsafeCell ?st) ?ly =>
+ refine (syn_type_has_layout_unsafecell st ly _);
+ [solve_layout_alg ]
+ | |- syn_type_has_layout (UntypedSynType ?ly) ?ly' =>
+ match ly with
+ | use_layout_alg' ?st' =>
+ refine (syn_type_has_layout_untyped_alg_tac st' _ ly' _ _);
+ [solve_layout_eq | solve_layout_alg]
+ | use_struct_layout_alg' ?sls' =>
+ refine (syn_type_has_layout_untyped_struct_alg_tac sls' _ ly' _ _);
+ [solve_layout_eq | solve_layout_alg]
+ | _ =>
+ refine (syn_type_has_layout_untyped ly ly' _ _ _ _);
+ [solve_layout_eq | solve_layout_wf | solve_layout_size | solve_ly_align_ib ]
+ end
+ | |- syn_type_has_layout (EnumSynType ?name ?it ?variants) ?ly =>
+ refine (syn_type_has_layout_enum_tac name variants _ it _ _ _ _ _ _ _);
+ [solve_layout_alg_forall | eassumption | eassumption | solve_layout_eq]
+ | |- enum_layout_spec_has_layout ?els ?el =>
+ refine (enum_layout_spec_has_layout_tac els _ _ _ _ _ _ _ _);
+ [solve_layout_alg_forall | eassumption | eassumption | solve_layout_eq]
+ | |- syn_type_has_layout (UnionSynType ?name ?variants) ?ly =>
+ refine (syn_type_has_layout_union_tac name variants _ _ _ _ _ _);
+ [solve_layout_alg_forall | eassumption | solve_layout_eq]
+ | |- union_layout_spec_has_layout ?uls ?ul =>
+ refine (union_layout_spec_has_layout_tac uls _ _ _ _ _ _);
+ [solve_layout_alg_forall | eassumption | solve_layout_eq]
+ end.
+
+Ltac solve_layout_alg_forall ::=
+ unfold_no_enrich;
+ simpl;
+ match goal with
+ | |- Forall2 syn_type_has_layout_multi_pred [] ?fields' =>
+ econstructor
+ | |- Forall2 syn_type_has_layout_multi_pred (?f :: ?fields) ?fields' =>
+ econstructor;
+ [ eexists _, _; split_and!; [ solve_layout_alg | reflexivity | reflexivity]
+ | solve_layout_alg_forall]
+ end.
+
+Ltac solve_compute_layout ::=
+ unfold_no_enrich;
+ first [eassumption | progress solve_layout_alg; shelve].
+
+Ltac solve_compute_struct_layout ::=
+ unfold_no_enrich;
+ first [eassumption | progress solve_layout_alg; shelve].
+
+(** syn_type_compat solver *)
+Section syntype_compat.
+ Context `{!LayoutAlg}.
+ Lemma syn_type_compat_refl st :
+ syn_type_compat st st.
+ Proof. left. done. Qed.
+
+ Lemma syn_type_compat_untyped_r st ly ly' :
+ syn_type_has_layout st ly' →
+ ly = ly' →
+ syn_type_compat st (UntypedSynType ly).
+ Proof. intros ? ->. right. eauto. Qed.
+End syntype_compat.
+Global Arguments syn_type_compat : simpl never.
+
+Ltac solve_syn_type_compat :=
+ unfold_no_enrich;
+ match goal with
+ | |- syn_type_compat ?st ?st =>
+ refine (syn_type_compat_refl _)
+ | |- syn_type_compat ?st1 (UntypedSynType ?ly2) =>
+ refine (syn_type_compat_untyped_r _ _ _ _ _);
+ [solve_layout_alg | solve_layout_eq ]
+ end.
+
+
+(** ** Op-alg solver *)
+
+Section opalg.
+ Context `{!typeGS Σ}.
+
+ Lemma use_op_alg'_ot_tac st ot :
+ use_op_alg st = Some ot → use_op_alg' st = ot.
+ Proof. rewrite /use_op_alg' => -> //. Qed.
+
+ (* Use for tyvars *)
+ Lemma use_op_alg_tyvar_tac st ot :
+ syn_type_is_layoutable st →
+ ot = use_op_alg' st →
+ use_op_alg st = Some ot.
+ Proof.
+ intros (ly & Hly%syn_type_has_layout_op_alg) ->.
+ destruct Hly as (ot & Hot & <-).
+ rewrite /use_op_alg' Hot //.
+ Qed.
+
+ Lemma simplify_use_op_alg' T_st T_ly :
+ use_op_alg T_st = Some T_ly →
+ use_op_alg' T_st = T_ly.
+ Proof.
+ rewrite /use_op_alg' => -> //.
+ Qed.
+End opalg.
+
+Ltac solve_op_alg := idtac.
+
+(* We assume a let-binding [H_ly] has been introduced into the context in which we can rewrite *)
+Ltac simplify_optype' H_ly :=
+ repeat match type of H_ly with
+ | _ = use_op_alg' ?st =>
+ erewrite (simplify_use_op_alg' st) in H_ly;
+ [ | solve_op_alg]
+ | _ => idtac
+ end.
+(** Simplify a layout [ly] in the goal. *)
+Ltac simplify_optype_go ly :=
+ let Hly := fresh in
+ let ly_term := fresh in
+ remember ly as ly_term eqn:Hly;
+ simplify_optype' Hly;
+ subst ly_term.
+Ltac simplify_optype ly :=
+ match ly with
+ | ?ly => is_var ly
+ | _ => simplify_optype_go ly
+ end.
+
+(** Solve goals of the form [ot1 = ot2]. *)
+Ltac solve_ot_eq :=
+ (* TODO? *)
+ try reflexivity.
+
+(** Solve goals of the form [Forall2 _ xs ?fields], by instantiating [?fields]. *)
+(* Definition below. *)
+Ltac solve_op_alg_forall :=
+ idtac.
+
+Ltac solve_op_alg ::=
+ (* normalize goal *)
+ lazymatch goal with
+ | |- use_op_alg ?st = Some ?ot => idtac
+ | |- use_op_alg' ?st = ?ot => refine (use_op_alg'_ot_tac st ot _)
+ end;
+ try match goal with
+ | |- use_op_alg ?st = Some ?op =>
+ match st with
+ | ty_syn_type _ => idtac
+ | _ =>
+ let st_eval := eval hnf in st in
+ change_no_check st with st_eval
+ end
+ (*simplify_optype op*)
+ end;
+ try eassumption;
+ (* match on st *)
+ lazymatch goal with
+ | |- use_op_alg ?st = Some (use_op_alg' ?st) =>
+ refine (use_op_alg_tyvar_tac st _ _ _);
+ [solve_layout_alg | reflexivity]
+ | |- use_op_alg (IntSynType ?it) = Some ?ot =>
+ refine (use_op_alg_int _ _ _);
+ [ solve_ot_eq ]
+ | |- use_op_alg BoolSynType = Some ?ot =>
+ refine (use_op_alg_bool _ _);
+ [solve_ot_eq ]
+ | |- use_op_alg PtrSynType = Some ?ot =>
+ refine (use_op_alg_ptr _ _);
+ [solve_ot_eq ]
+ | |- use_op_alg FnPtrSynType = Some ?ot =>
+ refine (use_op_alg_fnptr _ _);
+ [solve_ot_eq ]
+ | |- use_op_alg (StructSynType ?name ?fields) = Some ?ot =>
+ refine (use_op_alg_struct name fields _ _ _ _ _ _);
+ [solve_op_alg_forall | solve_layout_alg | solve_ot_eq ]
+ | |- use_op_alg UnitSynType = Some ?ot =>
+ refine (use_op_alg_unit _ _);
+ [solve_ot_eq ]
+ | |- use_op_alg (ArraySynType ?st ?len) = Some ?ot =>
+ fail 1000 "implement solve_op_alg for ArraySynType"
+ | |- use_op_alg (UnsafeCell ?st) = Some ?ot =>
+ refine (use_op_alg_unsafecell st _ _);
+ [solve_op_alg ]
+ | |- use_op_alg (UntypedSynType ?ly) = Some ?ot =>
+ simplify_layout ly;
+ refine (use_op_alg_untyped _ ot _);
+ [solve_ot_eq ]
+ | |- use_op_alg (EnumSynType ?name ?it ?fields) = Some ?ot =>
+ refine (use_op_alg_enum _ _ _ _ _ _ _);
+ [solve_layout_alg | solve_ot_eq]
+ | |- use_op_alg (UnionSynType ?name ?fields) = Some ?ot =>
+ refine (use_op_alg_union _ _ _ _ _ _);
+ [solve_layout_alg | solve_ot_eq]
+ | |- use_op_alg (ty_syn_type _) = Some ?ot =>
+ refine (use_op_alg_tyvar_tac (ty_syn_type _) ot _ _);
+ [solve_layout_alg | solve_ot_eq]
+ | |- use_op_alg ?st = Some ?ot =>
+ is_var st;
+ refine (use_op_alg_tyvar_tac st ot _ _);
+ [solve_layout_alg | solve_ot_eq]
+ end.
+
+Ltac solve_op_alg_forall ::=
+ simpl;
+ match goal with
+ | |- Forall2 use_op_alg_struct_pred [] ?fields' =>
+ econstructor
+ | |- Forall2 use_op_alg_struct_pred (?f :: ?fields) ?fields' =>
+ econstructor;
+ [ simpl; solve_op_alg
+ | solve_op_alg_forall]
+ end.
+
+
+(** ** Solver for goals of the form [ty_has_op_type] *)
+Section tac.
+ Context `{!typeGS Σ}.
+
+ Lemma ty_has_op_type_simplify_tac {rt} (ty : type rt) ot ot2 mt :
+ ot = ot2 →
+ ty_has_op_type ty ot2 mt →
+ ty_has_op_type ty ot mt.
+ Proof. intros ->; done. Qed.
+End tac.
+
+Ltac simplify_ot :=
+ match goal with
+ | |- (use_op_alg' ?st) = ?ot =>
+ solve_op_alg
+ | |- ?ot = use_op_alg' ?st =>
+ symmetry; solve_op_alg
+ | |- _ => reflexivity
+ end.
+(*
+Ltac solve_ty_has_op_type :=
+ lazymatch goal with
+ | |- ty_has_op_type ?ty ?ot ?mc =>
+ refine (ty_has_op_type_simplify_tac ty ot _ mc _ _);
+ [simplify_ot | ];
+ first [
+ assert_fails (is_var ty);
+ rewrite /ty_has_op_type/=
+ | idtac];
+ repeat (first [progress (split_and!; simpl; first [done | sidecond_hook]) | li_shelve_sidecond])
+ end.
+ *)
+(*
+Ltac solve_ty_has_op_type :=
+ lazymatch goal with
+ | |- ty_has_op_type ?ty ?ot ?mc =>
+ refine (ty_has_op_type_simplify_tac ty ot _ mc _ _);
+ [simplify_ot | ];
+ (* specific handling for a few cases *)
+ match goal with
+ | |- is_value_ot ?st (use_op_alg' ?st) ?mc =>
+ refine (is_value_ot_use_op_alg _ _ _ _ _); [done | solve_layout_alg]
+ | |- is_array_ot _ _ _ _ => rewrite /is_array_ot; eexists _
+ | |- is_value_ot _ _ _ => rewrite /is_value_ot; eexists _
+ | |- _ =>
+ (* otherwise unfold *)
+ first [ assert_fails (is_var ty); rewrite /ty_has_op_type/= | idtac]
+ end;
+ repeat (first [progress (split_and!; simpl; first [done | sidecond_hook]) | shelve])
+ end.
+ *)
+Arguments is_value_ot : simpl never.
+Arguments is_array_ot : simpl never.
+Arguments is_struct_ot : simpl never.
+Ltac solve_ty_has_op_type :=
+ lazymatch goal with
+ | |- ty_has_op_type ?ty ?ot ?mc =>
+ refine (ty_has_op_type_simplify_tac ty ot _ mc _ _);
+ [simplify_ot | ];
+ (*first [ assert_fails (is_var ty); rewrite /ty_has_op_type/= | idtac];*)
+ first [ assert_fails (is_var ty); rewrite /ty_has_op_type/= | idtac];
+ (* specific handling for a few cases *)
+ match goal with
+ | |- is_value_ot ?st (use_op_alg' ?st) ?mc =>
+ refine (is_value_ot_use_op_alg _ _ _ _ _); [done | solve_layout_alg]
+ | |- is_value_ot _ _ _ => rewrite /is_value_ot; eexists _
+ | |- _ =>
+ (*otherwise unfold *)
+ hnf
+ end;
+ repeat (
+ first [
+ match goal with
+ | |- ∃ _, _ => eexists
+ end
+ | progress (split_and!; simpl; first [done | progress sidecond_hook | idtac])
+ | shelve
+ ])
+
+ (*repeat match goal with*)
+ (*| |- ∃ _, _ => eexists*)
+ (*end;*)
+ (*repeat (first [progress (split_and!; simpl; first [done | progress sidecond_hook | idtac]) | shelve])*)
+
+ (*repeat (first [progress (split_and!; simpl; first [done | sidecond_hook]) | shelve])*)
+ end.
+
+(** ** [bor_kind] solvers *)
+Section bor_kind_outlives.
+ Context `{!typeGS Σ}.
+
+ Lemma lctx_bor_kind_outlives_owned E L wl κ :
+ lctx_bor_kind_outlives E L (Owned wl) κ.
+ Proof.
+ iIntros (?) "HL HE". done.
+ Qed.
+
+ Lemma lctx_bor_kind_outlives_uniq E L κ γ κ' :
+ lctx_lft_incl E L κ' κ →
+ lctx_bor_kind_outlives E L (Uniq κ γ) κ'.
+ Proof.
+ iIntros (Hincl ?) "HL HE".
+ iPoseProof (Hincl with "HL") as "#Ha".
+ by iApply "Ha".
+ Qed.
+
+ Lemma lctx_bor_kind_outlives_shared E L κ κ' :
+ lctx_lft_incl E L κ' κ →
+ lctx_bor_kind_outlives E L (Shared κ) κ'.
+ Proof.
+ iIntros (Hincl ?) "HL HE".
+ iPoseProof (Hincl with "HL") as "#Ha".
+ by iApply "Ha".
+ Qed.
+End bor_kind_outlives.
+
+Ltac solve_bor_kind_outlives :=
+ lazymatch goal with
+ | |- lctx_bor_kind_outlives ?E ?L (Owned _) ?κ =>
+ refine (lctx_bor_kind_outlives_owned E L _ _)
+ | |- lctx_bor_kind_outlives ?E ?L (Uniq _ _) _ =>
+ refine (lctx_bor_kind_outlives_uniq E L _ _ _ _); solve_lft_incl
+ | |- lctx_bor_kind_outlives ?E ?L (Shared _) _ =>
+ refine (lctx_bor_kind_outlives_shared _ _ _ _ _); solve_lft_incl
+ end.
+
+
+(** ** Augment the context with commonly needed facts. *)
+
+
+Ltac augment_context :=
+ specialize (max_int_isize_lt_usize) as ?;
+ specialize (max_int_ge_127 i8) as ?;
+ specialize (max_int_ge_127 u8) as ?;
+ specialize (max_int_ge_127 i16) as ?;
+ specialize (max_int_ge_127 u16) as ?;
+ specialize (max_int_ge_127 i32) as ?;
+ specialize (max_int_ge_127 u32) as ?;
+ specialize (max_int_ge_127 i64) as ?;
+ specialize (max_int_ge_127 u64) as ?;
+ specialize (max_int_ge_127 i128) as ?;
+ specialize (max_int_ge_127 u128) as ?;
+ specialize (max_int_ge_127 isize_t) as ?;
+ specialize (max_int_ge_127 usize_t) as ?;
+ specialize (min_int_le_n128_signed i8 eq_refl) as ?;
+ specialize (min_int_le_n128_signed i16 eq_refl) as ?;
+ specialize (min_int_le_n128_signed i32 eq_refl) as ?;
+ specialize (min_int_le_n128_signed i64 eq_refl) as ?;
+ specialize (min_int_le_n128_signed i128 eq_refl) as ?;
+ specialize (min_int_le_n128_signed isize_t eq_refl) as ?;
+ specialize (min_int_unsigned_0 u8 eq_refl) as ?;
+ specialize (min_int_unsigned_0 u16 eq_refl) as ?;
+ specialize (min_int_unsigned_0 u32 eq_refl) as ?;
+ specialize (min_int_unsigned_0 u64 eq_refl) as ?;
+ specialize (min_int_unsigned_0 u128 eq_refl) as ?;
+ specialize (min_int_unsigned_0 usize_t eq_refl) as ?
+ (*specialize (layout_wf_unit) as ?;*)
+ (*specialize (layout_wf_ptr) as ?*)
+.
+
+
+(** * Tactics for inverting layout assumptions *)
+Global Arguments use_layout_alg : simpl never.
+(*
+Ltac simplify_struct_layout_alg H :=
+ repeat match type of H with
+ | _ => progress simplify_eq/=
+ | _ => progress simpl_option by eauto
+ | use_layout_alg (StructSynType _ _) = Some _ =>
+ unfold use_layout_alg in H; simpl in H
+ | mbind (M:=option) ?f ?mx = ?my =>
+ match mx with Some _ => fail 1 | None => fail 1 | _ => idtac end;
+ match my with Some _ => idtac | None => idtac | _ => fail 1 end;
+ let Heq := fresh "_sl_eq" in
+ let x := fresh "sl" in destruct mx as [x|] eqn:Heq;
+ [change (f x = my) in H|change (None = my) in H];
+ simplify_struct_layout_alg Heq
+ end.
+*)
+
+Ltac simplify_layout_alg := fail "impl simplify_layout_alg".
+Ltac inv_multi_fields_rec Hrec :=
+ simpl in Hrec;
+ match type of Hrec with
+ | Forall2 _ (?x :: ?L1) (?L2) =>
+ let Harg := fresh in
+ let Hrec2 := fresh "Hrec" in
+ apply Forall2_cons_inv_l in Hrec as ([] & ? & [? Harg] & Hrec2 & ?);
+ inv_multi_fields_rec Hrec2;
+ simplify_layout_alg Harg
+ | Forall2 _ [] _ =>
+ apply Forall2_nil_inv_l in Hrec as ->
+ end.
+Ltac inv_multi_fields Hrec :=
+ simpl in Hrec; inv_multi_fields_rec Hrec.
+
+
+From iris.proofmode Require Import string_ident.
+Tactic Notation "rename_layouts" "in" hyp(H) "with" tactic(cont) :=
+ match type of H with
+ | struct_layout_alg ?name ?fields = Some ?sl =>
+ let sl_name := eval cbv in (append name "_sl") in
+ let fields_name := eval cbv in (append name "_fields") in
+ let H_name := eval cbv in (append name "_salg") in
+ string_to_ident_cps sl_name ltac:(fun sl_n =>
+ string_to_ident_cps fields_name ltac:(fun fields_n =>
+ string_to_ident_cps H_name ltac:(fun H_n =>
+ rename sl into sl_n;
+ apply struct_layout_alg_has_fields in H as fields_n;
+ rename H into H_n;
+ cont H_n)))
+ | union_layout_alg ?name ?variants = Some ?ul =>
+ let ul_name := eval cbv in (append name "_ul") in
+ let variants_name := eval cbv in (append name "_variants") in
+ let H_name := eval cbv in (append name "_ualg") in
+ string_to_ident_cps ul_name ltac:(fun ul_n =>
+ string_to_ident_cps variants_name ltac:(fun variants_n =>
+ string_to_ident_cps H_name ltac:(fun H_n =>
+ rename ul into ul_n;
+ apply union_layout_alg_has_variants in H as variants_n;
+ rename H into H_n;
+ cont H_n)))
+ | use_layout_alg ?T = Some ?ly =>
+ is_var T; is_var ly;
+ let st_name := constr:(ident_to_string! T) in
+ let ly_name := eval cbv in (append st_name "_ly") in
+ let H_name := eval cbv in (append st_name "_alg") in
+ string_to_ident_cps ly_name ltac:(fun ly_n =>
+ string_to_ident_cps H_name ltac:(fun H_n =>
+ rename ly into ly_n;
+ rename H into H_n;
+ cont H_n))
+ end.
+Tactic Notation "rename_layouts" "in" hyp(H) :=
+ rename_layouts in H with (fun x => idtac).
+
+Ltac is_duplicate H :=
+ match type of H with
+ | use_layout_alg ?st = Some _ =>
+ match goal with
+ | H2 : NO_ENRICH (use_layout_alg st = Some _) |- _ =>
+ idtac
+ end
+ | struct_layout_alg ?name ?fields = Some _ =>
+ match goal with
+ | H2 : NO_ENRICH (struct_layout_alg name fields = Some _) |- _ =>
+ idtac
+ end
+ end.
+
+Section handle_duplicate.
+ Context `{!LayoutAlg}.
+
+ Lemma handle_duplicate_use_layout_alg_tac st ly0 ly1 :
+ use_layout_alg st = Some ly0 →
+ NO_ENRICH (use_layout_alg st = Some ly1) →
+ ly0 = ly1.
+ Proof.
+ rewrite /NO_ENRICH.
+ intros ??. by eapply syn_type_has_layout_inj.
+ Qed.
+
+ Lemma handle_duplicate_struct_layout_alg_tac name fields sl0 sl1 :
+ struct_layout_alg name fields = Some sl0 →
+ NO_ENRICH (struct_layout_alg name fields = Some sl1) →
+ sl0 = sl1.
+ Proof.
+ rewrite /NO_ENRICH.
+ intros ??. by simplify_eq.
+ Qed.
+
+ Lemma handle_duplicate_union_layout_alg_tac name variants ul0 ul1 :
+ union_layout_alg name variants = Some ul0 →
+ NO_ENRICH (union_layout_alg name variants = Some ul1) →
+ ul0 = ul1.
+ Proof.
+ rewrite /NO_ENRICH.
+ intros ??. by simplify_eq.
+ Qed.
+
+End handle_duplicate.
+
+
+Ltac postprocess_new_struct_assum H Halg :=
+ match type of Halg with
+ | struct_layout_alg ?name ?field_lys = Some _ =>
+ first [
+ (* if this is a duplicate, remove it *)
+ match goal with
+ | H2 : NO_ENRICH (struct_layout_alg name field_lys = Some _) |- _ =>
+ specialize (handle_duplicate_struct_layout_alg_tac _ _ _ _ Halg H2) as ?;
+ clear Halg
+ end
+ |
+ try specialize (use_layout_alg_wf _ _ H) as ?;
+ try specialize (use_layout_alg_size _ _ H) as ?;
+ try specialize (use_layout_alg_align _ _ H) as ?;
+ try specialize (use_struct_layout_alg_wf _ _ H) as ?;
+ try specialize (use_struct_layout_alg_size _ _ H) as ?;
+ try specialize (use_enum_layout_alg_wf _ _ H) as ?;
+ try specialize (use_enum_layout_alg_size _ _ H) as ?;
+ rename_layouts in Halg with (fun Halg => apply dont_enrich in Halg)
+ ]
+ end.
+Ltac postprocess_new_union_assum H Halg :=
+ match type of Halg with
+ | union_layout_alg ?name ?variant_lys = Some _ =>
+ first [
+ (* if this is a duplicate, remove it *)
+ match goal with
+ | H2 : NO_ENRICH (union_layout_alg name variant_lys = Some _) |- _ =>
+ specialize (handle_duplicate_union_layout_alg_tac _ _ _ _ Halg H2) as ?;
+ clear Halg
+ end
+ |
+ try specialize (use_layout_alg_wf _ _ H) as ?;
+ try specialize (use_layout_alg_size _ _ H) as ?;
+ try specialize (use_layout_alg_align _ _ H) as ?;
+ try specialize (use_union_layout_alg_wf _ _ H) as ?;
+ try specialize (use_union_layout_alg_size _ _ H) as ?;
+ rename_layouts in Halg with (fun Halg => apply dont_enrich in Halg)
+ ]
+ end.
+
+Ltac simplify_layout_alg H ::=
+ simpl in H;
+ try match type of H with
+ | syn_type_has_layout ?spec _ =>
+ rewrite /syn_type_has_layout in H
+ | struct_layout_spec_has_layout _ _ =>
+ rewrite /struct_layout_spec_has_layout in H
+ | union_layout_spec_has_layout _ _ =>
+ rewrite /union_layout_spec_has_layout in H
+ | enum_layout_spec_has_layout _ _ =>
+ rewrite /enum_layout_spec_has_layout in H
+ end;
+ try match type of H with
+ | use_layout_alg ?spec = Some _ =>
+ rewrite ?/syn_type_of_sls ?/syn_type_of_els ?/syn_type_of_uls in H
+ end;
+ try match type of H with
+ | use_layout_alg (ty_syn_type ?T) = Some _ =>
+ (* dont' want to hnf this *)
+ is_var T
+ | use_layout_alg ?spec = Some _ =>
+ let spec_eval := eval hnf in spec in
+ change_no_check spec with spec_eval in H
+ (*is_var spec; rewrite /spec in H*)
+ | use_struct_layout_alg ?spec = Some _ =>
+ let spec_eval := eval hnf in spec in
+ change_no_check spec with spec_eval in H
+ (*is_var spec; rewrite /spec in H*)
+ | use_union_layout_alg ?spec = Some _ =>
+ let spec_eval := eval hnf in spec in
+ change_no_check spec with spec_eval in H
+ | use_enum_layout_alg ?spec = Some _ =>
+ let spec_eval := eval hnf in spec in
+ change_no_check spec with spec_eval in H
+ end;
+ match type of H with
+ | use_layout_alg ?st = Some _ =>
+ (* don't do anything *)
+ is_var st;
+ first [
+ (* if this is a duplicate, remove it *)
+ match goal with
+ | H2 : NO_ENRICH (use_layout_alg st = Some _) |- _ =>
+ specialize (handle_duplicate_use_layout_alg_tac _ _ _ H H2) as ?;
+ clear H
+ end
+ | specialize (use_layout_alg_size _ _ H) as ?;
+ specialize (use_layout_alg_wf _ _ H) as ?;
+ specialize (use_layout_alg_align _ _ H) as ?;
+ (* stop exploiting this further to prevent divergence *)
+ rename_layouts in H with (fun H_n => apply dont_enrich in H_n)
+ ]
+ | use_struct_layout_alg ?sls = Some _ =>
+ (* don't do anything *)
+ is_var sls;
+ specialize (use_struct_layout_alg_size _ _ H) as ?;
+ specialize (use_struct_layout_alg_wf _ _ H) as ?;
+ (* stop exploiting this further to prevent divergence *)
+ rename_layouts in H with (fun H_n => apply dont_enrich in H_n)
+ | use_enum_layout_alg ?els = Some _ =>
+ (* don't do anything *)
+ is_var els;
+ specialize (use_enum_layout_alg_size _ _ H) as ?;
+ specialize (use_enum_layout_alg_wf _ _ H) as ?;
+ (* stop exploiting this further to prevent divergence *)
+ rename_layouts in H with (fun H_n => apply dont_enrich in H_n)
+ | use_layout_alg (IntSynType ?it) = Some _ =>
+ apply syn_type_has_layout_int_inv in H as (? & ?)
+ | use_layout_alg (BoolSynType) = Some _ =>
+ apply syn_type_has_layout_bool_inv in H
+ | use_layout_alg PtrSynType = Some _ =>
+ apply syn_type_has_layout_ptr_inv in H
+ | use_layout_alg FnPtrSynType = Some _ =>
+ apply syn_type_has_layout_fnptr_inv in H
+
+ | use_layout_alg (StructSynType _ ?fields) = Some _ =>
+ let Hrec := fresh "Hrec" in
+ let Halg := fresh "Halg" in
+ specialize (syn_type_has_layout_struct_inv _ _ _ H) as (? & ? & ? & Halg & Hrec);
+ simpl in Halg;
+ inv_multi_fields Hrec;
+ (* NOTE: this has a [try] in front because some of the [simplify_eq] in [inv_multi_fields] may already have taken the [Halg] away -- then this will fail and cause huge pain. *)
+ try postprocess_new_struct_assum H Halg;
+ clear H
+ | use_struct_layout_alg ?sls = Some _ =>
+ let Hrec := fresh "Hrec" in
+ let Halg := fresh "Halg" in
+ specialize (use_struct_layout_alg_inv _ _ H) as (? & Halg & Hrec);
+ simpl in Halg;
+ inv_multi_fields Hrec;
+ try postprocess_new_struct_assum H Halg;
+ clear H
+
+ | use_layout_alg UnitSynType = Some _ =>
+ apply syn_type_has_layout_unit_inv in H
+ | use_layout_alg (ArraySynType ?st ?len) = Some _ =>
+ let ly' := fresh "ly" in let H' := fresh "_ly_eq" in
+ apply syn_type_has_layout_array_inv in H as (ly' & H' & ? & ?);
+ simplify_layout_alg H'
+ | use_layout_alg (UnsafeCell ?st) = Some _ =>
+ apply syn_type_has_layout_unsafecell in H; simplify_layout_alg H
+ | use_layout_alg (UntypedSynType ?ly) = Some _ =>
+ apply syn_type_has_layout_untyped_inv in H as (? & ? & ? & ?)
+
+ | use_layout_alg (EnumSynType _ ?it ?variants) = Some _ =>
+ let Hrec := fresh "Hrec" in
+ let Halg_ul := fresh "Halg" in
+ let Halg_sl := fresh "Halg" in
+ specialize (syn_type_has_layout_enum_inv _ _ _ _ H) as (? & ? & ? & Halg_ul & Halg_sl & ? & Hrec);
+ simpl in Halg_ul, Halg_sl;
+ inv_multi_fields Hrec;
+ try postprocess_new_union_assum H Halg_ul;
+ try postprocess_new_struct_assum H Halg_sl;
+ clear H
+ | use_enum_layout_alg ?els = Some _ =>
+ let Hrec := fresh "Hrec" in
+ let Halg_ul := fresh "Halg" in
+ let Halg_sl := fresh "Halg" in
+ specialize (use_enum_layout_alg_inv _ _ H) as (? & ? & Halg_ul & Halg_sl & Hrec);
+ simpl in Halg_ul, Halg_sl;
+ inv_multi_fields Hrec;
+ try postprocess_new_union_assum H Halg_ul;
+ try postprocess_new_struct_assum H Halg_sl;
+ clear H
+
+ | use_layout_alg (UnionSynType _ ?variants) = Some _ =>
+ let Hrec := fresh "Hrec" in
+ let Halg_ul := fresh "Halg" in
+ specialize (syn_type_has_layout_union_inv _ _ _ H) as (? & ? & ? & Halg_ul & Hrec);
+ simpl in Halg_ul;
+ inv_multi_fields Hrec;
+ try postprocess_new_union_assum H Halg_ul;
+ clear H
+ | use_union_layout_alg ?uls = Some _ =>
+ let Hrec := fresh "Hrec" in
+ let Halg_ul := fresh "Halg" in
+ specialize (use_union_layout_alg_inv _ _ H) as (? & Halg_ul & Hrec);
+ simpl in Halg_ul;
+ inv_multi_fields Hrec;
+ try postprocess_new_union_assum H Halg_ul;
+ clear H
+ | use_layout_alg _ = Some _ =>
+ idtac
+ end;
+ simplify_eq.
+
+
+Ltac inv_layout_alg :=
+ repeat match goal with
+ | H : syn_type_has_layout _ _ |- _ =>
+ rewrite /syn_type_has_layout in H
+ | H : syn_type_is_layoutable _ |- _ =>
+ let st := fresh "_st" in
+ destruct H as [st H]
+ | H : use_layout_alg _ = Some _ |- _ =>
+ progress (simplify_layout_alg H)
+ (* struct *)
+ | H : struct_layout_spec_is_layoutable _ |- _ =>
+ let st := fresh "_st" in
+ destruct H as [st H]
+ | H : struct_layout_spec_has_layout _ _ |- _ =>
+ rewrite /struct_layout_spec_has_layout in H
+ | H : use_struct_layout_alg _ = Some _ |- _ =>
+ progress (simplify_layout_alg H)
+ (* enum *)
+ | H : enum_layout_spec_is_layoutable _ |- _ =>
+ let st := fresh "_st" in
+ destruct H as [st H]
+ | H : enum_layout_spec_has_layout _ _ |- _ =>
+ rewrite /enum_layout_spec_has_layout in H
+ | H : use_enum_layout_alg _ = Some _ |- _ =>
+ progress (simplify_layout_alg H)
+ (* union *)
+ | H : union_layout_spec_is_layoutable _ |- _ =>
+ let st := fresh "_st" in
+ destruct H as [st H]
+ | H : union_layout_spec_has_layout _ _ |- _ =>
+ rewrite /union_layout_spec_has_layout in H
+ | H : use_union_layout_alg _ = Some _ |- _ =>
+ progress (simplify_layout_alg H)
+ end.
+ (*unfold_no_enrich.*)
+Global Arguments syn_type_has_layout : simpl never.
+
diff --git a/theories/rust_typing/axioms.v b/theories/rust_typing/axioms.v
new file mode 100644
index 0000000000000000000000000000000000000000..ada4f9645d05b6885d3e6afa763b7a66b96579ec
--- /dev/null
+++ b/theories/rust_typing/axioms.v
@@ -0,0 +1,59 @@
+Require Import Coq.Logic.ProofIrrelevance.
+From Equations Require Import Equations.
+From stdpp Require Import base.
+From iris Require Import prelude.
+Require Import Coq.Logic.EqdepFacts.
+
+Lemma proof_irrelevance (P : Prop) (p1 p2 : P) : p1 = p2.
+Proof. apply proof_irrelevance. Qed.
+
+(* TODO: we currently require ProofIrrelevance only for getting the ltype induction principle.
+ We might be able to get by without it however and just require UIP. *)
+
+(* Equations seems to change the arguments for eq_refl, restore *)
+Global Arguments eq_refl {A}%type_scope {x}, [_] _.
+
+(* Uniqueness of identity proofs *)
+(*Axiom (UIP_t : ∀ T, UIP_ T).*)
+
+Lemma UIP_t T : UIP_ T.
+Proof.
+ intros a b -> Heq.
+ rewrite (proof_irrelevance _ Heq eq_refl).
+ done.
+Qed.
+
+Lemma UIP_refl : ∀ (X : Type) (x : X) (Heq : x = x), Heq = eq_refl x.
+Proof.
+ intros X x Heq. apply UIP_t.
+Qed.
+
+(* Instance for Equations to find. *)
+Global Instance UIP_inst X : UIP X.
+Proof. apply UIP_t. Qed.
+Global Set Equations With UIP.
+
+Import EqNotations.
+Lemma existT_inj {X P} (p : X) (x y : P p) :
+ existT p x = existT p y → x = y.
+Proof.
+ revert x y.
+ enough (∀ a b, a = b → ∀ Heq' : projT1 a = projT1 b, rew [P] Heq' in projT2 a = projT2 b) as H.
+ { intros x y Heq. by specialize (H _ _ Heq eq_refl). }
+ intros a b Heq. destruct Heq. intros Heq.
+ specialize (UIP_t _ _ _ Heq eq_refl) as ->. done.
+Qed.
+
+Section eq.
+ (* TODO move *)
+ Lemma rew_invert {X Y} {F : Type → Type} (Heq : X = Y) (z : F X):
+ rew <-[F] Heq in (rew [F] Heq in z) = z.
+ Proof.
+ destruct Heq. done.
+ Qed.
+ Lemma rew_invert' {X Y} {F : Type → Type} (Heq : Y = X) (z : F X):
+ rew [F] Heq in (rew <-[F] Heq in z) = z.
+ Proof.
+ destruct Heq. done.
+ Qed.
+End eq.
diff --git a/theories/rust_typing/base.v b/theories/rust_typing/base.v
new file mode 100644
index 0000000000000000000000000000000000000000..e0d17cd4fd9dec9fb817c0f7ee6cc171eb87bf74
--- /dev/null
+++ b/theories/rust_typing/base.v
@@ -0,0 +1,107 @@
+From lrust.lifetime Require Export lifetime.
+From lithium Require Export all.
+From caesium Require Export proofmode notation syntypes.
+From refinedrust Require Export axioms pinned_borrows.
+From iris.prelude Require Import options.
+
+Ltac iR := iSplitR; first done.
+Ltac iL := iSplitL; last done.
+
+Definition rrustN := nroot .@ "rrust".
+Definition shrN := rrustN .@ "shr".
+
+Definition lft_userN : namespace := nroot .@ "lft_usr".
+
+(* The "user mask" of the lifetime logic. This needs to be disjoint with ↑lftN.
+
+ If a client library desires to put invariants in lft_userE, then it is
+ encouraged to place it in the already defined lft_userN. On the other hand,
+ extensions to the model of RustBelt itself (such as gpfsl for
+ the weak-mem extension) can require extending [lft_userE] with the relevant
+ namespaces. In that case all client libraries need to be re-checked to
+ ensure disjointness of [lft_userE] with their masks is maintained where
+ necessary. *)
+Definition lft_userE : coPset := ↑lft_userN.
+
+Definition lftE : coPset := ↑lftN.
+Definition timeE : coPset := ↑timeN.
+
+Create HintDb refinedc_typing.
+
+Ltac solve_typing :=
+ (typeclasses eauto with refinedc_typing typeclass_instances core).
+
+Global Hint Constructors Forall Forall2 elem_of_list : refinedc_typing.
+Global Hint Resolve submseteq_cons submseteq_inserts_l submseteq_inserts_r
+ : refinedc_typing.
+
+(* done is there to handle equalities with constants *)
+Global Hint Extern 100 (_ ≤ _) => simpl; first [done|lia] : refinedc_typing.
+Global Hint Extern 100 (@eq Z _ _) => simpl; first [done|lia] : refinedc_typing.
+Global Hint Extern 100 (@eq nat _ _) => simpl; first [done|lia] : refinedc_typing.
+
+Class CoPsetFact (P : Prop) : Prop := copset_fact : P.
+(* clear for performance reasons as there can be many hypothesis and they should not be needed for the goals which occur *)
+Local Definition coPset_disjoint_empty_r := disjoint_empty_r (C:=coPset).
+Local Definition coPset_disjoint_empty_l := disjoint_empty_l (C:=coPset).
+Global Hint Extern 1 (CoPsetFact ?P) => (change P; clear; eauto using coPset_disjoint_empty_r, coPset_disjoint_empty_r with solve_ndisj) : typeclass_instances.
+
+
+Class LayoutSizeEq (ly1 ly2 : layout) := layout_size_eq_proof : ly_size ly1 = ly_size ly2.
+Global Instance layout_size_eq_refl ly : LayoutSizeEq ly ly.
+Proof. constructor. Qed.
+
+Class LayoutSizeLe (ly1 ly2 : layout) := layout_size_le_proof : ly_size ly1 ≤ ly_size ly2.
+Global Instance layout_size_le_refl ly : LayoutSizeLe ly ly.
+Proof. constructor. Qed.
+
+
+(** Block typeclass resolution for an argument *)
+Definition TCNoResolve (P : Type) := P.
+Global Typeclasses Opaque TCNoResolve.
+
+(** [TCForall] but for [Type] instead of [Prop] *)
+Inductive TCTForall {A} (P : A → Type) : list A → Type :=
+ | TCTForall_nil : TCTForall P []
+ | TCTForall_cons x xs : P x → TCTForall P xs → TCTForall P (x :: xs).
+Existing Class TCTForall.
+Global Existing Instance TCTForall_nil.
+Global Existing Instance TCTForall_cons.
+Global Hint Mode TCTForall ! ! ! : typeclass_instances.
+
+
+Declare Scope printing_sugar.
+
+(* Hints for unfolding type definitions used by some parts of the automation (e.g. [elctx_simplify]). *)
+Create HintDb tyunfold.
+
+(* Marker to prevent Lithium's machinery from simplifying a hypothesis. *)
+Definition introduce_direct {Σ} (P : iProp Σ) := P.
+Global Arguments introduce_direct : simpl never.
+Global Typeclasses Opaque introduce_direct.
+
+(* We override the lifetime logic's version with a direct fixpoint version for nicer unfolding + computation. *)
+Fixpoint lft_intersect_list (κs : list lft) : lft :=
+ match κs with
+ | [] => static
+ | κ :: κs => κ ⊓ lft_intersect_list κs
+ end.
+Lemma lft_intersect_list_iff κs :
+ lft_intersect_list κs = lifetime.lft_intersect_list κs.
+Proof.
+ induction κs as [ | κ κs IH]; simpl; first done.
+ destruct κs as [ | κ' κs]; simpl.
+ { rewrite right_id //. }
+ simpl in IH. rewrite IH //.
+Qed.
+
+Lemma lft_intersect_list_elem_of_incl_syn (κs : list lft) κ :
+ κ ∈ κs → lft_intersect_list κs ⊑ˢʸ⿠κ.
+Proof.
+ rewrite lft_intersect_list_iff. apply lft_intersect_list_elem_of_incl_syn.
+Qed.
+Lemma lft_intersect_list_elem_of_incl `{!invGS Σ} {userE : coPset} `{!lftGS Σ userE} (κs : list lft) κ :
+ κ ∈ κs → ⊢ lft_intersect_list κs ⊑ κ.
+Proof.
+ rewrite lft_intersect_list_iff. apply lft_intersect_list_elem_of_incl.
+Qed.
diff --git a/theories/rust_typing/box.v b/theories/rust_typing/box.v
new file mode 100644
index 0000000000000000000000000000000000000000..a0be26c8c20c346280bde13549c392c3ea2e22a6
--- /dev/null
+++ b/theories/rust_typing/box.v
@@ -0,0 +1,1055 @@
+From refinedrust Require Export base type.
+From refinedrust Require Import programs uninit ltypes ltype_rules.
+From caesium Require Import derived.
+
+(**
+ Boxes copy the refinement of their inner type.
+ They fully own their memory, and thus allow deallocation (in their drop implementation).
+ TODO: actually have drop impls for types.
+*)
+
+(* NOTE:
+ this is not an accurate model of Rust's box type.
+ (Rust's actual box is a struct with two fields: a Unique and an Allocator)
+ We can instead use this as a simplified model for now,
+ as long as we don't actually strive to verify Rust's actual Box implementation.
+ *)
+
+Section box.
+ Context `{typeGS Σ} {rt} `{Inhabited rt} (inner : type rt).
+
+ Program Definition box : type (place_rfn rt) := {|
+ ty_sidecond := True;
+ ty_own_val π r v :=
+ ∃ (l : loc) (ly : layout), ⌜v = l⌠∗ ⌜syn_type_has_layout inner.(ty_syn_type) ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ inner.(ty_sidecond) ∗
+ (* No later here over the freeable. I don't know how to make the unfolding equation work with one. *)
+ (freeable_nz l ly.(ly_size) 1 HeapAlloc) ∗
+ £ num_cred ∗ atime 1 ∗
+ ∃ (ri : rt), place_rfn_interp_owned r ri ∗
+ (* this needs to match up with the corresponding later/fupd in the OfTyLtype to get the unfolding equation *)
+ ▷ |={lftE}=> ∃ v' : val, l ↦ v' ∗ inner.(ty_own_val) π ri v';
+ ty_has_op_type ot mt := is_ptr_ot ot;
+ ty_syn_type := PtrSynType;
+
+ ty_shr κ tid r l :=
+ (∃ (li : loc) (ly : layout) (ri : rt), place_rfn_interp_shared r ri ∗
+ ⌜l `has_layout_loc` void*⌠∗
+ ⌜use_layout_alg inner.(ty_syn_type) = Some ly⌠∗
+ ⌜li `has_layout_loc` ly⌠∗
+ inner.(ty_sidecond) ∗
+ loc_in_bounds l 0 void*.(ly_size) ∗
+ (* also need this for the inner location to get the right unfolding equations *)
+ loc_in_bounds li 0 ly.(ly_size) ∗
+ &frac{κ}(λ q', l ↦{q'} li) ∗
+ (* later for contractiveness *)
+ ▷ □ |={lftE}=> inner.(ty_shr) κ tid ri li)%I;
+ ty_ghost_drop π r :=
+ ∃ ri, place_rfn_interp_owned r ri ∗ inner.(ty_ghost_drop) π ri;
+
+ ty_lfts := inner.(ty_lfts);
+ ty_wf_E := inner.(ty_wf_E);
+ |}%I.
+ Next Obligation.
+ iIntros (Ï€ v r) "(%l & %ly & -> & ? & ? & _)". eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (ot mt Hot). apply is_ptr_ot_layout in Hot as ->. done.
+ Qed.
+ Next Obligation.
+ iIntros (???) "(%l & %ly & -> & _)". done.
+ Qed.
+ Next Obligation.
+ iIntros (κ π l r) "(%li & %ly & %ri & Hr & ? & ? & ? & _)".
+ eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (E κ l ly π r q ?) "#(LFT & TIME & LLCTX) Htok %Halg %Hly #Hlb Hb".
+ rewrite -lft_tok_sep. iDestruct "Htok" as "(Htok & Htoki)".
+ iApply fupd_logical_step.
+ iMod (bor_exists with "LFT Hb") as (v) "Hb"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hl & Hb)"; first solve_ndisj.
+ iMod (bor_exists with "LFT Hb") as (l') "Hb"; first solve_ndisj.
+ iMod (bor_exists with "LFT Hb") as (ly') "Hb"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Heq & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Heq Htok") as "(>-> & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hst & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hst Htok") as "(>%Hst & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hly & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hly Htok") as "(>%Hly' & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hlb' & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hlb' Htok") as "(>#Hlb' & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hsc & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hsc Htok") as "(>Hsc & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hfree & Hb)"; first solve_ndisj.
+ rewrite bi.sep_assoc.
+ iMod (bor_sep with "LFT Hb") as "(Hcred & Hb)"; first solve_ndisj.
+ iMod (bor_exists_tok with "LFT Hb Htok") as "(%ri & Hb & Htok)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hrfn & Hb)"; first solve_ndisj.
+
+ (* get observation about refinement *)
+ iMod (place_rfn_interp_owned_share with "LFT Hrfn Htok") as "(Hrfn & Htok)"; first done.
+
+ (* use credits to remove the later + fupd from Hb *)
+ iDestruct "Htok" as "(Htok1 & Htok)".
+ iMod (bor_acc with "LFT Hcred Htok1") as "(>(Hcred & Hat) & Hcl_cred)"; first solve_ndisj.
+ iDestruct "Hcred" as "(Hcred1 & Hcred2 & Hcred)".
+ set (R := (∃ v' : val, l' ↦ v' ∗ v' â—áµ¥{ Ï€} ri @ inner)%I).
+ iPoseProof (bor_fupd_later_strong E lftE _ _ R True with "LFT [//] [Hcred1] [] Hb Htok") as "Hu"; [done | done | ..].
+ { iIntros "(_ & Ha)". iModIntro. iNext. iApply (lc_fupd_add_later with "Hcred1"); iNext.
+ iMod "Ha". by iFrame. }
+ { eauto with iFrame. }
+ iMod "Hu"as "Hu".
+ iApply (lc_fupd_add_later with "Hcred2"); iNext.
+ iMod "Hu" as "(Hb & Htok & _)".
+
+ iMod (bor_fracture (λ q, l ↦{q} l')%I with "LFT Hl") as "Hl"; first solve_ndisj.
+
+ (* recusively share *)
+ iDestruct "Htoki" as "(Htoki & Htoki2)".
+ iPoseProof (ty_share with "[$LFT $TIME $LLCTX] [Htok Htoki] [//] [//] Hlb' Hb") as "Hb"; first done.
+ { rewrite -lft_tok_sep. iFrame. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hb").
+
+ iApply (logical_step_intro_atime with "Hat").
+ iModIntro. iIntros "Hcred' Hat !> [#Hshr Htok]".
+ iMod ("Hcl_cred" with "[$Hcred' $Hat]") as "(? & Htok2)".
+ iCombine "Htok2 Htoki2" as "Htok2". rewrite !lft_tok_sep.
+ iCombine "Htok Htok2" as "$".
+ iModIntro.
+ iExists l', ly', ri. iFrame.
+ iSplitR. { inversion Halg; subst; done. }
+ iSplitR; first done. iSplitR; first done.
+ inversion Halg; subst ly. iFrame "#".
+ iNext. iModIntro. iModIntro. done.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (κ κ' π r l) "#Hincl (%li & %ly & %r' & Hrfn & ? & ? & ? & Hsc & Hlb & Hlbi & Hl & #Hshr)".
+ iExists li, ly, r'. iFrame. iSplitL "Hl".
+ { iApply (frac_bor_shorten with "Hincl Hl"). }
+ iNext. iDestruct "Hshr" as "#Hshr". iModIntro. iMod "Hshr". iModIntro.
+ by iApply (ty_shr_mono with "Hincl Hshr").
+ Qed.
+ Next Obligation.
+ simpl. iIntros (Ï€ r v??) "(%l & %ly & -> & Halg & Hly & Hlb & Hsc & Hf & Hcred & Hat & Hb)".
+ iDestruct "Hb" as "(%r' & Hr & Hv)".
+ iApply fupd_logical_step.
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iApply (lc_fupd_add_later with "Hcred1"); iNext.
+ iMod (fupd_mask_mono with "Hv") as "Hv"; first done.
+ iDestruct "Hv" as "(%v' & Hl & Hv)".
+ iPoseProof (ty_own_ghost_drop with "Hv") as "Hgdrop"; first done.
+ iApply (logical_step_compose with "Hgdrop").
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "!> Hcred' Hat !> Hgdrop".
+ eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (ot mt st π r ? Hot).
+ destruct mt.
+ - eauto.
+ - iIntros "(%l & %ly & -> & ?)".
+ iExists l, ly. iFrame.
+ iPoseProof (mem_cast_compat_loc (λ v, True)%I) as "%Hl"; first done.
+ + eauto.
+ + iPureIntro. by apply Hl.
+ - iApply (mem_cast_compat_loc (λ v, _)); first done.
+ iIntros "(%l & %ly & -> & _)". eauto.
+ Qed.
+End box.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ Lemma box_own_val_mono_in {rt1 rt2} π (ty1 : type rt1) (ty2 : type rt2) r1 r2 v :
+ type_incl r2 r1 ty2 ty1 -∗
+ v â—áµ¥{Ï€} #r2 @ box ty2 -∗
+ v â—áµ¥{Ï€} #r1 @ box ty1.
+ Proof.
+ iIntros "(%Hst_eq & #Hsc_eq & #Hincl & #Hincl_shr)".
+ iIntros "Hv".
+ iDestruct "Hv" as (l ly) "(-> & Halg & Hly & Hlb & Hsc & Hf & Hcred & Hat & Hb)".
+ iExists l. rewrite -Hst_eq. iExists ly. iSplitR; first done.
+ iFrame. iDestruct "Hb" as (ri) "(-> & Hb)".
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iExists _. iSplitR; first done.
+ iNext. iMod "Hb". iDestruct "Hb" as (v) "(Hl & Hv)". iExists v. iFrame. by iApply "Hincl".
+ Qed.
+ Lemma box_own_val_mono {rt} π (ty1 : type rt) (ty2 : type rt) r v :
+ (∀ r, type_incl r r ty2 ty1) -∗
+ v â—áµ¥{Ï€} r @ box ty2 -∗
+ v â—áµ¥{Ï€} r @ box ty1.
+ Proof.
+ iIntros "#Hincl".
+ iIntros "Hv".
+ iDestruct "Hv" as (l ly) "(-> & Halg & Hly & Hlb & Hsc & Hf & Hcred & Hat & Hb)".
+ iExists l. iDestruct "Hb" as (ri) "(Hrfn & Hb)".
+ iDestruct ("Hincl" $! ri) as "(%Hst_eq & #Hsc_eq & #Hinclv & #Hincl_shr)".
+ rewrite -Hst_eq. iExists ly. iSplitR; first done. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iExists _. iFrame.
+ iNext. iMod "Hb". iDestruct "Hb" as (v) "(Hl & Hv)". iExists v. iFrame. by iApply "Hinclv".
+ Qed.
+
+ Lemma box_shr_mono_in {rt1 rt2} π (ty1 : type rt1) (ty2 : type rt2) r1 r2 l κ :
+ type_incl r2 r1 ty2 ty1 -∗
+ l â—â‚—{Ï€, κ} #r2 @ box ty2 -∗
+ l â—â‚—{Ï€, κ} #r1 @ box ty1.
+ Proof.
+ iIntros "(%Hst_eq & #Hsc_eq & #Hincl & #Hincl_shr) Hl".
+ iDestruct "Hl" as (li ly ri) "(-> & ? & ? & ? & Hsc & Hlb & Hlb' & Hs & Hb)".
+ iExists li, ly, _. iSplitR; first done. iFrame. rewrite -Hst_eq. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iNext. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro. by iApply "Hincl_shr".
+ Qed.
+ Lemma box_shr_mono {rt} π (ty1 ty2 : type rt) r l κ :
+ (∀ r, type_incl r r ty2 ty1) -∗
+ l â—â‚—{Ï€, κ} r @ box ty2 -∗
+ l â—â‚—{Ï€, κ} r @ box ty1.
+ Proof.
+ iIntros "Hincl Hl".
+ iDestruct "Hl" as (li ly ri) "(Hrfn & ? & ? & ? & Hsc & Hlb & Hlb' & Hs & Hb)".
+ iDestruct ("Hincl" $! ri) as "(%Hst_eq & #Hsc_eq & #Hincl & #Hincl_shr)".
+ iExists li, ly, ri. iFrame. rewrite -Hst_eq. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iNext. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro. by iApply "Hincl_shr".
+ Qed.
+
+ Lemma box_type_incl_in {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 :
+ type_incl r2 r1 ty2 ty1 -∗
+ type_incl #r2 #r1 (box ty2) (box ty1).
+ Proof.
+ iIntros "#Hincl".
+ iSplitR; first done. iSplitR.
+ { iPureIntro. simpl. lia. }
+ iSplit; iIntros "!#".
+ - iIntros (??). by iApply box_own_val_mono_in.
+ - iIntros (???). by iApply box_shr_mono_in.
+ Qed.
+ Lemma box_type_incl {rt} (ty1 ty2 : type rt) r :
+ (∀ r, type_incl r r ty2 ty1) -∗
+ type_incl r r (box ty2) (box ty1).
+ Proof.
+ iIntros "#Hincl".
+ iSplitR; first done. iSplitR.
+ { iPureIntro. simpl. lia. }
+ iSplit; iIntros "!#".
+ - iIntros (??). by iApply box_own_val_mono.
+ - iIntros (???). by iApply box_shr_mono.
+ Qed.
+
+ Lemma box_subtype {rt1 rt2} E L (ty1 : type rt1) (ty2 : type rt2) r1 r2 :
+ subtype E L r1 r2 ty1 ty2 →
+ subtype E L #r1 #r2 (box ty1) (box ty2).
+ Proof.
+ iIntros (Hsubt ?) "HL HE".
+ iPoseProof (Hsubt with "HL HE") as "#Hsub".
+ iApply box_type_incl_in. by iApply "Hsub".
+ Qed.
+ Lemma box_full_subtype {rt} E L (ty1 ty2 : type rt) :
+ full_subtype E L ty1 ty2 →
+ full_subtype E L (box ty1) (box ty2).
+ Proof.
+ iIntros (Hsubt ??) "HL HE".
+ iApply box_type_incl. iIntros (?).
+ iApply (Hsubt with "HL HE").
+ Qed.
+End subtype.
+
+Section unfold.
+ Context `{typeGS Σ} {rt} (ty : type rt).
+
+ Lemma box_ltype_unfold_1_owned wl r :
+ ⊢ ltype_incl' (Owned wl) r r (BoxLtype (◠ty)) (◠(box (ty))).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_box_unfold /box_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & Hlb & Hcred & %r' & Hrfn & Hb)".
+ iModIntro. iExists ly. iFrame "∗".
+ iExists _. iFrame. iNext. iMod "Hb".
+ iDestruct "Hb" as (l' ly') "(Hl & % & % & Hf & Hb)".
+ iExists l'. iFrame.
+ iExists l', ly'. iSplitR; first done. iFrame "∗ %".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly'' & % & % & Hsc & Hlb' & [Hcred Hat] & Hb)".
+ enough (ly'' = ly') as ->. { iModIntro. iFrame. }
+ eapply syn_type_has_layout_inj; done.
+ Qed.
+ Lemma box_ltype_unfold_2_owned wl r :
+ ⊢ ltype_incl' (Owned wl) r r (◠(box (ty))) (BoxLtype (◠ty)).
+ Proof.
+ iModIntro. iIntros (Ï€ l).
+ rewrite ltype_own_box_unfold /box_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & Halg & Hly & Hsc & Hlb & Hcred & %r' & Hrfn & Hb)".
+ iModIntro. iExists ly. iFrame.
+ iExists r'. iFrame. iNext.
+ iDestruct "Hb" as ">(%v & Hl & %l' & %ly' & -> & %Halg & %Hly & Hlb & Hsc' & Hf & Hcred & Hat & Hb)".
+ iExists l', ly'. iFrame "∗ %".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. iModIntro. iExists ly'.
+ iDestruct "Hb" as "(%ri & Hrfn & Hb)". iFrame "% ∗".
+ eauto with iFrame.
+ Qed.
+
+ Lemma box_ltype_unfold_1_shared `{!Inhabited rt} κ r :
+ ⊢ ltype_incl' (Shared κ) r r (BoxLtype (◠ty)) (◠(box (ty))).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_box_unfold /box_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & %Ha & % & #Hlb & %ri & Hrfn & #Hb)".
+ iExists ly. iFrame. iFrame "Hlb %".
+ iExists _. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & Hs & Hb)".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & >? & >? & >Hsc & >Hlb' & %ri' & >Hrfn & Hb)".
+ iExists _, _, _. iFrame.
+ injection Ha as <-. iFrame "#". done.
+ Qed.
+ Lemma box_ltype_unfold_2_shared κ r :
+ ⊢ ltype_incl' (Shared κ) r r (◠(box (ty))) (BoxLtype (◠ty)).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_box_unfold /box_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & Hsc & ? & %r' & Hrfn & #Hb)". iExists ly. iFrame "∗ %".
+ iExists _. iFrame. iModIntro.
+ iMod "Hb". iDestruct "Hb" as "(%li & %ly' & %ri & Hrfn & ? & ? & ? & Hsc & Hlb & Hlbi & Hs & Hb)".
+ iModIntro. iExists li. iFrame. iNext. iDestruct "Hb" as "#Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. iExists ly'. iFrame.
+ iExists _. iFrame. done.
+ Qed.
+
+ Lemma box_ltype_unfold_1_uniq κ γ r :
+ ⊢ ltype_incl' (Uniq κ γ) r r (BoxLtype (◠ty)) (◠(box (ty))).
+ Proof.
+ iModIntro. iIntros (Ï€ l).
+ rewrite ltype_own_box_unfold /box_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & Halg & Hly & Hlb & Hcred & Hat & Hrfn & Hb)". iExists ly.
+ iFrame "∗". iMod "Hb". iModIntro.
+ setoid_rewrite ltype_own_core_equiv. simp_ltypes.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iMod "Hb".
+ iDestruct "Hb" as "(%l' & %ly' & Hl & %Halg & Hly & Hf & Hb)".
+ iExists l'. iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists l', ly'. iFrame "∗". iSplitR; first done.
+ iDestruct "Hb" as "(%ly'' & %Halg' & Hly & Hsc & Hlb & [Hcred Hat] & Hb)".
+ iModIntro. iFrame. iSplitR; first done.
+ simp_ltypes in Halg. replace ly'' with ly'; first done.
+ eapply syn_type_has_layout_inj; done.
+ * iIntros "(%r' & Hauth & Hb)".
+ iExists _. iFrame. iMod "Hb".
+ iDestruct "Hb" as "(%v & Hl & %l' & %ly' & -> & %Halg & %Hly & Hlb & Hsc & Hf & Hcred & Hat & Hb)".
+ iDestruct "Hb" as "(%ri & Hown & Hv)".
+ iModIntro. iExists l', ly'. iFrame.
+ iSplitR; first done. iSplitR; first done.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly'. iFrame. iSplitR; first done. iSplitR; first done.
+ iExists _. iFrame.
+ Qed.
+ Lemma box_ltype_unfold_2_uniq κ γ r :
+ ⊢ ltype_incl' (Uniq κ γ) r r (◠(box (ty))) (BoxLtype (◠ty)).
+ Proof.
+ iModIntro. iIntros (Ï€ l).
+ rewrite ltype_own_box_unfold /box_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & Halg & Hly & Hsc & Hlb & Hcred & Hat & Hrfn & Hb)".
+ iExists ly. iFrame. iMod "Hb". iModIntro.
+ (* same proof as above *)
+ setoid_rewrite ltype_own_core_equiv. simp_ltypes.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)".
+ iExists _. iFrame. iMod "Hb".
+ iDestruct "Hb" as "(%v & Hl & %l' & %ly' & -> & %Halg & %Hly & Hlb & Hsc & Hf & Hcred & Hat & Hb)".
+ iDestruct "Hb" as "(%ri & Hown & Hv)".
+ iModIntro. iExists l', ly'. iFrame.
+ iSplitR; first done. iSplitR; first done.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly'. iFrame. iSplitR; first done. iSplitR; first done.
+ iExists _. iFrame.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iMod "Hb".
+ iDestruct "Hb" as "(%l' & %ly' & Hl & %Halg & Hly & Hf & Hb)".
+ iExists l'. iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists l', ly'. iFrame "∗". iSplitR; first done.
+ iDestruct "Hb" as "(%ly'' & %Halg' & Hly & Hsc & Hlb & [Hcred Hat] & Hb)".
+ iModIntro. iFrame. iSplitR; first done.
+ simp_ltypes in Halg. replace ly'' with ly'; first done.
+ eapply syn_type_has_layout_inj; done.
+ Qed.
+
+ Local Lemma box_ltype_unfold_1' `{!Inhabited rt} b r :
+ ⊢ ltype_incl' b r r (BoxLtype (◠ty)) (◠(box (ty))).
+ Proof.
+ iModIntro. destruct b.
+ - iApply box_ltype_unfold_1_owned.
+ - iApply box_ltype_unfold_1_shared.
+ - iApply box_ltype_unfold_1_uniq.
+ Qed.
+ Local Lemma box_ltype_unfold_2' b r :
+ ⊢ ltype_incl' b r r (◠(box ty)) (BoxLtype (◠ty)).
+ Proof.
+ iModIntro. destruct b.
+ - iApply box_ltype_unfold_2_owned.
+ - iApply box_ltype_unfold_2_shared.
+ - iApply box_ltype_unfold_2_uniq.
+ Qed.
+ Lemma box_ltype_unfold_1 `{!Inhabited rt} b r :
+ ⊢ ltype_incl b r r (BoxLtype (◠ty)) (◠(box (ty))).
+ Proof.
+ iModIntro. iSplitR; first done.
+ simp_ltypes. iSplit; iApply box_ltype_unfold_1'.
+ Qed.
+ Lemma box_ltype_unfold_2 b r :
+ ⊢ ltype_incl b r r (◠(box (ty))) (BoxLtype (◠ty)).
+ Proof.
+ iModIntro. iSplitR; first done.
+ simp_ltypes. iSplit; iApply box_ltype_unfold_2'.
+ Qed.
+ Lemma box_ltype_unfold `{Inhabited rt} b r :
+ ⊢ ltype_eq b r r (BoxLtype (◠ty)) (◠(box (ty))).
+ Proof.
+ iSplit; [iApply box_ltype_unfold_1 | iApply box_ltype_unfold_2].
+ Qed.
+
+ Lemma box_ltype_unfold_full_eqltype `{!Inhabited rt} E L (lt : ltype rt) :
+ full_eqltype E L lt (◠ty)%I →
+ full_eqltype E L (BoxLtype lt) (â— (box ty))%I.
+ Proof.
+ intros Heq. etrans.
+ { eapply box_full_eqltype; done. }
+ iIntros (?) "HL #CTX #HE". iIntros (??).
+ iApply box_ltype_unfold.
+ Qed.
+End unfold.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ Lemma box_ltype_place_cond_ty b {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ typed_place_cond_ty b lt1 lt2 -∗
+ typed_place_cond_ty b (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ destruct b; simpl.
+ - iIntros "_". done.
+ - iIntros "(%Hrefl & Heq & Hub)". subst.
+ iExists eq_refl. cbn. iSplitR "Hub".
+ + iIntros (??). by iApply box_ltype_eq.
+ + by iApply box_ltype_imp_unblockable.
+ - iIntros "(%Hrefl & Heq & Hub)". subst.
+ iExists eq_refl. cbn.
+ iSplitL "Heq".
+ + simp_ltypes. iIntros (??). by iApply box_ltype_eq.
+ + by iApply box_ltype_imp_unblockable.
+ Qed.
+
+ Lemma box_ltype_acc_owned {rt} F π (lt : ltype rt) (r : place_rfn rt) wl l :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned wl] PlaceIn r @ BoxLtype lt -∗
+ ⌜l `has_layout_loc` void*⌠∗ loc_in_bounds l 0 (ly_size void*) ∗ |={F}=>
+ ∃ l' : loc, l ↦ l' ∗ l' â—â‚—[Ï€, Owned true] r @ lt ∗
+ logical_step F
+ (∀ bmin rt2 (lt2 : ltype rt2) (r2 : place_rfn rt2),
+ (* refinement type can only change where strong accesses are allowed *)
+ ⌜place_access_rt_rel bmin rt rt2⌠-∗
+ l ↦ l' -∗
+ l' â—â‚—[Ï€, Owned true] r2 @ lt2 -∗
+ typed_place_cond bmin lt lt2 r r2 ={F}=∗
+ l â—â‚—[Ï€, Owned wl] PlaceIn r2 @ BoxLtype lt2 ∗
+ typed_place_cond bmin (BoxLtype lt) (BoxLtype lt2) (PlaceIn r) (PlaceIn r2)).
+ Proof.
+ iIntros (?) "Hb". rewrite ltype_own_box_unfold /box_ltype_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hlb & Hcred & %r' & <- & Hb)".
+ injection Halg as <-. iFrame "#%".
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iDestruct "Hb" as "(%l' & %ly' & Hl & %Halg & %Hly' & Hf & Hb)".
+ iModIntro. iExists l'. iFrame.
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred' !>". iIntros (bmin rt2 lt2 r2) "%Hrel Hl Hb #Hcond". iModIntro.
+ iSplitL "Hf Hl Hb Hcred'".
+ { rewrite ltype_own_box_unfold /box_ltype_own. iExists void*. iFrame "# ∗".
+ iSplitR; first done. iSplitR; first done.
+ iExists r2. iSplitR; first done. iNext.
+ iExists l', ly'. iFrame. iPoseProof (typed_place_cond_syn_type_eq with "Hcond") as "<-".
+ iFrame "%#". done. }
+ iDestruct "Hcond" as "(Hcondt & Hcondr)".
+ iSplit.
+ + iApply box_ltype_place_cond_ty; done.
+ + destruct bmin; simpl; [done | | done].
+ iDestruct "Hcondr" as "(%Heq1 & <-)". subst rt2.
+ iExists eq_refl. done.
+ Qed.
+
+
+ Lemma box_ltype_acc_uniq {rt} F π (lt : ltype rt) (r : place_rfn rt) l q κ γ R :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ (q.[κ] ={lftE}=∗ R) -∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn r @ BoxLtype lt -∗
+ ⌜l `has_layout_loc` void*⌠∗ loc_in_bounds l 0 (ly_size void*) ∗ |={F}=>
+ ∃ l' : loc, l ↦ l' ∗ l' â—â‚—[Ï€, Owned true] r @ lt ∗
+ logical_step F
+ ((* weak *)(∀ bmin (lt2 : ltype rt) r2,
+ l ↦ l' -∗
+ l' â—â‚—[Ï€, Owned true] r2 @ lt2 -∗
+ bmin ⊑ₖ Uniq κ γ -∗
+ typed_place_cond bmin lt lt2 r r2 ={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn r2 @ BoxLtype lt2 ∗
+ R ∗
+ typed_place_cond bmin (BoxLtype lt) (BoxLtype lt2) (PlaceIn r) (PlaceIn r2)) ∧
+ ((* strong *)∀ rt2 (lt2 : ltype rt2) r2,
+ l ↦ l' -∗
+ ⌜ltype_st lt2 = ltype_st lt⌠-∗
+ l' â—â‚—[Ï€, Owned true] r2 @ lt2 ={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn r2 @ OpenedLtype (BoxLtype lt2) (BoxLtype lt) (BoxLtype lt)
+ (λ r1 r1', ⌜r1 = r1'âŒ) (λ _ _, R)))
+ .
+ Proof.
+ iIntros (?) "#(LFT & TIME & LLCTX) Hκ HR Hb". rewrite ltype_own_box_unfold /box_ltype_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hlb & Hcred & Hat & Hrfn & Hb)".
+ injection Halg as <-. iFrame "#%".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod "Hb".
+ (* NOTE: we are currently throwing away the existing "coring"-viewshift that we get *)
+ iMod (pinned_bor_acc_strong lftE with "LFT Hb Hκ") as "(%κ' & #Hincl & Hb & _ & Hb_cl)"; first done.
+ iMod "Hcl_F" as "_".
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iApply (lc_fupd_add_later with "Hcred1"). iNext.
+ iDestruct "Hb" as "(%r' & Hauth & Hb)".
+ iPoseProof (gvar_agree with "Hauth Hrfn") as "#->".
+ iMod (fupd_mask_mono with "Hb") as "(%l' & %ly' & Hl & %Hst & %Hly' & Hf & Hb)"; first done.
+ iModIntro. iExists l'. iFrame.
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "Hcred' Hat".
+ iModIntro.
+ iSplit.
+ - (* close *)
+ iIntros (bmin lt2 r2) "Hl Hb #Hincl_k #Hcond".
+ (* extract the necessary info from the place_cond *)
+ iPoseProof (typed_place_cond_incl _ (Uniq κ γ) with "Hincl_k Hcond") as "Hcond'".
+ iDestruct "Hcond'" as "(Hcond' & _)".
+ iDestruct "Hcond'" as "(%Heq & Heq & (_ & #Hub))".
+ rewrite (UIP_refl _ _ Heq). cbn.
+ iPoseProof (typed_place_cond_syn_type_eq with "Hcond") as "%Hst_eq".
+ (* close the borrow *)
+ iMod (gvar_update r2 with "Hauth Hrfn") as "(Hauth & Hrfn)".
+ set (V := (∃ r', gvar_auth γ r' ∗ (|={lftE}=> ∃ (l' : loc) ly', l ↦ l' ∗ ⌜syn_type_has_layout (ltype_st lt2) ly'⌠∗ ⌜l' `has_layout_loc` ly'⌠∗ freeable_nz l' (ly_size ly') 1 HeapAlloc ∗ ltype_own lt2 (Owned true) π r' l'))%I).
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iMod ("Hb_cl" $! V with "[] Hcred1 [Hauth Hf Hl Hb]") as "(Hb & Htok)".
+ { iNext. iIntros "(%r' & Hauth & Hb) Hdead".
+ iModIntro. iNext. iExists r'. iFrame "Hauth".
+ clear. iMod "Hb" as "(%l' & %ly' & Hl & ? & ? & ? & Ha)".
+ iMod (lft_incl_dead with "Hincl Hdead") as "Hdead"; first done.
+ (* unblock *)
+ iMod ("Hub" with "[$Hdead //] Ha") as "Ha".
+ (* use that the cores are equal *)
+ iDestruct ("Heq" $! (Owned true) _) as "(_ & (%Hst & #Hi & _))".
+ rewrite ltype_own_core_equiv. iMod ("Hi" with "Ha") as "Ha".
+ rewrite -ltype_own_core_equiv. move: Hst. rewrite !ltype_core_syn_type_eq.
+ intros ->. eauto with iFrame. }
+ { iModIntro. rewrite /V. rewrite -Hst_eq. eauto 8 with iFrame. }
+ iMod ("HR" with "Htok") as "$".
+ iMod "Hcl_F" as "_".
+ iModIntro.
+ (* TODO maybe donate the leftover credits *)
+ iSplitL.
+ { rewrite ltype_own_box_unfold /box_ltype_own.
+ iExists void*. iFrame.
+ iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ iPoseProof (pinned_bor_shorten with "Hincl Hb") as "Hb".
+ iModIntro. subst V.
+ (* need to adapt the pinned part, too *)
+ iApply (pinned_bor_iff with "[] [] Hb").
+ { iNext. iModIntro. eauto. }
+ clear -Hst_eq.
+ iNext. iModIntro. iSplit.
+ - iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame.
+ iMod "Hb" as "(%l' & %ly' & Hl & Halg & Hly & Hf & Hb)".
+ iDestruct ("Heq" $! (Owned true) _) as "((_ & #Heq1 & _) & (_ & #Heq2 & _))".
+ rewrite ltype_own_core_equiv. iMod ("Heq1" with "Hb") as "Hb". rewrite -ltype_own_core_equiv.
+ rewrite Hst_eq. eauto with iFrame.
+ - iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame.
+ iMod "Hb" as "(%l' & %ly' & Hl & Halg & Hly & Hf & Hb)".
+ iDestruct ("Heq" $! (Owned true) _) as "((_ & #Heq1 & _) & (_ & #Heq2 & _))".
+ rewrite ltype_own_core_equiv. iMod ("Heq2" with "Hb") as "Hb". rewrite -ltype_own_core_equiv.
+ rewrite Hst_eq. eauto with iFrame.
+ }
+ iDestruct "Hcond" as "(Hcond_ty & Hcond_rfn)".
+ iSplit.
+ + iApply box_ltype_place_cond_ty; done.
+ + iApply typed_place_cond_rfn_lift. done.
+ - (* shift to OpenedLtype *)
+ iIntros (rt2 lt2 r2) "Hl %Hst' Hb". iModIntro.
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iApply (opened_ltype_create_uniq_simple with "Hrfn Hauth Hcred1 Hat Hincl HR Hb_cl [] [Hcred']"); first done.
+ { iModIntro. iIntros (?) "Hauth Hc". simp_ltypes.
+ rewrite ltype_own_box_unfold /box_ltype_own.
+ iExists _. iFrame. iDestruct "Hc" as ">(% & _ & _ & _ & _ & %r' & -> & >(%l0 & % & Hl & %Halg & % & Hf & Hb))".
+ iModIntro. setoid_rewrite ltype_own_core_equiv.
+ iExists _, _. move: Halg. rewrite ltype_core_syn_type_eq => ?.
+ eauto with iFrame. }
+ { iIntros (?) "Hobs Hat Hcred Hp". simp_ltypes.
+ rewrite ltype_own_box_unfold /box_ltype_own.
+ setoid_rewrite ltype_own_core_equiv. rewrite ltype_core_idemp.
+ rewrite ltype_core_syn_type_eq. iModIntro. eauto 8 with iFrame. }
+ { rewrite ltype_own_box_unfold /box_ltype_own.
+ iExists void*. do 4 iR.
+ iExists r2. iR. iNext. iModIntro. rewrite Hst'. eauto with iFrame. }
+ Qed.
+
+ Lemma box_ltype_acc_shared {rt} F π (lt : ltype rt) (r : place_rfn rt) l q κ :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ l â—â‚—[Ï€, Shared κ] PlaceIn r @ BoxLtype lt -∗
+ ⌜l `has_layout_loc` void*⌠∗ loc_in_bounds l 0 (ly_size void*) ∗ |={F}=>
+ ∃ (l' : loc) q, l ↦{q} l' ∗ (|={F}â–·=> l' â—â‚—[Ï€, Shared κ] r @ lt) ∗
+ (∀ bmin,
+ l ↦{q} l' -∗
+ l' â—â‚—[Ï€, Shared κ] r @ lt -∗
+ bmin ⊑ₖ Shared κ -∗
+ typed_place_cond bmin lt lt r r ={F}=∗
+ l â—â‚—[Ï€, Shared κ] PlaceIn r @ BoxLtype lt ∗
+ q.[κ] ∗
+ typed_place_cond bmin (BoxLtype lt) (BoxLtype lt) (PlaceIn r) (PlaceIn r)).
+ Proof.
+ iIntros (?) "#CTX Hκ Hb". rewrite {1}ltype_own_box_unfold /box_ltype_own.
+ (* TODO *)
+ Abort.
+
+ (** Place access *)
+ (* Needs to have lower priority than the id instance *)
+ Lemma place_ofty_box {rt} `{Inhabited rt} π E L l (ty : type rt) (r : place_rfn (place_rfn rt)) bmin0 b P T :
+ typed_place π E L l (BoxLtype (◠ty)) r bmin0 b P T
+ ⊢ typed_place π E L l (◠(box ty)) r bmin0 b P T.
+ Proof.
+ iIntros "Hp". iApply typed_place_eqltype; last done.
+ symmetry. apply box_ltype_unfold_full_eqltype; first apply _. reflexivity.
+ Qed.
+ Global Instance typed_place_ofty_box_inst {rt} `{Inhabited rt} π E L l (ty : type rt) (r : place_rfn (place_rfn rt)) bmin0 b P :
+ TypedPlace E L π l (◠(box ty))%I r bmin0 b P | 30 := λ T, i2p (place_ofty_box π E L l ty r bmin0 b P T).
+
+ Lemma typed_place_box_owned {rto} π E L (lt2 : ltype rto) P l r wl bmin0 (T : place_cont_t (place_rfn rto)) :
+ (∀ l', typed_place π E L l' lt2 r (bmin0) (Owned true) P
+ (λ L' κs l2 b2 bmin rti tyli ri strong weak,
+ T L' κs l2 b2 bmin rti tyli ri
+ (fmap (λ strong, mk_strong
+ (λ rti2, place_rfn (strong.(strong_rt) rti2))
+ (λ rti2 lti2 ri2, BoxLtype (strong.(strong_lt) _ lti2 ri2))
+ (λ rti2 (r : place_rfn rti2), PlaceIn (strong.(strong_rfn) _ r))
+ strong.(strong_R)) strong)
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, BoxLtype (weak.(weak_lt) lti2 ri2))
+ (λ (r : place_rfn rti), PlaceIn (weak.(weak_rfn) r))
+ weak.(weak_R)) weak)))
+ ⊢ typed_place π E L l (BoxLtype lt2) (PlaceIn r) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iIntros "HR" (Φ F ??). iIntros "#(LFT & TIME & LLCTX) #HE HL Hincl0 HP HΦ/=".
+ iPoseProof (box_ltype_acc_owned F with "HP") as "(%Hly & Hlb & Hb)"; [done.. | ].
+ iApply fupd_wp. iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iMod "Hb" as "(%l' & Hl & Hb & Hcl)". iMod "HclF" as "_".
+ iModIntro. iApply (wp_logical_step with "TIME Hcl"); [solve_ndisj.. | ].
+ iApply (wp_deref with "Hl") => //; [solve_ndisj | by apply val_to_of_loc | ].
+ iNext. iIntros (st) "Hl Hcred Hc". iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iMod "HclF" as "_". iExists l'.
+ iSplitR. { iPureIntro. unfold mem_cast. rewrite val_to_of_loc. done. }
+ iApply ("HR" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hb"). { destruct bmin0; done. }
+ iModIntro. iIntros (L' κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hb Hs".
+ iApply ("HΦ" $! _ _ _ _ bmin _ _ _ _ _ with "Hincl1 Hb") => /=.
+ iSplit.
+ - (* strong update *) iDestruct "Hs" as "[Hs _]".
+ destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2).
+ iIntros "Hl2 %Hcond".
+ iMod ("Hs" with "Hl2 [//]") as "(Hb & %Hcond2 & HR)".
+ iMod ("Hc" $! (Owned false) with "[] Hl Hb [//]") as "(Hb & Hcond)".
+ { destruct bmin0; done. }
+ iModIntro. iFrame "HR Hb".
+ done.
+ - (* weak update *)
+ destruct weak as [ weak | ]; last done.
+ iDestruct "Hs" as "[_ Hs]".
+ iIntros (ltyi2 ri2 bmin').
+ iIntros "Hincl2 Hl2 Hcond".
+ iMod ("Hs" with "Hincl2 Hl2 Hcond") as "(Hb & Hcond & $ & HR)".
+ iMod ("Hc" with "[] Hl Hb Hcond") as "(Hb & $ & Hcond)".
+ { iPureIntro. apply place_access_rt_rel_refl. }
+ iModIntro. iFrame "HR Hb".
+ done.
+ Qed.
+ Global Instance typed_place_box_owned_inst {rto} π E L (lt2 : ltype rto) bmin0 r l wl P :
+ TypedPlace E L π l (BoxLtype lt2) (PlaceIn r) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) | 30 := λ T, i2p (typed_place_box_owned π E L lt2 P l r wl bmin0 T).
+
+ Lemma typed_place_box_uniq {rto} π E L (lt2 : ltype rto) P l r κ' γ' bmin0
+ (T : place_cont_t (place_rfn rto)) :
+ li_tactic (lctx_lft_alive_count_goal E L κ') (λ '(κs, L'),
+ (∀ l', typed_place π E L' l' lt2 r (bmin0) (Owned true) P
+ (λ L'' κs' l2 b2 bmin rti tyli ri strong weak,
+ T L'' (κs ++ κs') l2 b2 (Uniq κ' γ' ⊓ₖ bmin) rti tyli ri
+ (* strong branch: fold to OpenedLtype *)
+ (fmap (λ strong, mk_strong (place_rfn ∘ strong.(strong_rt))
+ (λ rti2 ltyi2 ri2,
+ OpenedLtype (BoxLtype (strong.(strong_lt) _ ltyi2 ri2)) (BoxLtype lt2) (BoxLtype lt2) (λ r1 r1', ⌜r1 = r1'âŒ) (λ _ _, llft_elt_toks κs))
+ (λ rti2 ri2, PlaceIn $ strong.(strong_rfn) _ ri2)
+ strong.(strong_R)) strong)
+ (* weak branch: just keep the Box *)
+ (fmap (λ weak, mk_weak (λ lti2 ri2, BoxLtype (weak.(weak_lt) lti2 ri2)) (λ (r : place_rfn rti), PlaceIn (weak.(weak_rfn) r)) weak.(weak_R)) weak))))
+ ⊢ typed_place π E L l (BoxLtype lt2) (PlaceIn r) bmin0 (Uniq κ' γ') (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ rewrite /lctx_lft_alive_count_goal.
+ iIntros "(%κs & %L2 & %Hal & HT)".
+ iIntros (Φ F ??). iIntros "#(LFT & TIME & LLCTX) #HE HL #Hincl0 HP HΦ/=".
+ (* get a token *)
+ iApply fupd_wp. iMod (fupd_mask_subseteq lftE) as "HclF"; first done.
+ iMod (lctx_lft_alive_count_tok lftE with "HE HL") as (q) "(Hκ' & Hclκ' & HL)"; [done.. | ].
+ iMod "HclF" as "_". iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iPoseProof (box_ltype_acc_uniq F with "[$LFT $TIME $LLCTX] Hκ' Hclκ' HP") as "(%Hly & Hlb & Hb)"; [done.. | ].
+ iMod "Hb" as "(%l' & Hl & Hb & Hcl)". iMod "HclF" as "_".
+ iModIntro. iApply (wp_logical_step with "TIME Hcl"); [solve_ndisj.. | ].
+ iApply (wp_deref with "Hl") => //; [solve_ndisj | by apply val_to_of_loc | ].
+ iNext.
+ iIntros (st) "Hl Hcred Hcl".
+ iExists l'.
+ iSplitR. { iPureIntro. unfold mem_cast. rewrite val_to_of_loc. done. }
+ iApply ("HT" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hb"). { destruct bmin0; done. }
+ iModIntro. iIntros (L'' κs' l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hb Hs".
+ iApply ("HΦ" $! _ _ _ _ (Uniq κ' γ' ⊓ₖ bmin) _ _ _ _ _ with "[Hincl1] Hb").
+ { iApply bor_kind_incl_trans; last iApply "Hincl1". iApply bor_kind_min_incl_r. }
+ simpl. iSplit.
+ - (* strong update *)
+ iDestruct "Hs" as "(Hs & _)". iDestruct "Hcl" as "(_ & Hcl)".
+ destruct strong as [strong | ]; last done.
+ iIntros (tyli2 ri2 bmin').
+ iIntros "Hl2 %Hst".
+ iMod ("Hs" with "Hl2 [//]") as "(Hb & %Hst' & HR)".
+ iMod ("Hcl" with "Hl [] Hb") as "Hb".
+ { iPureIntro. done. }
+ iModIntro. simp_ltypes.
+ iFrame. done.
+ - (* weak update *)
+ destruct weak as [ weak | ]; last done.
+ iDestruct "Hs" as "(_ & Hs)". iDestruct "Hcl" as "(Hcl & _)".
+ iIntros (ltyi2 ri2 bmin') "#Hincl2 Hl2 Hcond".
+ iMod ("Hs" with "[Hincl2] Hl2 Hcond") as "(Hb & Hcond & ? & HR)".
+ { iApply bor_kind_incl_trans; first iApply "Hincl2". iApply bor_kind_min_incl_r. }
+ iMod ("Hcl" with "Hl Hb [//] Hcond") as "(Hb & Hκ' & Hcond)".
+ iModIntro. rewrite llft_elt_toks_app. iFrame.
+ Qed.
+ Global Instance typed_place_box_uniq_inst {rto} π E L (lt2 : ltype rto) bmin0 r l κ' γ' P :
+ TypedPlace E L π l (BoxLtype lt2) (PlaceIn r) bmin0 (Uniq κ' γ') (DerefPCtx Na1Ord PtrOp true :: P) | 30 := λ T, i2p (typed_place_box_uniq π E L lt2 P l r κ' γ' bmin0 T).
+
+ (*
+ Lemma typed_place_box_shared {rto} π E L (lt2 : ltype rto) P l r κ' bmin0
+ (T : llctx → list lft → loc → bor_kind → bor_kind → ∀ rti, ltype rti → place_rfn rti → (ltype rti → ltype ((place_rfn rto))) → (place_rfn rti → place_rfn ((place_rfn rto))) → (ltype rti → place_rfn rti → iProp Σ) → iProp Σ) :
+ li_tactic (lctx_lft_alive_count_goal E L κ') (λ '(κs, L'),
+ (∀ l', typed_place π E L' l' lt2 r (bmin0) (Owned true) P
+ (λ L'' κs' l2 b2 bmin rti tyli ri (tylp : ltype rti → ltype rto) (rctx : place_rfn rti → place_rfn rto) R,
+ T L'' (κs ++ κs') l2 b2 (Shared κ' ⊓ₖ bmin) rti tyli ri (BoxLtype ∘ tylp) (λ (r : place_rfn rti), PlaceIn (rctx r)) R))) -∗
+ typed_place π E L l (BoxLtype lt2) (PlaceIn r) bmin0 (Shared κ') (DerefPCtx Na1Ord PtrOp :: P) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance typed_place_box_shared_inst {rto} π E L (lt2 : ltype rto) bmin0 r l κ' P :
+ TypedPlace E L π l (BoxLtype lt2) (PlaceIn r) bmin0 (Shared κ') (DerefPCtx Na1Ord PtrOp :: P) | 30 := λ T, i2p (typed_place_box_shared π E L lt2 P l r κ' bmin0 T).
+ *)
+
+
+ Lemma stratify_ltype_box_Owned {rt} `{Inhabited rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : (place_rfn rt)) wl
+ (T : llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ) :
+ (∀ l', stratify_ltype π E L mu mdu ma ml l' lt r (Owned true) (λ L' R rt' (lt' : ltype rt') r',
+ if ma is StratRefoldFull
+ then cast_ltype_to_type E L' lt' (λ ty', T L' R _ (◠(box ty'))%I (PlaceIn r'))
+ else T L' R _ (BoxLtype lt') (PlaceIn r')))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (BoxLtype lt) (PlaceIn r) (Owned wl) T.
+ Proof.
+ Admitted.
+ Global Instance stratify_ltype_box_Owned_inst {rt} `{Inhabited rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : (place_rfn rt)) wl :
+ StratifyLtype π E L mu mdu ma ml l (BoxLtype lt) (PlaceIn r) (Owned wl) := λ T, i2p (stratify_ltype_box_Owned π E L mu mdu ma ml l lt r wl T).
+
+ Lemma stratify_ltype_box_uniq {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : (place_rfn rt)) κ' γ'
+ (T : llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ) :
+ (* get a lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L κ') (λ '(κs, L1),
+ (∀ l', stratify_ltype π E L1 mu mdu ma ml l' lt r (Owned true) (λ L2 R rt' lt' r',
+ (* validate the update *)
+ prove_place_cond E L2 (Uniq κ' γ') lt lt' (λ upd,
+ match upd with
+ | ResultWeak Heq =>
+ (* update obeys the contract, get a box *)
+ match ma with
+ | StratRefoldFull => ∃ (_ : Inhabited rt'), cast_ltype_to_type E L2 lt' (λ ty',
+ T L2 (llft_elt_toks κs ∗ R) _ (◠(box ty'))%I (#r'))
+ | _ =>
+ T L2 (llft_elt_toks κs ∗ R) _ (BoxLtype lt') (#r')
+ end
+ | ResultStrong =>
+ (* unfold to an OpenedLtype *)
+ ⌜ma = StratNoRefold⌠∗
+ T L2 R _ (OpenedLtype (BoxLtype lt') (BoxLtype lt) (BoxLtype lt) (λ r1 r2, ⌜r1 = r2âŒ) (λ _ _, llft_elt_toks κs)) (#r')
+ end))))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (BoxLtype lt) (PlaceIn r) (Uniq κ' γ') T.
+ Proof.
+ Admitted.
+ Global Instance stratify_ltype_box_uniq_inst {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : (place_rfn rt)) κ' γ' :
+ StratifyLtype π E L mu mdu ma ml l (BoxLtype lt) (PlaceIn r) (Uniq κ' γ') :=
+ λ T, i2p (stratify_ltype_box_uniq π E L mu mdu ma ml l lt r κ' γ' T).
+
+ (* TODO: shared folding instance *)
+
+ (** Unfolding instances *)
+ Lemma stratify_ltype_ofty_box {rt} `{!Inhabited rt} π E L mu ma {M} (ml : M) l (ty : type rt) (r : place_rfn (place_rfn rt)) b T :
+ stratify_ltype π E L mu StratDoUnfold ma ml l (BoxLtype (◠ty)) r b T
+ ⊢ stratify_ltype π E L mu StratDoUnfold ma ml l (◠(box ty)) r b T.
+ Proof.
+ iIntros "Hp". iApply stratify_ltype_eqltype; iFrame.
+ iPureIntro. apply full_eqltype_alt. symmetry.
+ eapply box_ltype_unfold_full_eqltype; first apply _. reflexivity.
+ Qed.
+ Global Instance stratify_ltype_ofty_box_inst {rt} `{Inhabited rt} π E L mu ma {M} (ml : M) l (ty : type rt) (r : place_rfn (place_rfn rt)) b :
+ StratifyLtype π E L mu StratDoUnfold ma ml l (◠(box ty))%I r b | 30 := λ T, i2p (stratify_ltype_ofty_box π E L mu ma ml l ty r b T).
+
+
+ (** prove_place_cond instances *)
+ (* These need to have a lower priority than the ofty_refl instance (level 2) and the unblocking instances (level 5), but higher than the trivial "no" instance *)
+ Lemma prove_place_cond_unfold_box_l E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) k T :
+ prove_place_cond E L k (BoxLtype (â— ty)) lt T
+ ⊢ prove_place_cond E L k (◠(box ty)) lt T.
+ Proof.
+ iApply prove_place_cond_eqltype_l. apply symmetry. apply box_ltype_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_box_l_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) k :
+ ProvePlaceCond E L k (◠(box ty))%I lt | 10 := λ T, i2p (prove_place_cond_unfold_box_l E L ty lt k T).
+ Lemma prove_place_cond_unfold_box_r E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) k T :
+ prove_place_cond E L k lt (BoxLtype (â— ty)) T
+ ⊢ prove_place_cond E L k lt (◠(box ty)) T.
+ Proof.
+ iApply prove_place_cond_eqltype_r. apply symmetry. apply box_ltype_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_box_r_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) k :
+ ProvePlaceCond E L k lt (◠(box ty))%I | 10 := λ T, i2p (prove_place_cond_unfold_box_r E L ty lt k T).
+
+ Lemma prove_place_cond_box_ltype E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) k T :
+ prove_place_cond E L k lt1 lt2 (λ upd, T $ access_result_lift (place_rfn) upd)
+ ⊢ prove_place_cond E L k (BoxLtype lt1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "($ & (%upd & Hcond & HT))".
+ iExists _. iFrame. destruct upd; cbn.
+ - subst rt2. by iApply box_ltype_place_cond_ty.
+ - done.
+ Qed.
+ Global Instance prove_place_cond_box_ltype_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) k :
+ ProvePlaceCond E L k (BoxLtype lt1) (BoxLtype lt2) | 5 := λ T, i2p (prove_place_cond_box_ltype E L lt1 lt2 k T).
+
+ (** Resolve ghost *)
+ Import EqNotations.
+ Lemma resolve_ghost_box_Owned {rt} π E L l (lt : ltype rt) γ wl rm lb T :
+ find_observation (place_rfn rt) γ FindObsModeDirect (λ or,
+ match or with
+ | None => ⌜rm = ResolveTry⌠∗ T L (PlaceGhost γ) True false
+ | Some r => T L (PlaceIn $ r) True true
+ end)
+ ⊢ resolve_ghost π E L rm lb l (BoxLtype lt) (Owned wl) (PlaceGhost γ) T.
+ Proof.
+ Admitted.
+ Global Instance resolve_ghost_box_owned_inst {rt} π E L l (lt : ltype rt) γ wl rm lb :
+ ResolveGhost π E L rm lb l (BoxLtype lt) (Owned wl) (PlaceGhost γ) | 7 := λ T, i2p (resolve_ghost_box_Owned π E L l lt γ wl rm lb T).
+
+ Lemma resolve_ghost_box_Uniq {rt} π E L l (lt : ltype rt) γ rm lb κ γ' T :
+ find_observation (place_rfn rt) γ FindObsModeDirect (λ or,
+ match or with
+ | None => ⌜rm = ResolveTry⌠∗ T L (PlaceGhost γ) True false
+ | Some r => T L (PlaceIn $ r) True true
+ end)
+ ⊢ resolve_ghost π E L rm lb l (BoxLtype lt) (Uniq κ γ') (PlaceGhost γ) T.
+ Proof.
+ Admitted.
+ Global Instance resolve_ghost_box_uniq_inst {rt} π E L l (lt : ltype rt) γ κ γ' rm lb :
+ ResolveGhost π E L rm lb l (BoxLtype lt) (Uniq κ γ') (PlaceGhost γ) | 7 := λ T, i2p (resolve_ghost_box_Uniq π E L l lt γ rm lb κ γ' T).
+
+ (** cast_ltype *)
+ Lemma cast_ltype_to_type_box E L {rt} `{Inhabited rt} (lt : ltype rt) T :
+ cast_ltype_to_type E L lt (λ ty, T (box ty))
+ ⊢ cast_ltype_to_type E L (BoxLtype lt) T.
+ Proof.
+ iIntros "Hs". iDestruct "Hs" as "(%ty & %Heq & HT)".
+ iExists (box ty). iFrame "HT". iPureIntro.
+ apply box_ltype_unfold_full_eqltype; done.
+ Qed.
+ Global Instance cast_ltype_to_type_box_inst E L {rt} `{Inhabited rt} (lt : ltype rt) :
+ CastLtypeToType E L (BoxLtype lt) := λ T, i2p (cast_ltype_to_type_box E L lt T).
+
+ (** Subtyping instances *)
+ Lemma weak_subtype_box_in E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 T :
+ weak_subtype E L r1 r2 ty1 ty2 T
+ ⊢ weak_subtype E L #r1 #r2 (box ty1) (box ty2) T.
+ Proof.
+ iIntros "HT" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ by iApply box_type_incl_in.
+ Qed.
+ Global Instance weak_subtype_box_in_inst E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 :
+ Subtype E L #r1 #r2 (box ty1) (box ty2) | 10 := λ T, i2p (weak_subtype_box_in E L ty1 ty2 r1 r2 T).
+
+ Lemma weak_subtype_box E L {rt} (ty1 : type rt) (ty2 : type rt) r T :
+ mut_subtype E L ty1 ty2 T
+ ⊢ weak_subtype E L r r (box ty1) (box ty2) T.
+ Proof.
+ iIntros "(%Hsubt & HT)" (??) "#CTX #HE HL".
+ iPoseProof (full_subtype_acc with "HE HL") as "#Hincl"; first done.
+ iFrame. by iApply box_type_incl.
+ Qed.
+ Global Instance weak_subtype_box_inst E L {rt} (ty1 : type rt) (ty2 : type rt) r :
+ Subtype E L r r (box ty1) (box ty2) | 15 := λ T, i2p (weak_subtype_box E L ty1 ty2 r T).
+
+ Lemma mut_subtype_box E L {rt} (ty1 ty2 : type rt) T :
+ mut_subtype E L ty1 ty2 T
+ ⊢ mut_subtype E L (box ty1) (box ty2) T.
+ Proof.
+ iIntros "(%Hsubt & $)". iPureIntro.
+ by eapply box_full_subtype.
+ Qed.
+ Global Instance mut_subtype_box_inst E L {rt} (ty1 ty2 : type rt) :
+ MutSubtype E L (box ty1) (box ty2) := λ T, i2p (mut_subtype_box E L ty1 ty2 T).
+
+ Lemma mut_eqtype_box E L {rt} (ty1 ty2 : type rt) T :
+ mut_eqtype E L ty1 ty2 T
+ ⊢ mut_eqtype E L (box ty1) (box ty2) T.
+ Proof.
+ iIntros "(%Hsubt & $)". iPureIntro.
+ apply full_subtype_eqtype; eapply box_full_subtype.
+ - by apply full_eqtype_subtype_l.
+ - by apply full_eqtype_subtype_r.
+ Qed.
+ Global Instance mut_eqtype_box_inst E L {rt} (ty1 ty2 : type rt) :
+ MutEqtype E L (box ty1) (box ty2) := λ T, i2p (mut_eqtype_box E L ty1 ty2 T).
+
+ (** Subltyping instances *)
+ (* generic in [r2] to handle the case that it is an evar *)
+ Lemma weak_subltype_box_owned_in E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl r1 r2 T :
+ (∃ r2', ⌜r2 = #r2'⌠∗ weak_subltype E L (Owned true) r1 r2' lt1 lt2 T)
+ ⊢ weak_subltype E L (Owned wl) #r1 r2 (BoxLtype lt1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%r2' & -> & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ by iApply box_ltype_incl_owned_in.
+ Qed.
+ Global Instance weak_subltype_box_owned_in_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl r1 r2 :
+ SubLtype E L (Owned wl) #r1 r2 (BoxLtype lt1) (BoxLtype lt2) | 10 := λ T, i2p (weak_subltype_box_owned_in E L lt1 lt2 wl r1 r2 T).
+
+ Lemma weak_subltype_box_shared_in E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ r1 r2 T :
+ (∃ r2', ⌜r2 = #r2'⌠∗ weak_subltype E L (Shared κ) r1 r2' lt1 lt2 T)
+ ⊢ weak_subltype E L (Shared κ) #r1 r2 (BoxLtype lt1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%r2' & -> & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ by iApply box_ltype_incl_shared_in.
+ Qed.
+ Global Instance weak_subltype_box_shared_in_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ r1 r2 :
+ SubLtype E L (Shared κ) #r1 r2 (BoxLtype lt1) (BoxLtype lt2) | 10 := λ T, i2p (weak_subltype_box_shared_in E L lt1 lt2 κ r1 r2 T).
+
+ (* Base instance that will trigger, e.g., for Uniq or PlaceGhost refinements *)
+ Lemma weak_subltype_box_base E L {rt} (lt1 lt2 : ltype rt) k r T :
+ mut_eqltype E L lt1 lt2 T
+ ⊢ weak_subltype E L k r r (BoxLtype lt1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%Hsubt & T)" (??) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hincl"; first done. iFrame.
+ iApply box_ltype_incl. done.
+ Qed.
+ Global Instance weak_subltype_box_base_inst E L {rt} (lt1 lt2 : ltype rt) k r :
+ SubLtype E L k r r (BoxLtype lt1) (BoxLtype lt2) | 20 := λ T, i2p (weak_subltype_box_base E L lt1 lt2 k r T).
+
+ Lemma mut_subltype_box E L {rt} (lt1 lt2 : ltype rt) T :
+ mut_eqltype E L lt1 lt2 T
+ ⊢ mut_subltype E L (BoxLtype lt1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%Heqt & $)". iPureIntro.
+ by eapply box_full_subltype.
+ Qed.
+ Global Instance mut_subltype_box_inst E L {rt} (lt1 lt2 : ltype rt) :
+ MutSubLtype E L (BoxLtype lt1) (BoxLtype lt2) := λ T, i2p (mut_subltype_box E L lt1 lt2 T).
+
+ Lemma mut_eqltype_box E L {rt} (lt1 lt2 : ltype rt) T :
+ mut_eqltype E L lt1 lt2 T
+ ⊢ mut_eqltype E L (BoxLtype lt1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%Heqt & $)". iPureIntro.
+ apply full_subltype_eqltype; eapply box_full_subltype.
+ - done.
+ - symmetry. done.
+ Qed.
+ Global Instance mut_eqltype_box_inst E L {rt} (lt1 lt2 : ltype rt) :
+ MutEqLtype E L (BoxLtype lt1) (BoxLtype lt2) := λ T, i2p (mut_eqltype_box E L lt1 lt2 T).
+
+ (* Ofty unfolding if necessary *)
+ Lemma weak_subltype_box_ofty_1 E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type (place_rfn rt2)) k r1 r2 T :
+ (∃ ty2', ⌜ty2 = box ty2'⌠∗ weak_subltype E L k r1 r2 (BoxLtype lt1) (BoxLtype (◠ty2')) T)
+ ⊢ weak_subltype E L k r1 r2 (BoxLtype lt1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "Hincl").
+ iApply box_ltype_unfold_1.
+ Qed.
+ Global Instance weak_subltype_box_ofty_1_inst E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type (place_rfn rt2)) k r1 r2 :
+ SubLtype E L k r1 r2 (BoxLtype lt1) (◠ty2)%I | 10 := λ T, i2p (weak_subltype_box_ofty_1 E L lt1 ty2 k r1 r2 T).
+
+ Lemma weak_subltype_box_ofty_2 E L {rt1 rt2} `{!Inhabited rt2} (ty1 : type (place_rfn rt1)) (lt2 : ltype rt2) k r1 r2 T :
+ (∃ ty1', ⌜ty1 = box ty1'⌠∗ weak_subltype E L k r1 r2 (BoxLtype (◠ty1')) (BoxLtype lt2) T)
+ ⊢ weak_subltype E L k r1 r2 (◠ty1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%ty1' & -> & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "[] Hincl").
+ iApply box_ltype_unfold_2.
+ Qed.
+ Global Instance weak_subltype_box_ofty_2_inst E L {rt1 rt2} `{!Inhabited rt2} (ty1 : type (place_rfn rt1)) (lt2 : ltype rt2) k r1 r2 :
+ SubLtype E L k r1 r2 (◠ty1)%I (BoxLtype lt2) | 10 := λ T, i2p (weak_subltype_box_ofty_2 E L ty1 lt2 k r1 r2 T).
+
+ (* Same for [mut_subltype] *)
+ Lemma mut_subltype_box_ofty_1 E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) T :
+ (∃ ty2', ⌜ty2 = box ty2'⌠∗ mut_subltype E L (BoxLtype lt1) (BoxLtype (◠ty2')) T)
+ ⊢ mut_subltype E L (BoxLtype lt1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & %Hsubt & $)". iPureIntro.
+ etrans; first done. eapply full_eqltype_subltype_l.
+ by eapply box_ltype_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_box_ofty_1_inst E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) :
+ MutSubLtype E L (BoxLtype lt1) (◠ty2)%I | 10 := λ T, i2p (mut_subltype_box_ofty_1 E L lt1 ty2 T).
+
+ Lemma mut_subltype_box_ofty_2 E L {rt} `{!Inhabited rt} (ty1 : type (place_rfn rt)) (lt2 : ltype rt) T :
+ (∃ ty1', ⌜ty1 = box ty1'⌠∗ mut_subltype E L (BoxLtype (◠ty1')) (BoxLtype lt2) T)
+ ⊢ mut_subltype E L (◠ty1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%ty1' & -> & %Hsubt & $)". iPureIntro.
+ etrans; last done. eapply full_eqltype_subltype_r.
+ by eapply box_ltype_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_box_ofty_2_inst E L {rt} `{!Inhabited rt} (ty1 : type (place_rfn rt)) (lt2 : ltype rt) :
+ MutSubLtype E L (◠ty1)%I (BoxLtype lt2) | 10 := λ T, i2p (mut_subltype_box_ofty_2 E L ty1 lt2 T).
+
+ (* Same for [mut_eqltype] *)
+ Lemma mut_eqltype_box_ofty_1 E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) T :
+ (∃ ty2', ⌜ty2 = box ty2'⌠∗ mut_eqltype E L (BoxLtype lt1) (BoxLtype (◠ty2')) T)
+ ⊢ mut_eqltype E L (BoxLtype lt1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & %Heqt & $)". iPureIntro.
+ etrans; first done. by eapply box_ltype_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_box_ofty_1_inst E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) :
+ MutEqLtype E L (BoxLtype lt1) (◠ty2)%I | 10 := λ T, i2p (mut_eqltype_box_ofty_1 E L lt1 ty2 T).
+
+ Lemma mut_eqltype_box_ofty_2 E L {rt} `{!Inhabited rt} (ty1 : type (place_rfn rt)) (lt2 : ltype rt) T :
+ (∃ ty1', ⌜ty1 = box ty1'⌠∗ mut_eqltype E L (BoxLtype (◠ty1')) (BoxLtype lt2) T)
+ ⊢ mut_eqltype E L (◠ty1) (BoxLtype lt2) T.
+ Proof.
+ iIntros "(%ty1' & -> & %Heqt & $)". iPureIntro.
+ etrans; last done. symmetry. by eapply box_ltype_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_box_ofty_2_inst E L {rt} `{!Inhabited rt} (ty1 : type (place_rfn rt)) (lt2 : ltype rt) :
+ MutEqLtype E L (◠ty1)%I (BoxLtype lt2) | 10 := λ T, i2p (mut_eqltype_box_ofty_2 E L ty1 lt2 T).
+End rules.
+Global Typeclasses Opaque BoxLtype.
+Global Typeclasses Opaque box.
diff --git a/theories/rust_typing/dfrac_agree.v b/theories/rust_typing/dfrac_agree.v
new file mode 100644
index 0000000000000000000000000000000000000000..71340828729fb2618b0e7c584bb7ed37edaa8978
--- /dev/null
+++ b/theories/rust_typing/dfrac_agree.v
@@ -0,0 +1,104 @@
+From iris.algebra Require Export dfrac agree updates local_updates.
+From iris.algebra Require Import proofmode_classes.
+From iris.prelude Require Import options.
+
+Definition dfrac_agreeR (A : ofe) : cmra := prodR dfracR (agreeR A).
+
+Definition to_dfrac_agree {A : ofe} (dq : dfrac) (a : A) : dfrac_agreeR A :=
+ (dq, to_agree a).
+
+Section lemmas.
+ Context {A : ofe}.
+ Implicit Types (dq : dfrac) (q : Qp) (a : A).
+
+ Global Instance to_dfrac_agree_ne dq : NonExpansive (@to_dfrac_agree A dq).
+ Proof. solve_proper. Qed.
+ Global Instance to_dfrac_agree_proper dq : Proper ((≡) ==> (≡)) (@to_dfrac_agree A dq).
+ Proof. solve_proper. Qed.
+
+ Global Instance to_dfrac_agree_exclusive a : Exclusive (to_dfrac_agree (DfracOwn 1) a).
+ Proof. apply _. Qed.
+ Global Instance to_dfrac_discrete a : Discrete a → Discrete (to_dfrac_agree (DfracOwn 1) a).
+ Proof. apply _. Qed.
+ Global Instance to_frac_injN n : Inj2 (dist n) (dist n) (dist n) (@to_dfrac_agree A).
+ Proof. by intros dq1 a1 dq2 a2 [??%(inj to_agree)]. Qed.
+ Global Instance to_dfrac_inj : Inj2 (≡) (≡) (≡) (@to_dfrac_agree A).
+ Proof. by intros dq1 a1 dq2 a2 [??%(inj to_agree)]. Qed.
+
+ Lemma dfrac_agree_own_op q1 q2 a :
+ to_dfrac_agree (DfracOwn (q1 + q2)) a ≡ to_dfrac_agree (DfracOwn q1) a ⋅ to_dfrac_agree (DfracOwn q2) a.
+ Proof. rewrite /to_dfrac_agree -pair_op agree_idemp //. Qed.
+
+ Lemma dfrac_agree_own_op_valid q1 a1 q2 a2 :
+ ✓ (to_dfrac_agree (DfracOwn q1) a1 ⋅ to_dfrac_agree (DfracOwn q2) a2) →
+ (q1 + q2 ≤ 1)%Qp ∧ a1 ≡ a2.
+ Proof.
+ intros [Hq Ha]%pair_valid. simpl in *. split; first done.
+ apply to_agree_op_inv. done.
+ Qed.
+ Lemma dfrac_agree_own_op_valid_L `{!LeibnizEquiv A} q1 a1 q2 a2 :
+ ✓ (to_dfrac_agree (DfracOwn q1) a1 ⋅ to_dfrac_agree (DfracOwn q2) a2) →
+ (q1 + q2 ≤ 1)%Qp ∧ a1 = a2.
+ Proof. unfold_leibniz. apply dfrac_agree_own_op_valid. Qed.
+ Lemma dfrac_agree_own_op_validN q1 a1 q2 a2 n :
+ ✓{n} (to_dfrac_agree (DfracOwn q1) a1 ⋅ to_dfrac_agree (DfracOwn q2) a2) →
+ (q1 + q2 ≤ 1)%Qp ∧ a1 ≡{n}≡ a2.
+ Proof.
+ intros [Hq Ha]%pair_validN. simpl in *. split; first done.
+ apply to_agree_op_invN. done.
+ Qed.
+ Lemma dfrac_agree_own_op_valid1 q1 a1 dq2 a2 :
+ ✓ (to_dfrac_agree (DfracOwn q1) a1 ⋅ to_dfrac_agree dq2 a2) →
+ (q1 < 1)%Qp ∧ a1 ≡ a2.
+ Proof.
+ intros [Hq Ha]%pair_valid. simpl in *.
+ specialize (to_agree_op_inv _ _ Ha) as Heq. split; last done.
+ by eapply dfrac_valid_own_l.
+ Qed.
+ Lemma dfrac_agree_own_op_valid1_L `{!LeibnizEquiv A} q1 a1 dq2 a2 :
+ ✓ (to_dfrac_agree (DfracOwn q1) a1 ⋅ to_dfrac_agree dq2 a2) →
+ (q1 < 1)%Qp ∧ a1 = a2.
+ Proof. unfold_leibniz. apply dfrac_agree_own_op_valid1. Qed.
+ Lemma dfrac_agree_op_valid dq1 a1 dq2 a2 :
+ ✓ (to_dfrac_agree dq1 a1 ⋅ to_dfrac_agree dq2 a2) → a1 ≡ a2.
+ Proof.
+ intros [Hq Ha]%pair_valid. simpl in *.
+ specialize (to_agree_op_inv _ _ Ha) as Heq. done.
+ Qed.
+ Lemma dfrac_agree_op_valid_L `{!LeibnizEquiv A} dq1 a1 dq2 a2 :
+ ✓ (to_dfrac_agree dq1 a1 ⋅ to_dfrac_agree dq2 a2) → a1 = a2.
+ Proof. unfold_leibniz. apply dfrac_agree_op_valid. Qed.
+
+ Lemma dfrac_agree_own_included q1 a1 q2 a2 :
+ to_dfrac_agree (DfracOwn q1) a1 ≼ to_dfrac_agree (DfracOwn q2) a2 ↔
+ (q1 < q2)%Qp ∧ a1 ≡ a2.
+ Proof. by rewrite pair_included dfrac_own_included to_agree_included. Qed.
+ Lemma dfrac_agree_own_included_L `{!LeibnizEquiv A} q1 a1 q2 a2 :
+ to_dfrac_agree (DfracOwn q1) a1 ≼ to_dfrac_agree (DfracOwn q2) a2 ↔
+ (q1 < q2)%Qp ∧ a1 = a2.
+ Proof. unfold_leibniz. apply dfrac_agree_own_included. Qed.
+ Lemma dfrac_agree_own_includedN q1 a1 q2 a2 n :
+ to_dfrac_agree (DfracOwn q1) a1 ≼{n} to_dfrac_agree (DfracOwn q2) a2 ↔
+ (q1 < q2)%Qp ∧ a1 ≡{n}≡ a2.
+ Proof.
+ by rewrite pair_includedN -cmra_discrete_included_iff
+ dfrac_own_included to_agree_includedN.
+ Qed.
+ Lemma dfrac_agree_discarded_included a1 a2 :
+ to_dfrac_agree DfracDiscarded a1 ≼ to_dfrac_agree DfracDiscarded a2 ↔ a1 ≡ a2.
+ Proof.
+ rewrite pair_included to_agree_included; split;
+ naive_solver eauto using dfrac_discarded_included.
+ Qed.
+
+ (** No frame-preserving update lemma needed -- use [cmra_update_exclusive] with
+ the above [Exclusive] instance. *)
+ Lemma dfrac_agree_discard_update dq a :
+ to_dfrac_agree dq a ~~> to_dfrac_agree DfracDiscarded a.
+ Proof.
+ apply prod_update; last done.
+ apply dfrac_discard_update.
+ Qed.
+End lemmas.
+
+Global Typeclasses Opaque to_dfrac_agree.
diff --git a/theories/rust_typing/dune b/theories/rust_typing/dune
new file mode 100644
index 0000000000000000000000000000000000000000..0e4b222cd9a92d0a73d212255bc2141a9c01295f
--- /dev/null
+++ b/theories/rust_typing/dune
@@ -0,0 +1,6 @@
+(coq.theory
+ (name refinedrust)
+ (package refinedrust)
+ (flags -w -notation-overridden -w -redundant-canonical-projection)
+ (synopsis "RefinedRust")
+ (theories caesium lithium))
diff --git a/theories/rust_typing/enum.v b/theories/rust_typing/enum.v
new file mode 100644
index 0000000000000000000000000000000000000000..7d522ee90a544d59b3f13e7bbf57f3453221fc06
--- /dev/null
+++ b/theories/rust_typing/enum.v
@@ -0,0 +1,872 @@
+From refinedrust Require Export type ltypes.
+From refinedrust Require Import uninit int.
+From refinedrust Require Import products programs.
+Set Default Proof Using "Type".
+
+Section union.
+ Context `{!typeGS Σ}.
+ (** [active_union_t ty uls] basically wraps [ty] to lay it out in [uls], asserting that a union currently is in variant [variant].
+ This is not capturing the allowed union layouting in Rust in full generality (Rust may freely choose the offsets of the variants),
+ but we are anyways already not handling tags correctly, so who cares... *)
+ (* TODO rather factor out into a padded type, as in RefinedC? *)
+ Program Definition active_union_t {rt} (ty : type rt) (variant : string) (uls : union_layout_spec) : type rt := {|
+ ty_own_val π r v :=
+ (∃ ul ly, ⌜use_union_layout_alg uls = Some ul⌠∗
+ ⌜layout_of_union_member variant ul = Some ly⌠∗
+ take ly.(ly_size) v â—áµ¥{Ï€} r @ ty ∗
+ drop ly.(ly_size) v â—áµ¥{Ï€} () @ uninit (UntypedSynType (ly_offset (ul : layout) ly.(ly_size))))%I;
+ ty_syn_type := uls;
+ ty_has_op_type ot mt :=
+ (* we should not directly read from/write to this *)
+ (* TODO: really? *)
+ False;
+ ty_shr κ π r l :=
+ (∃ ul ly, ⌜use_union_layout_alg uls = Some ul⌠∗
+ ⌜layout_of_union_member variant ul = Some ly⌠∗
+ ⌜l `has_layout_loc` ul⌠∗
+ l â—â‚—{Ï€, κ} r @ ty ∗
+ (l +â‚— ly.(ly_size)) â—â‚—{Ï€, κ} () @ uninit (UntypedSynType (ly_offset (ul : layout) ly.(ly_size))))%I;
+ ty_ghost_drop r := ty.(ty_ghost_drop) r;
+ ty_lfts := ty_lfts ty;
+ ty_wf_E := ty_wf_E ty;
+ ty_sidecond := True;
+ |}.
+ Next Obligation.
+ iIntros (rt ty var uls π r v) "(%ul & %ly & % & % & Hv & Hvr)".
+ iExists ul.
+ iSplitR. { iPureIntro. by apply use_union_layout_alg_Some_inv. }
+ iPoseProof (ty_has_layout with "Hv") as "(%ly' & %Halg0 & %Hv0)".
+ rewrite uninit_own_spec. iDestruct "Hvr" as "(% & %Halg1 & %Hv1)".
+ iPureIntro. apply syn_type_has_layout_untyped_inv in Halg1 as (-> & _ & _).
+ Admitted.
+ Next Obligation.
+ done.
+ Qed.
+ Next Obligation.
+ eauto.
+ Qed.
+ Next Obligation.
+ iIntros (????????) "(%ul & %ly & % & % & % & _)". iExists ul.
+ iSplitR; first done. iPureIntro. by eapply use_union_layout_alg_Some_inv.
+ Qed.
+ Next Obligation.
+ iIntros (rt ty variant uls E κ l ly π r q ?) "CTX Htok %Halg %Hly #Hlb Hb".
+ Admitted.
+ Next Obligation.
+ iIntros (rt ty variant uls κ κ' π r l) "#Hincl Hb".
+ Admitted.
+ Next Obligation.
+ iIntros (?????????) "Hb".
+ iDestruct "Hb" as "(%ul & %ly & %Halg & %Hly & Hv & _)".
+ iPoseProof (ty_own_ghost_drop with "Hv") as "Ha"; last iApply (logical_step_wand with "Ha"); eauto.
+ Qed.
+ Next Obligation.
+ done.
+ Qed.
+End union.
+
+(*
+ Design decisions and considerations:
+ - What is enum refined by? Should be refined by the tag and the refinement of the respective component.
+ Several ways to encode that:
+ 1) have a Coq type that subsumes both, with projections into an index for the tag and the refinement
+ 2) have two separate things: a tag (either a string, an index, or a member of a Coq type), and a sum of the refinement types. Only certain combinations are valid, of course.
+ 3)
+
+
+ RefinedC defines the tagged union type directly in terms of struct: containing the tag and the actual data.
+ It basically takes the approach 1).
+ + this just directly unfolds to the struct.
+ further types:
+ - variant ti r ty is ownership of the padded full union chunk storing ty; where r is the refinement of the whole union and thus also defines the variant
+ => typed_place with GetMemberUnion on this basically focusses on the segment actually storing ty.
+ - tag ti r defines ownership of the integer tag corresponding to r.
+ => there is a subsumption instance from int to this.
+ -
+ *)
+
+(*
+
+ To avoid some of the complication of separate variant + data assignment:
+ can I just do a fused assignment?
+ Caveats:
+ - less realistic, in particular due to how assignment to unions works in the bag-of-bytes model: we are really writing the full union now using an UntypedOp, whereas otherwise we would do a typed write of just the part of the representation that is relevant.
+ - a bit of frontend work, but should be fairly easy.
+
+ Enum ltype setup:
+ Variant 1:
+ - by default have a EnumLtype els with a current ltype for the data of the current variant (we need this specific additional ltype in order to be able to do borrows)
+ - note that we will need an unfolding lemma that looks slightly differently from the usual thing which talks about the current variant (i.e. depends on the refinement)
+ - imp unblockable lemma: states that the enum is unblockable if the current_lt is unblockable to something which matches the type dictated by the variant.
+ - by itself, this will support strong updates for the contained thing. We don't have an active coupling to the tag at that point.
+ => does this have disadvantages?
+ + switching to this constitutes a strong update, similar to switching to OpenedLtype.
+ So we need to open borrows for that.
+ +
+ => can we just use OpenedLtype for that?
+ - every enum access will just unfold it.
+ [- NO, it currently is not flexible enough to do that, because the Cpre/Cpost do not have access to the types.]
+ - it is expressible by just taking as lt_inner the â— enum -- if we are unblockable to that, everything is fine.
+ Then we need a pretty powerful subtyping/prove_place_cond, however.
+
+ Variant 1.5:
+ - have its own ltype. We could still use coreable to implement stuff below borrows.
+
+ Variant 2:
+ - like variant 1, but maintain an active coupling to the tag field.
+ we always require the core of the current thing to be equivalent to the type prescribed by the tag.
+ - this variant does not allow to do storng updates below.
+ If we want to do a strong update, e.g. move something out temporarily, we need to use an OpenedLtype above.
+ Here the condition is expressible already -- we just need to get something whose core goes to the full enum.
+
+
+ How would I do separate assignment for this implementation?
+ For Variant 1:
+ + nothing interesting happens, because we anways just have an openedltype which just does "plain data".
+ For Variant 1.5:
+ + we need to do a bit of work, but there's nothing fundamentally difficult here.
+ For Variant 2:
+ + the place access lemma for this will put an OpenedLtype above (with lt_inner = full enum, so similar to Variant 1), so we can still do strong updates below.
+ + afterwards, we would write the new tag.
+ + at that point, we could re-establish the invariant. However, how do we detect that?
+ It would essentially need to happen on-demand, e.g. when reading (we'd require a FoldOpened anyways).
+
+ It seems like for separate assignments, Variant 1 is more convenient (for variant 2, we basically put variant 1 on top).
+ It seems like for just regular stuff, Variant 2 might be nicer, because we don't need to open borrows etc all the time.
+
+ Is there a reason why we should not just keep borrows open all the time?
+ - e.g. something related to semantic safety and panics?
+ does it destroy our panic freedom plans?
+ What I can imagine is this: everytime we call into something which might panic, we need to prove that the panic handler, i.e. the unwinding path, also plays out correctly, and pass a proof of that to the function.
+ Basically, in that path we would then need to show that everything checks out, i.e. we can close everything properly.
+ But that should not be that difficult, i.e. it should be fine as long as we can restore it again, which we can usually do.
+ -
+
+ Then what is the difference to just requiring magic wands everywhere and using that as your interface?
+ i.e. would unfolding all of my stuff into aliases at the start of the function be a valid approach?
+ - in RustBelt it certainly is, when you do manual proofs.
+ The Q here is really mostly from an automation perspective.
+ - we need to consider what happens at calls.
+ - how well does it work for nesting to just do magic wands?
+ This question is mostly orthogonal. Quite possibly it would work in a different way -- but it's not at all clear how well. Especially if we consider automating it in a system like Coq. Magic wands are pretty hard in general, and the structure enforced by having proper borrows etc. certainly helps us.
+ It also makes semantic safety arguments easier.
+ HOWEVER, for shared references there is a very clear argument (in terms of seplogic specification) what this buys us!
+ Sharing in e.g. refinedc is MUCH less expressive, and it's difficult to emulate Rust-style sharing with magic wands and fractions.
+
+ For now, go with variant 1 and see how well it works.
+ *)
+
+Section enum.
+ Context `{!typeGS Σ}.
+
+
+ (* let's try to do it similarly *)
+ Record enum (rt : Type) : Type := mk_enum {
+ (* the layout spec *)
+ enum_els : enum_layout_spec;
+ (* out of the current refinement, extract the tag *)
+ enum_tag : rt → var_name;
+ (* out of the current refinement, extract the component type and refinement *)
+ enum_ty : rt → sigT (λ rt' : Type, type rt' * rt')%type;
+ (* convenience function: given the variant name, also project out the type *)
+ enum_variant_ty : var_name → option (sigT type);
+ (* explicitly track the lifetimes each of the variants needs -- needed for sharing *)
+ enum_lfts : list lft;
+ enum_wf_E : elctx;
+ enum_lfts_complete : ∀ (r : rt), ty_lfts (projT2 (enum_ty r)).1 ⊆ enum_lfts;
+ enum_wf_E_complete : ∀ (r : rt), ty_wf_E (projT2 (enum_ty r)).1 ⊆ enum_wf_E;
+ }.
+ Global Arguments mk_enum {_}.
+ Global Arguments enum_els {_}.
+ Global Arguments enum_tag {_}.
+ Global Arguments enum_ty {_}.
+ Global Arguments enum_variant_ty {_}.
+ Global Arguments enum_lfts {_}.
+ Global Arguments enum_wf_E {_}.
+
+ Definition enum_lookup_tag {rt} (e : enum rt) (r : rt) :=
+ els_lookup_tag e.(enum_els) (e.(enum_tag) r).
+
+ (* For constructing the enum, we need to provide a hint that computes the refinement of the enum fromt the variant and its refinement.
+ Note that, crucially, also the [e : enum rto] is already an input to this typeclass (determined by the [rust_type] annotation on [EnumInit]), because we need the type parameters of the enum to already be determined.
+ (As an example, imagine constructing the [None] variant of [Option<T>]).
+ *)
+ Class ConstructEnum {rti rto} (e : enum rto) (variant : string) (ty : type rti) (input : rti) (out : rto) : Type := construct_enum {
+ (* sidecondition that we need to solve *)
+ (*construct_enum_sc : Prop;*)
+ (* agreemtn that we get as a result *)
+ construct_enum_proof : e.(enum_ty) out = existT _ (ty, input) ∧ e.(enum_tag) out = variant;
+ }.
+ Global Hint Mode ConstructEnum + + + + + + - : typeclass_instances.
+ Global Arguments construct_enum {_ _ _ _ _ _}.
+
+ (* NOTE Place design:
+ - place access should always directly go to one variant, or to the tag.
+ - don't allow strong updates, just as for array.
+
+ We should then have one place type that encapsulates the enum.
+ Main point: we need to pad it properly.
+ That shouldn't be a big point though, because we do not expose this part of the representation.
+ It should not need its own type/place type.
+ We do not need to treat with these types independelty etc.
+ Maybe having some core abstraction for that would make sense though.
+
+ *)
+
+
+ (*
+ When reading the discriminant: want to get the integer associated to the variant, because we need it for a switch.
+ When initializing an enum value with EnumInit: need to map from the variant to the full type. i.e. need to invert the map we currently have? that sounds complicated.
+ When reading a field: just need to get the field refinement, we can do that now.
+
+
+ For initialization:
+ interpret rust type, require it to syntactically be enum e : type rt
+ Then find the typeclass instance for ConstructEnum using tc_..
+ get the output refinement.
+ Then can directly construct it.
+ *)
+
+ (* Q: when accessing, how do we unfold it?
+ Should we have a variant of [enum] for ltypes?
+ I guess, maybe.
+ Or maybe have an ltype override parameter. That seems easier.
+ However, then we get nasty dependent typing, since the type of that parameter has to depend on the type of the refinement..
+
+ I guess we should just fix the ltype to have a specific variant. Then it's just dependent on another parameter.
+ This anyways makes sense, semantically.
+ *)
+
+ (* NOTE: for now, we only support untyped reads from enums.
+ To handle this more accurately, we should probably figure out the proper model for enums with niches etc first. *)
+ Definition is_enum_ot {rt} (en : enum rt) (ot : op_type) (mt : memcast_compat_type) :=
+ match ot with
+ | UntypedOp ly =>
+ ∃ el : struct_layout, use_enum_layout_alg en.(enum_els) = Some el ∧
+ ly = el ∧
+ foldr (λ '(v, st) P,
+ ∃ rty ly',
+ en.(enum_variant_ty) v = Some rty ∧
+ syn_type_has_layout st ly' ∧
+ ty_has_op_type (projT2 rty) (UntypedOp ly') mt
+ ) True (en.(enum_els).(els_variants))
+ | _ => False
+ end.
+
+
+ (* NOTE: in principle, we might want to formulate this with [ex_plain_t] as an existential abstraction over a struct.
+ However, here the inner type also depends on the outer refinement, which is not supported by [ex_plain_t] right now. *)
+ Program Definition enum_t {rt} (e : enum rt) : type rt :=
+ {|
+ ty_own_val π r v :=
+ (∃ rt' ty' r' ly,
+ ⌜e.(enum_ty) r = existT rt' (ty', r')⌠∗
+ ⌜syn_type_has_layout e.(enum_els) ly⌠∗
+ (* we cannot directly borrow the variant or data fields while in this interpretation *)
+ v â—áµ¥{Ï€} -[#(enum_lookup_tag e r); #r'] @ struct_t (sls_of_els e.(enum_els))
+ +[int e.(enum_els).(els_tag_it); active_union_t ty' (e.(enum_tag) r) (uls_of_els e.(enum_els))])%I;
+ ty_shr κ π r l :=
+ (∃ rt' ty' r' ly,
+ ⌜e.(enum_ty) r = existT rt' (ty', r')⌠∗
+ ⌜syn_type_has_layout e.(enum_els) ly⌠∗
+ l â—â‚—{Ï€, κ} -[#(enum_lookup_tag e r); #r'] @ struct_t (sls_of_els e.(enum_els))
+ +[int e.(enum_els).(els_tag_it); active_union_t ty' (enum_tag e r) (uls_of_els e.(enum_els))])%I;
+ ty_syn_type := e.(enum_els);
+ ty_has_op_type ot mt :=
+ is_enum_ot e ot mt;
+ ty_sidecond := True%I;
+ ty_ghost_drop π r := True%I; (* TODO *)
+ ty_lfts := e.(enum_lfts);
+ ty_wf_E := e.(enum_wf_E);
+ |}.
+ Next Obligation.
+ iIntros (rt e π r v).
+ iIntros "(%rt' & %ty' & %r' & %ly & %Heq & %Halg & Hv)".
+ specialize (syn_type_has_layout_els_sls _ _ Halg) as (sl & Halg' & ->).
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv".
+ { simpl. by apply use_struct_layout_alg_Some_inv. }
+ iExists sl. done.
+ Qed.
+ Next Obligation.
+ Admitted.
+ Next Obligation.
+ eauto.
+ Qed.
+ Next Obligation.
+ iIntros (rt e κ π l r) "(%rt' & %ty' & %r' & %ly & %Heqt & %Halg & Hl)".
+ iPoseProof (ty_shr_aligned with "Hl") as "(%ly' & %Hly & %Halg')". simpl in *.
+ specialize (syn_type_has_layout_els_sls _ _ Halg) as (sl & Halg'' & ->).
+ apply use_struct_layout_alg_Some_inv in Halg''.
+ assert (ly' = sl) as -> by by eapply syn_type_has_layout_inj.
+ iExists sl. done.
+ Qed.
+ Next Obligation.
+ iIntros (rt e E κ l ly π r q ?) "#CTX Htok %Halg %Hly Hlb Hb".
+ iAssert (&{κ} ((∃ (rt' : Type) (ty' : type rt') (r' : rt') (ly0 : layout), ⌜enum_ty e r = existT rt' (ty', r')⌠∗ ⌜syn_type_has_layout (enum_els e) ly0⌠∗ ∃ v : val, l ↦ v ∗ v â—áµ¥{ Ï€} -[# (enum_lookup_tag e r); # r'] @ struct_t (sls_of_els (enum_els e)) +[int (els_tag_it (enum_els e)); active_union_t ty' (enum_tag e r) (uls_of_els (enum_els e))])))%I with "[Hb]" as "Hb".
+ { iApply (bor_iff with "[] Hb"). iNext. iModIntro.
+ iSplit.
+ - iIntros "(%v & Hl & % & % & % & % & ? & ? & ?)". eauto 8 with iFrame.
+ - iIntros "(% & % & % & % & ? & ? & % & ? & ?)". eauto 8 with iFrame. }
+ simpl. iEval (rewrite -lft_tok_sep) in "Htok". iDestruct "Htok" as "(Htok1 & Htok2)".
+ iApply fupd_logical_step.
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iMod (bor_exists_tok with "LFT Hb Htok1") as "(%rt' & Hb & Htok1)"; first done.
+ iMod (bor_exists_tok with "LFT Hb Htok1") as "(%ty' & Hb & Htok1)"; first done.
+ iMod (bor_exists_tok with "LFT Hb Htok1") as "(%r' & Hb & Htok1)"; first done.
+ iMod (bor_exists_tok with "LFT Hb Htok1") as "(%ly' & Hb & Htok1)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Heqt & Hb)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Halg & Hb)"; first done.
+ iMod (bor_persistent with "LFT Heqt Htok1") as "(>%Heqt & Htok1)"; first done.
+ iMod (bor_persistent with "LFT Halg Htok1") as "(>%Halg' & Htok1)"; first done.
+ iPoseProof (list_incl_lft_incl_list (ty_lfts ty') (enum_lfts e)) as "Hincl".
+ { etrans; last eapply (enum_lfts_complete _ e r). rewrite Heqt. done. }
+ iMod (lft_incl_acc with "Hincl Htok2") as "(%q' & Htok2 & Htok2_cl)"; first done.
+ iPoseProof (lft_tok_lb with "Htok1 Htok2") as "(%q'' & Htok1 & Htok2 & Htok_cl)".
+ iCombine ("Htok1 Htok2") as "Htok".
+ rewrite !lft_tok_sep.
+ specialize (syn_type_has_layout_els_sls _ _ Halg) as (sl & Halg'' & ->).
+ iPoseProof (ty_share _ E _ _ _ _ _ q'' with "[$] [Htok] [] [] Hlb Hb") as "Hstep"; first done.
+ { simpl. rewrite right_id. done. }
+ { simpl. iPureIntro. by apply use_struct_layout_alg_Some_inv. }
+ { done. }
+ simpl.
+ iApply logical_step_fupd.
+ iApply (logical_step_wand with "Hstep").
+ iModIntro. iIntros "(Hl & Htok)".
+ rewrite right_id -lft_tok_sep. iDestruct "Htok" as "(Htok1 & Htok2)".
+ iPoseProof ("Htok_cl" with "Htok1 Htok2") as "(Htok1 & Htok2)".
+ iMod ("Htok2_cl" with "Htok2") as "Htok2".
+ rewrite -lft_tok_sep. iFrame.
+ iExists rt', ty', r', _.
+ iR. iR. by iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (rt e κ κ' π r l) "#Hincl (%rt' & %ty' & %r' & %ly & ? & ? & Hl)".
+ iExists rt', ty', r', ly. iFrame.
+ iApply (ty_shr_mono with "Hincl Hl").
+ Qed.
+ Next Obligation.
+ iIntros (rt e π r v F ?) "Hv".
+ iApply logical_step_intro. done.
+ Qed.
+ Next Obligation.
+ iIntros (rt e ot mt st π r v ?) "Hl".
+ (*done.*)
+ (*Qed.*)
+ Admitted.
+
+ (* TODO non-expansiveness *)
+
+
+ Global Instance enum_t_copyable {rt} (e : enum rt):
+ (∀ r : rt, Copyable (projT2 (e.(enum_ty) r)).1) →
+ Copyable (enum_t e).
+ Proof.
+ (* TODO *)
+ Admitted.
+End enum.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ (* TODO: should probably have a subtyping condition on enum that lifts this element-wise. *)
+
+End subtype.
+
+Section unfold.
+ Context `{!typeGS Σ}.
+
+ (* TODO *)
+End unfold.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ (* TODO move *)
+ Lemma mjoin_pad_struct_layout sl els f :
+ Forall2 (λ '(n, ly) v, v `has_layout_val` ly) (named_fields sl.(sl_members)) els →
+ (∀ ly, length (f ly) = ly_size ly) →
+ mjoin (pad_struct sl.(sl_members) els f) `has_layout_val` sl.
+ Proof.
+ rewrite /has_layout_val/layout_of{2}/ly_size/=.
+ generalize (sl_members sl) => fields. clear sl.
+ induction fields as [ | [[name | ] field] fields IH] in els |-*; simpl; first done.
+ - intros Ha Hf. apply Forall2_cons_inv_l in Ha as (v & els' & Hlen & Ha%IH & ->); last done.
+ rewrite app_length Ha Hlen. done.
+ - intros Ha Hf. apply IH in Ha; last done. rewrite app_length Ha Hf//.
+ Qed.
+
+ Lemma big_sepL2_pad_struct (tys : list (sigT (λ rt, (type rt * rt)%type))) (els : list val) (defty : layout → sigT _) (defval : layout → val) fields Φ :
+ ([∗ list] i ↦ v; ty ∈ els; tys, ∃ j, ⌜field_index_of fields (named_fields fields !!! i).1 = Some j⌠∗ Φ j v ty) -∗
+ ([∗ list] i ↦ v; ty ∈ pad_struct fields els defval; pad_struct fields tys defty, Φ i v ty) : iProp Σ.
+ Proof.
+ iIntros "Ha". iPoseProof (big_sepL2_length with "Ha") as "%Hleneq".
+ iInduction els as [ | el els] "IH"; destruct tys as [ | ty tys].
+ (* TODO *)
+ Abort.
+
+ Lemma type_enum_init π E L (els : enum_layout_spec) (variant : string) (rsty : rust_type) (e : expr) (T : typed_val_expr_cont_t) :
+ ⌜enum_layout_spec_is_layoutable els⌠∗
+ typed_val_expr π E L e (λ L2 v rti tyi ri,
+ ⌜((list_to_map (els_variants els) : gmap _ _) !! variant) = Some (ty_syn_type tyi)⌠∗
+ ∃ M, named_lfts M ∗ (named_lfts M -∗
+ (* get the desired enum type *)
+ li_tactic (interpret_rust_type_goal M rsty) (λ '(existT rto tyo),
+ ∃ (e : enum rto), ⌜tyo = enum_t e⌠∗ ⌜e.(enum_els) = els⌠∗
+ trigger_tc (ConstructEnum e variant tyi ri) (λ ro,
+ (*⌜construct_enum_sc⌠∗*)
+ ∀ v', T L2 v' _ (enum_t e) ro))))
+ ⊢ typed_val_expr π E L (EnumInit els variant rsty e) T.
+ Proof.
+ iIntros "(%Hly & HT)". destruct Hly as [el Hly].
+ iIntros (?) "#CTX #HE HL Hc".
+ iApply wp_enum_init; first done.
+ iApply ("HT" with "CTX HE HL [Hc]").
+ iIntros (L2 v rt ty r) "HL Hv HT".
+ iDestruct "HT" as "(%Hlook_st & %M & Hlfts & HT)".
+ iPoseProof ("HT" with "Hlfts") as "HT".
+ rewrite /interpret_rust_type_goal.
+ iDestruct "HT" as "(%rto & %tyo & %en & -> & <- & HT)".
+ rewrite /trigger_tc. iDestruct "HT" as "(%ro & %Hc & HT)".
+ iApply ("Hc" with "HL [Hv] HT").
+ iEval (rewrite /ty_own_val/=).
+ destruct Hc as [[Hproj Htag]].
+ iExists _, _, _, _.
+ iR. iSplitR. { iPureIntro. apply use_enum_layout_alg_Some_inv. apply Hly. }
+ iEval (rewrite /ty_own_val/=).
+ iExists el. iSplitR. { iPureIntro. apply use_enum_layout_alg_inv'. done. }
+ iPoseProof (ty_has_layout with "Hv") as "(%ly & %Hst & %Hlyv)".
+ iR.
+ iSplitR. { iPureIntro. apply mjoin_pad_struct_layout; first last.
+ { intros. rewrite replicate_length. done. }
+ apply use_enum_layout_alg_inv in Hly as (ul & variant_lys & Hul & Hsl & Hf).
+ apply struct_layout_alg_has_fields in Hsl. rewrite -Hsl.
+ econstructor.
+ { simpl.
+ (* TODO should make that property hold in els. *)
+ admit. }
+ econstructor; last done.
+ rewrite Hlook_st /use_layout_alg' Hst/=.
+ rewrite /use_union_layout_alg'.
+ erewrite use_union_layout_alg_Some; [ | done | done].
+ simpl.
+ rewrite /has_layout_val app_length replicate_length.
+ rewrite /has_layout_val in Hlyv. rewrite Hlyv.
+ enough (ly_size ly ≤ ly_size ul) by lia.
+ apply union_layout_alg_has_variants in Hul as ->.
+ apply elem_of_list_to_map_2 in Hlook_st.
+ apply elem_of_list_lookup_1 in Hlook_st as (i & Hlooki).
+ eapply Forall2_lookup_l in Hf; last done.
+ destruct Hf as ([name ly'] & Hul & -> & Hst').
+ assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+ rewrite {2}/ly_size /ul_layout/=.
+ apply max_list_elem_of_le. rewrite elem_of_list_fmap.
+ eexists. split; first done. apply elem_of_list_fmap.
+ exists (name, ly). split; first done.
+ by eapply elem_of_list_lookup_2.
+ }
+ rewrite reshape_join.
+ 2: { admit. }
+ (* TODO use big_sepL2_pad_struct *)
+ Admitted.
+
+ (* TODO: would really like to have this lemma instead, but the dependent typing for the evars is trouble *)
+ (*
+ Lemma type_enum_init π E L (els : enum_layout_spec) (variant : string) (rsty : rust_type) (e : expr) (T : typed_val_expr_cont_t) :
+ ⌜enum_layout_spec_is_layoutable els⌠∗
+ typed_val_expr π E L e (λ L2 v rti tyi ri,
+ ⌜((list_to_map (els_variants els) : gmap _ _) !! variant) = Some (ty_syn_type tyi)⌠∗
+ ∃ M, named_lfts M ∗ (named_lfts M -∗
+ (* get the desired enum type *)
+ li_tactic (interpret_rust_type_goal M rsty) (λ '(existT rto tyo),
+ ∃ (e : enum rto), ⌜tyo = enum_t e⌠∗ ⌜e.(enum_els) = els⌠∗
+ ∃ rti' tyi', ⌜e.(enum_variant_ty) variant = Some (existT rti' tyi')⌠∗
+ (* TODO also need syntypes to be compatible *)
+ ∃ ri' : rti', owned_subtype π E L2 false ri ri' tyi tyi' (λ L3,
+ trigger_tc (ConstructEnum e variant tyi' ri') (λ ro,
+ (*⌜construct_enum_sc⌠∗*)
+ ∀ v', T L3 v' _ (enum_t e) ro))))) -∗
+ typed_val_expr π E L (EnumInit els variant rsty e) T.
+ Proof.
+ iIntros "(%Hly & HT)". destruct Hly as [el Hly].
+ iIntros (?) "#CTX #HE HL Hc".
+ iApply wp_fupd.
+ iApply wp_enum_init; first done.
+ iApply ("HT" with "CTX HE HL [Hc]").
+ iIntros (L2 v rt ty r) "HL Hv HT".
+ iDestruct "HT" as "(%Hlook_st & %M & Hlfts & HT)".
+ iPoseProof ("HT" with "Hlfts") as "HT".
+ rewrite /interpret_rust_type_goal.
+ iDestruct "HT" as "(%rto & %tyo & %en & -> & <- & HT)".
+ iDestruct "HT" as "(%rti' & %tyi' & %Hlook & %ri' & HT)".
+ iMod ("HT" with "[] [] CTX HE HL") as "(%L3 & HP & HL & HT)"; [done.. |].
+ iDestruct "HP" as "(%Hly' & _ & Hincl)".
+ iPoseProof (ty_has_layout with "Hv") as "(%ly & %Hst & %Hlyv)".
+ iPoseProof ("Hincl" with "Hv") as "Hv".
+ rewrite /trigger_tc. iDestruct "HT" as "(%ro & %Hc & HT)".
+ iApply ("Hc" with "HL [Hv] HT").
+ iEval (rewrite /ty_own_val/=).
+ destruct Hc as [[Hproj Htag]].
+ iExists _, _, _, _.
+ iR. iSplitR. { iPureIntro. apply use_enum_layout_alg_Some_inv. apply Hly. }
+ iEval (rewrite /ty_own_val/=).
+ iExists el. iSplitR. { iPureIntro. apply use_enum_layout_alg_inv'. done. }
+ iPoseProof (ty_has_layout with "Hv") as "(%ly2 & %Hst2 & %Hlyv2)".
+ iR.
+ iSplitR. { iPureIntro. apply mjoin_pad_struct_layout; first last.
+ { intros. rewrite replicate_length. done. }
+ apply use_enum_layout_alg_inv in Hly as (ul & variant_lys & Hul & Hsl & Hf).
+ apply struct_layout_alg_has_fields in Hsl. rewrite -Hsl.
+ econstructor.
+ { simpl.
+ (* TODO should make that property hold in els. *)
+ admit. }
+ econstructor; last done.
+ rewrite Hlook_st /use_layout_alg'/= Hst/=.
+ rewrite /use_union_layout_alg'.
+ erewrite use_union_layout_alg_Some; [ | done | done].
+ simpl.
+ rewrite /has_layout_val app_length replicate_length.
+ rewrite /has_layout_val in Hlyv. rewrite Hlyv.
+ enough (ly_size ly ≤ ly_size ul) by lia.
+ apply union_layout_alg_has_variants in Hul as ->.
+ apply elem_of_list_to_map_2 in Hlook_st.
+ apply elem_of_list_lookup_1 in Hlook_st as (i & Hlooki).
+ eapply Forall2_lookup_l in Hf; last done.
+ destruct Hf as ([name ly'] & Hul & -> & Hst').
+ assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+ rewrite {2}/ly_size /ul_layout/=.
+ apply max_list_elem_of_le. rewrite elem_of_list_fmap.
+ eexists. split; first done. apply elem_of_list_fmap.
+ exists (name, ly). split; first done.
+ by eapply elem_of_list_lookup_2.
+ }
+ rewrite reshape_join.
+ 2: { admit. }
+ (* TODO use big_sepL2_pad_struct *)
+ Admitted.
+ *)
+
+End rules.
+
+
+(* In a module, because having it in the top-level path will break the Ltac2 for looking up definitions when we actually verify stuff using Option. *)
+Module enum_test.
+ (*
+ Section test.
+ Context `{!typeGS Σ}.
+ (* Example enum spec: option *)
+ Section std_option_Option_els.
+ Definition std_option_Option_None_sls : struct_layout_spec := mk_sls "std_option_Option_None" [].
+
+ Definition std_option_Option_Some_sls T_st : struct_layout_spec := mk_sls "std_option_Option_Some" [
+ ("0", T_st)].
+
+ Program Definition std_option_Option_els (T_st : syn_type): enum_layout_spec := mk_els "std_option_Option" ISize [
+ ("None", std_option_Option_None_sls : syn_type);
+ ("Some", std_option_Option_Some_sls T_st : syn_type)] [("None", 0); ("Some", 1)] _.
+ Next Obligation. done. Qed.
+ Global Typeclasses Opaque std_option_Option_els.
+ End std_option_Option_els.
+ (* maybe we should represent this with a gmap for easy lookup? *)
+
+ Section std_option_Option_ty.
+ Context {T_rt : Type}.
+ Context (T_ty : type (T_rt)).
+
+ Definition std_option_Option_None_ty : type (plist place_rfn []) := struct_t std_option_Option_None_sls +[].
+ Definition std_option_Option_None_rt : Type := rt_of std_option_Option_None_ty.
+ Global Typeclasses Transparent std_option_Option_None_ty.
+
+ Definition std_option_Option_Some_ty : type (plist place_rfn [T_rt : Type]) := struct_t (std_option_Option_Some_sls (ty_syn_type T_ty)) +[
+ T_ty].
+ Definition std_option_Option_Some_rt : Type := rt_of std_option_Option_Some_ty.
+ Global Typeclasses Transparent std_option_Option_Some_ty.
+
+ Program Definition std_option_Option_enum : enum _ := mk_enum
+ ((std_option_Option_els (ty_syn_type T_ty)))
+ (λ rfn, match rfn with | None => "None" | Some x => "Some" end)
+ (λ rfn, match rfn with | None => existT _ (std_option_Option_None_ty, -[])| Some x => existT _ (std_option_Option_Some_ty, -[x])end)
+ (λ variant, if (decide (variant = "None")) then Some $ existT _ std_option_Option_None_ty else if decide (variant = "Some") then Some $ existT _ std_option_Option_Some_ty else None)
+ (ty_lfts T_ty)
+ (ty_wf_E T_ty)
+ _ _
+ .
+ Next Obligation.
+ intros []; simpl; set_solver.
+ Qed.
+ Next Obligation.
+ intros []; simpl; set_solver.
+ Qed.
+
+ Global Program Instance construct_enum_Some x : ConstructEnum (std_option_Option_enum) "Some" (std_option_Option_Some_ty) -[x] (Some (x)) :=
+ construct_enum _ _ .
+ Next Obligation. done. Qed.
+ Global Program Instance construct_enum_None : ConstructEnum (std_option_Option_enum) "None" (std_option_Option_None_ty) -[] None :=
+ construct_enum _ _.
+ Next Obligation. done. Qed.
+
+ Definition std_option_Option_ty : type _ := enum_t std_option_Option_enum.
+ Global Typeclasses Transparent std_option_Option_ty.
+ End std_option_Option_ty.
+ End test.
+ *)
+End enum_test.
+
+
+ (* Consideration (long term): how can we make this more realistic?
+
+ Main things we don't model:
+ - variant can be stored in a niche
+ - we don't know anything about the layout: in particular, assuming that the data is at offset zero, that there is an explicit variant field, etc. does not really match
+
+ Steps for making it better:
+ - syn_types should expose which of their bytes are padding bytes.
+ - layout algo can determine some arbitrary total size for the enum, and some arbitrary offsets for each of the variants
+ - also an arbitrary offset for the variant tag, as long as these bytes are seen as padding by all variants
+ - challenge: getting a pointsto for the variant, because it may overlap with padding bytes of an variant.
+ -> the type storing the active variant should expose the current variant.
+ types need to satisfy a law giving us pointstos for their padding bytes (temporarily), and the ownership predicate needs to be oblivious to that/ writing the type must not change the padding bytes.
+ -> the latter part seems strange, it is not really compatible with our current opsem, since uninit bytes are just garbled up.
+ -> point: they are not really uninit bytes, but should logically belong to some type (probably the one offering the padding), which is why they should not be treated as uninit by the opsem?
+ TODO look at what rustc does to make this work with LLVM
+ *)
+
+
+ (**
+ Plan for ltypes:
+ - raw_enum_ltype (e : enum rt) (lt : ltype ???) : ltype rt
+ + this is essentially unfolded, with a decoupled refinement
+ + This may just be a wrapper for unwrapped_ltype??? i.e. we have already opened the invariant. TODO.
+ + problem: if we do this naively, changing the variant will amount to a strong update.
+ => depending on whether we do a variant-changing access or not, this should amount to either unwrapped_ltype or opened_ltype.
+ TODO: think more about the design.
+
+ - unwrapped_ltype (lt1 : ltype rt) (lt2 : ltype rt) : ltype rt
+ + just captures what is necessary to go back from the (core of the) currently owned lt2 to the core lt1.
+ - we should just require going back from the core of lt2, since we may borrow somewhere in lt2, and we can't directly shift back the blocked thing.
+ - maybe use unblockable here?
+ + Q: can this also be used for the existential/invariant stuff?
+ difference: there we may not at all times have a vs to go back from the core, since we may temporarily break the invariant it.
+ if we are below a mutref there, we really need to open the mutref, and that should relax the typed_place_cond requirement below.
+ => I don't think these are the same. They have quite different features in terms of what requirements they pose/ what they ensure in turn.
+ - pad_ltype (st : syn_type) (lt : ltype rt) : ltype rt
+ + this wraps the inner ltype and adds trailing padding.
+ - opened_ltype (lt1 : ltype rt1) (lt2 : ltype rt2) (P : iProp Σ) (Q : iProp Σ) : ltype rt2
+ + used for existentials/invariants. this is different from unwrapped_ltype, as noted above.
+ + can only be directly at the top-level (below one level of references), not deeper.
+ + P are the additional resources needed to go back to lt1? and Q is what we obtain in addition if we do so.
+ - P may also need to depend on the current refinement.
+ - Q may also depend on the refinement and some quantifiers in P?
+ e.g. P r := ∃ n, r = n > 0 ∗ na_tok ∅
+ Q r := na_tok my_inv
+ (for na_tok this uses that they directly compose with disjoint union, so these minimal choices work wlog)
+ +
+
+
+
+ General theme here: we need to provide overly specific ltypes because the unfolding equations will otherwise loose information.
+ - issue is when operating below mutable references: there loosing some information really is problematic, because we can't just conjure that up again when the lftlogic needs to shift back => in general, we can't go weaker than ltype_eq, which is what we use currently.
+ - can we provide a general "wrapper ltype" that collects some of the lost information so we can shift back?
+ e.g. wrap lt1 lt2 actually contains lt2 below + information to shift lt2 back to lt1. then we could safely do things like
+ ◠(active_union ...) ⇠unwrap (◠active_union ..) (◠pad_type ...) ⇠unwrap (◠active_union ..) (pad_ltype ..)
+ i.e. wrap effectively contains a viewshift? and the core is just the lt1?
+ => this has quite some similarity with what is needed for the existentials + invariants.
+ the funny thing is that it again makes a second field explicit, which is what we originally did the whole core business with closed ltypes for (when blocking).
+ now we need it again for a different use case, because here we can't directly derive the core lt1 from lt2 (that's the whole point).
+ lt1 and lt2 need the same refinement type, because we might operate below mutrefs.
+
+
+
+ *)
+
+ (*
+ Procedure for unfolding/accessing:
+ - unfold enum to struct (this changes refinement already)
+ I won't get around that, either way. For mut and owned, go to OpenedLtype; for shared go to shadowed.
+ - for the tag, can now freely access and use it. we do not immediately need to re-establish anything when writing.
+ -
+
+ Q's for the data:
+ - what is the refinement after unfolding?
+ + option 1: same refinement as the enum -> VariantLtype
+ + option 2: just the data, i.e. refinement of the particular variant
+ -
+
+ VariantLtype (e : enum rt) (lt : ltype rt'): ltype rt
+ - requires that rt' = projT1 (enum_ty r) at refinement r.
+ - otherwise, does not require anything about the relation of lt to enum_ty r
+ => this seems unnatural.
+
+ VariantLtype (e : enum rt) (variant: string) (lt : ltype (rfn_of_variant e variant)): ltype rt
+ - would just unfold into active union on variant changes, i.e. similar to refinedc if we
+ => the delta to ActiveUnion is just that we carry the enum with us.
+
+ ActiveUnionLtype {rt} (uls : union_layout_spec) (variant : string) (lt : ltype rt) : ltype rt
+ - just pads lt according to the variant in uls.
+ - changing variant is a strong update here, but that is fine since we are encapsulated by the outer enum_t which supports that.
+ => Q: this doesn't retain information on the enum, so how do we get back? Is there enough stuff to guide the typing rules?
+ + concretely: we will stratify it, and stratification won't do much on the active enum itself.
+ then we get [variant, data] @ struct [tag , active_union ]
+ we have nothing here to tell us that this should be folded into a enum. additional difficulty: there may be blocked things below.
+ one thing we can do: stratification instances should trigger a subsume.
+ i.e. compute core of the current thing (needs to correctly descend below active_union!)
+ then require
+
+ -
+
+
+ Does anything get easier if we don't allow variant changes?
+ - VariantLtype could have a fixed variant parameter and require that the refinement-specified variatn matches it.
+ That way, we would have a natural way of specifying the type of the ltype.
+ -> this is also not totally incompatible with variant changes.
+
+ ======
+
+ Other approach: all of the considerations above allow quite a lot of freedom. But why do we need that?
+ - one idea: instead of having to access the data + variant separately, have a dedicated op that fuses the two and skips the union entirely.
+ i.e. have a data{els, variant} operation that fuses the struct offset + union offset.
+
+ UnfoldedEnumLtype (e : enum rt) (tag_variant data_variant : string) {rt'} (lt : ltype rt') : ltype rt'
+ - owns the whole enum struct.
+ - tag_variant controls the tag, but it is otherwise completely decoupled.
+ changes to either type of data or change to tag will constitute strong updates.
+ - data_variant controls the offset/padding for lt within the union
+ - â— enum unfolds into OpenedLtype (FixedEnumLtype ...) .. and
+ we can fold back if the rt' matches the type specified by tag_variant and the variants match.
+ - if we access data from it with a particular variant that does not match the actual one, we flush to uninit for that.
+ Pro:
+ - this interface seems pretty agnostic to the concrete representation. It doesn't really leak to the outside that there's a union.
+ - gives a lot of syntactic guidance. It's very clear how stratification can deal with this.
+ Con:
+ - it seems like a big ugly blob.
+
+ IF I can require that on a variant change, the write of the variatn struct will happen in one step, I can also do:
+ UnfoldedEnumLtype (e : enum rt) (tag_variant data_variant : string) (lt : ltype (rt_of data_variant)) : ltype rt
+ Reasoning: To the recursive access, I give the uninit (with a refinement which would not fit the pattern), but in the continuation I require that the refinement type matches the updated variant type.
+ TODO: is that requirement sensible? look at MIR translation
+
+ Something similar for Shared?
+ ShrUnfoldedEnumLtype (e : enum rt) (variant : string) (lt : ltype (rt_of variant)) : ltype rt
+ => for the latter variant above, we could also just merge this - they are not so different. We could just require the two variants to be the same for the shared case.
+
+
+ I think I like this approach more than the refinedc-style union approach. We should morally not rely too much on unions, and this restricted set of operations seems quite sensible compared to the very flexible appraoch of refiendc, which allows much stuff whihc we don't need to care about in Rust.
+
+ *)
+
+
+ (** essentially just a wrapper around int *)
+ (* TODO can we erase the "extra data" from the refinement?
+ currently, this would be refined by [Some ...], and the [...] doesn't really matter.
+
+ Alternatives: refine by variant number, or variant tag.
+ -> variant tag seems sensible.
+ *)
+ (*
+ Program Definition tag_t {rt} (e : enum rt) : type string := {|
+ st_own Ï€ r v := (v â—áµ¥{Ï€} e.(enum_tag_int) r @ int e.(enum_els).(els_tag_it))%I;
+ st_syn_type := IntSynType e.(enum_els).(els_tag_it);
+ st_has_op_type ot mt := is_int_ot ot e.(enum_els).(els_tag_it);
+ |}.
+ Next Obligation.
+ iIntros (rt e π r v) "Hown". iApply (ty_has_layout with "Hown").
+ Qed.
+ Next Obligation.
+ iIntros (rt e ot mt Hot). simpl.
+ rewrite (is_int_ot_layout _ _ Hot).
+ apply syn_type_has_layout_int; first done.
+ apply els_tag_it_size.
+ Qed.
+ Next Obligation.
+ iIntros (rt e ot mt st π r v Hot) "Hown".
+ by iApply (ty_memcast_compat with "Hown").
+ Qed.
+ *)
+ (* reading the discriminant should give us something typed at [tag_t en].
+ - we should then be able to switch on it, and know that we cannot fall into the default case, if we match exhaustively.
+ => The tag type should carry a bound on the range.
+ => refinement: either the full refinement of the enum, or the name of the tag. TODO
+ - after switching (knowing that the refinement has a particular value/particular variant), we should be able to focus the data field to one particular variant.
+ => we have a enum_ltype that describes the special link between the variant field and which variant is active in the data field. we need special access operations for it.
+ => focussing one variant should be part of the place access when accessing the data field. after that, it should behave the same as an ordinary struct field.
+ - what happens with the enum ltype when the variant update and the data update happen separately?
+ => we temporarily break its invariant. so, potentially the unfolded enum type should be more relaxed/ have less invariants?
+ *)
+
+ (*
+ Lemma has_layout_val_ly_offset_inv v ly o :
+ (drop o v) `has_layout_val` (ly_offset ly o) →
+ v `has_layout_val` ly ∨ (ly_size ly ≤ o ∧ length v ≤ o).
+ Proof.
+ rewrite /has_layout_val. rewrite drop_length.
+ destruct ly as [sz al].
+ rewrite /ly_offset /ly_size /=.
+ intros ?. destruct (decide (length v = sz)); first by left. right. lia.
+ Qed.
+ *)
+
+ (** [active_union_t ty uls] basically wraps [ty] to lay it out in [uls], asserting that a union currently is in variant [variant].
+ This is not capturing the allowed union layouting in Rust in full generality (Rust may freely choose the offsets of the variants),
+ but we are anyways already not handling tags correctly, so who cares... *)
+ (* TODO rather factor out into a padded type, as in RefinedC? *)
+ (*
+ Program Definition enum_variant_t {rt} (e : enum rt) (variant : string) : type rt := {|
+ ty_own_val π r v :=
+ (∃ ul ly, ⌜use_union_layout_alg uls = Some ul⌠∗
+ ⌜layout_of_union_member variant ul = Some ly⌠∗
+ take ly.(ly_size) v â—áµ¥{Ï€} r @ ty ∗
+ drop ly.(ly_size) v â—áµ¥{Ï€} () @ uninit (UntypedSynType (ly_offset (ul : layout) ly.(ly_size))))%I;
+ ty_syn_type := uls;
+ ty_has_op_type ot mt :=
+ (* we should not directly read from/write to this *)
+ (* TODO: really? *)
+ False;
+ ty_shr κ π r l :=
+ (∃ ul ly, ⌜use_union_layout_alg uls = Some ul⌠∗
+ ⌜layout_of_union_member variant ul = Some ly⌠∗
+ ⌜l `has_layout_loc` ul⌠∗
+ l â—â‚—{Ï€, κ} r @ ty ∗
+ (l +â‚—ly.(ly_size)) â—â‚—{Ï€, κ} () @ uninit (UntypedSynType (ly_offset (ul : layout) ly.(ly_size))))%I;
+ ty_ghost_drop r := ty.(ty_ghost_drop) r;
+ ty_lfts := [];
+ ty_wf_E := [];
+ ty_sidecond := True;
+ |}.
+ Next Obligation.
+ iIntros (rt ty var uls π r v) "(%ul & %ly & % & % & Hv & Hvr)".
+ iExists ul.
+ iSplitR. { iPureIntro. by apply use_union_layout_alg_Some_inv. }
+ iPoseProof (ty_has_layout with "Hv") as "(%ly' & %Halg0 & %Hv0)".
+ rewrite uninit_own_spec. iDestruct "Hvr" as "(% & %Halg1 & %Hv1)".
+ iPureIntro. apply syn_type_has_layout_untyped_inv in Halg1 as (-> & _ & _).
+ Admitted.
+ Next Obligation.
+ done.
+ Qed.
+ Next Obligation.
+ eauto.
+ Qed.
+ Next Obligation.
+ iIntros (????????) "(%ul & %ly & % & % & % & _)". iExists ul.
+ iSplitR; first done. iPureIntro. by eapply use_union_layout_alg_Some_inv.
+ Qed.
+ Next Obligation.
+ iIntros (rt ty variant uls E κ l ly π r q ?) "CTX Htok %Halg %Hly #Hlb Hb".
+ Admitted.
+ Next Obligation.
+ iIntros (rt ty variant uls κ κ' π r l) "#Hincl Hb".
+ Admitted.
+ Next Obligation.
+ iIntros (?????????) "Hb".
+ iDestruct "Hb" as "(%ul & %ly & %Halg & %Hly & Hv & _)".
+ iPoseProof (ty_own_ghost_drop with "Hv") as "Ha"; last iApply (logical_step_wand with "Ha"); eauto.
+ Qed.
+ Next Obligation.
+ done.
+ Qed.
+ *)
+ (* basically, all borrowing of components of an enum should happne at the level of the struct for a variants' components;
+ therefore, we don't need to do any of the handling here.
+ can we directly use place lemmas for structs? -- we still need an extra ltype that keeps trakc of that unfolding, so we can go back.
+ *)
diff --git a/theories/rust_typing/examples/loops.v b/theories/rust_typing/examples/loops.v
new file mode 100644
index 0000000000000000000000000000000000000000..6a07bd08025fecd62fec7529fe3f5fcc18c0b10f
--- /dev/null
+++ b/theories/rust_typing/examples/loops.v
@@ -0,0 +1,127 @@
+From refinedrust.automation Require Import ident_to_string.
+From iris.proofmode Require Import string_ident.
+From refinedrust Require Import typing.
+
+(** Some loop experiments *)
+
+Section loop1.
+Context `{!typeGS Σ}.
+
+(** Example 1 *)
+
+(*
+ fn loop1() {
+ let mut x = 1;
+ let mut y = 1;
+ loop {
+ #[invariant(x = y)]
+ x += 1;
+ y += 1;
+ }
+ }
+*)
+
+
+Definition loop1_def : function := {|
+ f_args := [
+ ];
+ f_local_vars := [
+ ("__0", (layout_of unit_sl) : layout);
+ ("x", (it_layout i32) : layout);
+ ("y", (it_layout i32) : layout);
+ ("__3", (layout_of unit_sl) : layout);
+ ("__4", (layout_of unit_sl) : layout)
+ ];
+ f_code :=
+ <["_bb1" :=
+ Goto "_bb2"
+ ]>%E $
+ <["_bb0" :=
+ "x" <-{ IntOp i32 } i2v (1) i32;
+ "y" <-{ IntOp i32 } i2v (1) i32;
+ (* put loop invariant annotation here *)
+ (*annot: (InitLoopAnnot loop1_bb1_invariant loop1_bb1_EL_invariant);*)
+ annot: InitLoopAnnot;
+ Goto "_bb1"
+ ]>%E $
+ <["_bb2" :=
+ "x" <-{ IntOp i32 } (use{ IntOp i32 } ("x")) +{ IntOp i32 , IntOp i32 } (i2v (1) i32);
+ "y" <-{ IntOp i32 } (use{ IntOp i32 } ("y")) +{ IntOp i32 , IntOp i32 } (i2v (1) i32);
+ "__4" <-{ UntypedOp ((layout_of unit_sl)) } zst_val;
+ Goto "_bb1"
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+Definition type_of_loop1 :=
+ fn(∀ _ : unit, (λ Ï, []); True)
+ → ∃ _ : unit, () @ unit_t; True.
+
+(* functional invariant to establish at the start of bb1 *)
+(* TODO: initialization status changes the refinement type.
+ Check whether we should try to infer that in the frontend, or whether we should just deinitialize everything that might not be needed beforehand via annotations (this seems easier to determine in the frontend);
+ point in particular: this may differ depending on which branch we took beforehand.
+ StorageDead instructions may be useful for that.
+*)
+Definition loop1_bb1_invariant (l_0 : place_rfn unit) (x : place_rfn Z) (y : place_rfn Z) (l_3 : place_rfn unit) (l_4 : place_rfn unit) : iProp Σ :=
+ ∃ x' y', ⌜x = PlaceIn x'⌠∗ ⌜y = PlaceIn y'⌠∗ ⌜x' = y'âŒ.
+
+Definition loop1_bb1_EL_invariant (E : elctx) (L : llctx) :=
+ True.
+
+Definition loop1_inv_map : bb_inv_map_t :=
+ PolyCons ("_bb1", (wrap_inv loop1_bb1_invariant, wrap_inv loop1_bb1_EL_invariant)) (PolyNil).
+
+
+Lemma loop1_dummy_context π :
+ ⊢ typed_function π loop1_def type_of_loop1.
+Proof.
+ intros.
+
+ set (loop_inv_map := BB_INV_MAP loop1_inv_map).
+
+ iStartProof.
+ start_function "loop1" ( ? ).
+ intros local___0 local_x local_y local___3 local___4.
+ prepare_parameters ( ).
+ init_lfts ( ∅ ).
+ repeat liRStep; liShow.
+ iApply typed_stmt_annot_skip.
+ do 1 liRStep; liShow.
+ rewrite {1}/Hinv__bb1.
+ do 9 liRStep.
+ liShow.
+ (* TODO need instances for subltype *)
+
+ (* TODO: check if the invariant may be too strong, in the sense that after one iteration we have something weaker? *)
+
+ (* TODO: add the named_lfts and the credit_store. *)
+
+
+Abort.
+
+(* Typing rule design:
+ - have a lemma
+
+
+
+
+(**
+ How can we get subtyping to work?
+ - I don't want to put subtyping directly in the invariant, which would be the straightforward way to establish it.
+ This would require inverting subtyping in the loop, which would be really nasty.
+ - Can we say: subtype E L (my_loop_inv E L) or so?
+ i.e. formulate it as: we can do subtyping and then have to show the invariant.
+ ideally would like some commuting rules here, i.e.
+ - first instantiate the existentials below the subtype with evars,
+ - then distribute the subtype over the the separating conj,
+ so that we can then apply the normal rules.
+
+
+ subtype E L P :=
+ elctx_interp E -∗ llctx_interp L -∗ P ∗ llctx_interp L
+
+
+
+ *)
diff --git a/theories/rust_typing/examples/rust.v b/theories/rust_typing/examples/rust.v
new file mode 100644
index 0000000000000000000000000000000000000000..6e8a6b3b9d21aeb5d740d95b77e33935647344e6
--- /dev/null
+++ b/theories/rust_typing/examples/rust.v
@@ -0,0 +1,404 @@
+From caesium Require Import lang notation tactics.
+From lithium Require Export tactics.
+From refinedrust Require Import functions programs int references uninit automation products.
+
+Section lithium.
+ Context {Σ : gFunctors}.
+Context (named_lfts' : gmap Z Z → iProp Σ).
+Lemma foo :
+ True -∗ named_lfts' ∅ -∗ True.
+Proof.
+ iStartProof.
+ liEnforceInvariantAndUnfoldInstantiatedEvars.
+ liStep.
+ liStep. liStep. liStep.
+Abort.
+End lithium.
+
+
+Section rectype.
+
+
+End rectype.
+
+
+(** Generics *)
+Definition target `{LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [
+ ("abc", use_layout_alg' T_st)
+ ];
+ f_local_vars := [
+ ("__0", it_layout i32);
+ ("abc2", use_layout_alg' T_st)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "abc2" <-{UntypedOp (use_layout_alg' T_st)} use{UntypedOp (use_layout_alg' T_st)} "abc";
+ "__0" <-{ IntOp i32 } I2v (42) I32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+Definition source (target_loc : loc) : function := {|
+ f_args := [];
+ f_local_vars := [
+ ("__0", it_layout i32 : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ expr: Call target_loc [Val(I2v (42) I32)];
+ "__0" <-{ IntOp i32 } I2v (42) I32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+
+(* call it with a mutable reference *)
+Definition source_ref (target_loc : loc) : function := {|
+ f_args := [];
+ f_local_vars := [
+ ("__0", it_layout i32 : layout);
+ ("a", it_layout i32 : layout);
+ ("b", void* : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "a" <-{IntOp i32} I2v (42) I32;
+ annot: (StartLftAnnot "κ" []);
+ "b" <-{PtrOp} &ref{Mut, Some (RSTInt I32), "κ"} "a";
+ expr: Call target_loc [use{PtrOp} "b"];
+ annot: (EndLftAnnot "κ");
+ "__0" <-{ IntOp i32 } I2v (42) I32;
+ annot: (StratifyContextAnnot);
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+Module attempt2.
+ Context `{!typeGS Σ}.
+ Definition type_of_source :=
+ fn(∀ () : unit, (λ Ï, []); λ Ï€, True)
+ → ∃ (x) : (Z), x @ int i32; (λ π, True).
+ (* NOTE fixing the refinement type ahead. That is still fine, since it is already lifetime-invariant. *)
+ (* NOTE: We don't parameterize the type over the layout, since that will be resolved at call time.
+ But we parameterize over the syn_type, so that we can instantiate it with the same one in the [typed_function] proof. *)
+ Definition type_of_target (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ (T_ty, r) : type T_rt * T_rt, (λ Ï, []); r @ T_ty; λ Ï€, ⌜T_ty.(ty_syn_type) = T_st⌠∗ True)
+ → ∃ () : unit, 42 @ int i32; (λ π, True).
+
+ Lemma source_typed π target_loc :
+ (* the function_ptr type is monomorphic in the layout and requires a concrete instantiation *)
+ (* this also means that, if we call the same function with different instantiations, we will need multiple linking assumptions *)
+ target_loc â—áµ¥{Ï€} target_loc @ function_ptr [IntSynType i32] (type_of_target Z (IntSynType i32)) -∗
+ typed_function π (source target_loc) [IntSynType i32] type_of_source.
+ Proof.
+ iStartProof.
+ start_function "source" ( () ) => local_0.
+ intros.
+ init_tyvars (∅).
+ init_lfts (∅).
+ repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Qed.
+
+ Lemma source_ref_typed π target_loc :
+ (* the function_ptr type is monomorphic in the layout and requires a concrete instantiation *)
+ (* this also means that, if we call the same function with different instantiations, we will need multiple linking assumptions *)
+ (* for a mutable reference to an i32 *)
+ target_loc â—áµ¥{Ï€} target_loc @ function_ptr [PtrSynType] (type_of_target (place_rfn Z * gname) (PtrSynType) ) -∗
+ (* for a shared reference to an i32 *)
+ (*target_loc â—áµ¥{Ï€} target_loc @ function_ptr [void* : layout] (type_of_target (place_rfn Z)) -∗*)
+ typed_function π (source_ref target_loc) [IntSynType i32; IntSynType i32; PtrSynType] type_of_source.
+ Proof.
+ iStartProof.
+ start_function "source" ( () ) => local_0 local_a local_b.
+ intros.
+ init_tyvars (∅).
+ init_lfts (∅).
+ repeat liRStep; liShow.
+
+ (* TODO: subtyping here should ideally hold. Currently it doesn't because of syntypes in return. *)
+
+ (* Now I didn't get any drop information on the ghost var.
+ In principle, I should get drop information from target, phrased generically. *)
+
+ (* TODO *)
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ Lemma target_typed π (T_rt : Type) T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (target T_st) [IntSynType i32; T_st] (type_of_target T_rt T_st).
+ Proof.
+ intros.
+ start_function "target" ( (T_ty & r) ) => arg_abc local_0 local_a.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+
+ (* TODO : for the first one, we will anyways need a property here that needs to be satisfied by all types (?)
+ - every type should be MCId and MCCopy at UntypedOp, because an UntypedOp memcast does nothing
+ - possibly: also also give each syntyep a canonical optype and require that types are compatible at MCCopy with that. (see notes on Ipad; would enable to use proper optypes on generic functions)
+
+
+ The latter point pertains in interesting ways to validity invariants.
+ The non-trivial optypes essentially check validity invariants. if our translation just uses Untyped for generics, we remove these validity checks (eg on loads) that Rust has.
+ But can they ever fail on generics anyways? And where would that error happen?
+ - if a value at generic type fails to satisfy a validity invariant, this should be an error of the context, because a generic function cannot make up such a thing out of thin air (?)
+ No: this does not hold true once I consider unsafe stuff like transmutation (but this is really sketchy, because I will not know anything about the generic..)
+ - everything that enters from the context is probably checked for validity at the call boundary already (doing a write to arguments, etc)
+ => The main issue I get from Untyped seems to be that I can do really sketchy casts and this is not caught by the semantics.
+ => This is just one more thing in our model that we don't handle, maybe.
+
+ But what would be the right way to verify it generically?
+ - one verification per syntactic type is clearly infeasible (there's an unbounded number due to structs)
+ - phrase a general condition (like I sketched above) and use proper optypes. Main difficulty: making sure that we can satisfy this condition for all the sematypes we are interested in. TODO;
+
+
+ Other thing: optypes for enums? What are valid bitpatterns for enums?
+
+ *)
+ Abort.
+
+ (* Now, can we actually instantiate the assumption on target that source poses?
+ - We assume that we have linked against the layout-monomorphic version, with the given argument layouts.
+ We get a corresponding [fntbl_entry f_loc (target (IntSynType i32))].
+ We can show that the arg_layouts of that match with what is assumed by function_ptr.
+ (because the layout alg will be successful)
+ - Then we need to show typed_function for that. This is easy and directly follows from [target_typed].
+ We need to show that the syntypes of the arg match with the layout, which we essentially already showed in the previous step.
+ We also need to show that the layout alg is successful on allthe locally used stuff.
+ It doesn't require establishing any connection between the layout and the type.
+ (which is good, because at that time, I may not know the full type).
+ *)
+End attempt2.
+ *)
+
+Section structs2.
+ Context `{typeGS Σ}.
+
+ (* Goal: translate the following code:
+
+ struct foostruct<T> {
+ x : i32,
+ y : T
+ }
+
+ struct barstruct<T> {
+ z : i32,
+ w : foostruct<T>,
+ }
+
+
+ fn foo<T>(a : foostruct<T>) {
+
+ }
+
+ fn bar<T>(b : barstruct<T>) {
+ foo(b.w);
+ }
+
+
+ fn foobar() {
+ let x: foostruct<i32>;
+ x = foostruct {x: 43, y: 53};
+
+ let y: barstruct<i32>;
+ y = barstruct {z : 42, w : x};
+
+ bar(y);
+ }
+
+ fn foobaz() {
+ let x: foostruct<i32>;
+ x = foostruct {x: 43, y: 53};
+
+ // this is not valid
+ let y: barstruct<foostruct<i32>>;
+ y = barstruct {z : 432, w: foostruct {x : 342, y : foostruct {x : 34, y : 90 }}};
+ }
+ *)
+
+ Section foostruct_spec.
+ Context (T_st : syn_type).
+ Definition foostruct_sls : struct_layout_spec := mk_sls "foostruct" [("x", IntSynType i32); ("y", T_st)].
+ End foostruct_spec.
+
+ Section barstruct_spec.
+ Context (T_st : syn_type).
+ Definition barstruct_sls : struct_layout_spec := mk_sls "barstruct" [("z", IntSynType i32); ("w", foostruct_sls T_st : syn_type)].
+ End barstruct_spec.
+
+ Section foo_code.
+ Definition foo (T_st : syn_type) : function := {|
+ f_args := [
+ ("abc", use_layout_alg' (foostruct_sls T_st))
+ ];
+ f_local_vars := [
+ ("__0", use_layout_alg' (IntSynType i32))
+ ];
+ f_code :=
+ <["_bb0" :=
+ "__0" <-{ IntOp i32 } I2v (42) I32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+ End foo_code.
+
+ Section bar_code.
+ (* let's assume that bar also uses (T, T) *)
+ Definition bar (T_st : syn_type) (foo_loc : loc) : function := {|
+ f_args := [
+ ("b", use_layout_alg' (barstruct_sls T_st))
+ ];
+ f_local_vars := [
+ ("__0", use_layout_alg' UnitSynType);
+ ("a", use_layout_alg' (foostruct_sls T_st))
+ ];
+ f_code :=
+ <["_bb0" :=
+ "a" <-{use_op_alg' (foostruct_sls T_st)} use{use_op_alg' (foostruct_sls T_st)} ("b" at{barstruct_sls T_st} "w");
+ annot: StopAnnot;
+ expr: Call foo_loc [use{use_op_alg' (foostruct_sls T_st)} "a"];
+ "__0" <-{ IntOp i32 } I2v (42) I32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+ End bar_code.
+
+ Section foobar_code.
+ Definition foobar (bar_loc : loc) : function := {|
+ f_args := [
+ ("x", use_layout_alg' (foostruct_sls (IntSynType i32)));
+ ("y", use_layout_alg' (barstruct_sls (IntSynType i32)))
+ ];
+ f_local_vars := [
+ ("__0", use_layout_alg' UnitSynType)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "x" at{foostruct_sls (IntSynType i32)} "x" <-{IntOp i32} (I2v 43 I32);
+ "x" at{foostruct_sls (IntSynType i32)} "y" <-{IntOp i32} (I2v 53 I32);
+ "y" at{barstruct_sls (IntSynType i32)} "z" <-{IntOp i32} (I2v 42 I32);
+ "y" at{barstruct_sls (IntSynType i32)} "w" <-{use_op_alg' (foostruct_sls (IntSynType i32))} use{use_op_alg' (foostruct_sls (IntSynType i32))} "x";
+ expr: Call bar_loc [use{use_op_alg' (barstruct_sls (IntSynType i32))} "y"];
+ "__0" <-{ IntOp i32 } I2v (42) I32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+ End foobar_code.
+
+ Section specs.
+ (* TODO: I don't think that the syntype sidecondition should be part of the precondition -- it should rather be hidden / explicitly a part of a function spec. *)
+ Definition type_of_foo (T_rt : Type) T_st :=
+ fn(∀ (T, r, z) : (type T_rt * T_rt * Z), (λ Ï, []); -[#z; #r] @ (struct_t (foostruct_sls T.(ty_syn_type)) +[int i32; T]); λ Ï€, ⌜T.(ty_syn_type) = T_stâŒ)
+ → ∃ () : (), 42 @ int i32; (λ Ï€, ⌜TrueâŒ).
+
+ Definition type_of_bar (T_rt : Type) T_st :=
+ fn(∀ (T, r, z1, z2) : (type T_rt * T_rt * Z * Z), (λ Ï, []);
+ -[#z1; #(-[#z2; #r])] @ (struct_t (barstruct_sls T.(ty_syn_type)) +[int i32; struct_t (foostruct_sls T.(ty_syn_type)) +[int i32; T]]); λ Ï€, ⌜T.(ty_syn_type) = T_stâŒ)
+ → ∃ () : (), () @ unit_t; (λ Ï€, ⌜TrueâŒ).
+
+ Definition type_of_foobar :=
+ fn(∀ () : (), (λ Ï, []); λ Ï€, True)
+ → ∃ () : (), () @ unit_t; (λ Ï€, ⌜TrueâŒ).
+ End specs.
+
+ Section proofs.
+
+ Lemma foo_typed π (T_rt : Type) T_st :
+ syn_type_is_layoutable (foostruct_sls T_st) →
+ ⊢ typed_function π (foo T_st) [IntSynType i32] (type_of_foo T_rt T_st).
+ Proof.
+ start_function "source" ( [[T_ty r] z] ) => arg_abc local_0.
+ intros.
+ init_lfts (∅).
+ init_tyvars (<["T" := existT _ T_ty]> ∅).
+ repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Qed.
+
+
+ Lemma bar_typed π (T_rt : Type) (T_st : syn_type) (foo_loc : loc) :
+ (* assumption for foostruct *)
+ syn_type_is_layoutable (foostruct_sls T_st) →
+ (* assumption for barstruct *)
+ syn_type_is_layoutable (barstruct_sls T_st) →
+ (* assumption for foo *)
+ foo_loc â—áµ¥{Ï€} foo_loc @ function_ptr [foostruct_sls T_st : syn_type] (type_of_foo T_rt T_st) -∗
+ typed_function π (bar T_st foo_loc) [UnitSynType; foostruct_sls T_st : syn_type] (type_of_bar T_rt T_st).
+ Proof.
+ start_function "source" ( [[[T_ty r] z1] z2] ) => arg_abc local_0 local_a.
+ init_lfts (∅).
+
+ simpl in *.
+ repeat liRStep; liShow.
+ iApply program_rules.typed_stmt_annot_skip.
+ do 49 liRStep; liShow.
+ repeat liRStep; liShow.
+
+ (*
+ coercing StructLtype to uninit..
+ difficulty: some parts might be blocked for a reborrow below, so we cannot require to be able to fold to ofty.
+ instead: need to structurally go through it.
+ coerce all the components to uninit.
+ This should work via subsume, since it is fully owned.
+ Should we instead explicitly have owned, non-persistent subtyping? Essentially subsume_loc + syn_type_eq + sidecond maybe
+
+ coercion to uninit only needs to work for Owned. For Uniq, we are below a mutref, which we should never need to deinitialize (and we can't).
+ *)
+
+ liRStep. liRStep. liRStep. liRStep.
+ liRStep; liShow.
+ liRStep.
+ (* evar instantiation strategy:
+ - need an instance for the case that the sls is different / contains an evar.
+ - after that, the struct instance should fire and we should be fine by recursion.
+ *)
+
+ iApply typed_stmt_annot_skip.
+
+ liRStep.
+ cbn.
+ simpl.
+ Set Printing All.
+
+ (* this is probably an issue with the plist *)
+ Global Typeclasses Opaque struct_t.
+ Arguments struct_t : simpl never.
+
+ (*refine (tac_fast_apply (place_ofty_struct (rts := [_ ; _]) _ _ _ _ _ _ _ _ _ _ _) _).*)
+ iApply (place_ofty_struct (rts := [_ ; _])).
+ liRStep.
+
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ (*
+ Lemma foobar_typed π (foostruct_i32_sl barstruct_i32_sl : struct_layout) (bar_loc : loc) :
+ (* assumption for bar *)
+ bar_loc â—áµ¥{Ï€} bar_loc @ function_ptr [foostruct_i32_sl : layout_spec; barstruct_i32_sl : layout_spec] (type_of_bar Z foostruct_i32_sl barstruct_i32_sl) -∗
+ typed_function π (foobar foostruct_i32_sl barstruct_i32_sl bar_loc) (type_of_foobar foostruct_i32_sl barstruct_i32_sl).
+ Proof.
+ (* TODO: need lemma to convert uninit to uninit struct *)
+ Abort.
+ *)
+
+ End proofs.
+End structs2.
diff --git a/theories/rust_typing/examples/structexamples.v b/theories/rust_typing/examples/structexamples.v
new file mode 100644
index 0000000000000000000000000000000000000000..d61aab67fd8f679ea8166b7200333bf986953a37
--- /dev/null
+++ b/theories/rust_typing/examples/structexamples.v
@@ -0,0 +1,563 @@
+From caesium Require Import lang notation tactics.
+From lithium Require Export tactics.
+From refinedrust Require typing.
+
+Program Definition unit_layout : struct_layout :=
+ {| sl_members := [] |}.
+Solve Obligations with solve_struct_obligations.
+
+Definition fields_def := list (var_name * layout).
+(* get the named fields *)
+Fixpoint named_fields (sl_fields : field_list) : list (var_name * layout) :=
+ foldr (λ '(n, ly) acc, match n with Some n => (n, ly) :: acc | _ => acc end) [] sl_fields.
+
+(* TODO: generalize to permutations + subset? (it should work even when we ignore some named fields, I think, and reordering is allowed) *)
+Definition sl_has_members (fields : list (var_name * layout)) (sl : struct_layout) :=
+ fields = named_fields (sl.(sl_members)).
+
+
+(*
+ We pose the following restrictions:
+ - no DSTs currently
+ - we pick a particular repr(C)-like representation for enums to encode them in terms of structs + unions
+ - for generics, we compute a bound on the size. This makes a few assumptions that require that the layout algorithm that will be used is in some sense "sane":
+ - we require that all data we use has at most 128bit/16byte/4logbyte alignment
+ - we require that the layout algorithm is at least as efficient (in terms of size) as the repr(C) layout algorithm.
+ TODO we may want to relax that to a constant factor?
+
+
+ Note that we do not model the following things:
+ - Caesium fixes an endianness.
+ - Caesium fixes the size of pointers to 64 bits.
+ - Structs layouts are currently assumed to be determined by their component's layouts, not necessarily their types.
+ - The model of enums follows repr(C).
+ - We assume that fields are not reordered in structs.
+ - ...
+
+
+ Note: Maybe it would be interesting at some point to switch to a more abstract memory model that would allow us to model more things. e.g. Krebbers-style CH2O.
+ The semantics would directly know about structs/unions/enums, and pointers would be paths through objects.
+
+ Would this also remove some of the trouble with the quite concrete layouts we have currently? We might be able to encode the fact that we don't care about how concretely data is layed out when we have some tree-like model.
+
+ Of course, the Q is: what is the right balance between abstraction and fine-grained information? We still want to be able to have repr(C) stuff to reason about memcasts etc.
+
+=> This is not the most relevant thing for now. It will be more relevant to get good verification results for unsafe code later on, though, but finding a good memory model (possibly with support for Stacked Borrows/Tree Borrows) is something that is an entirely new challenge that is orthogonal.
+
+
+ For now, we remain in this somewhat awkward spot where we don't work with a fully concrete model (because we can't with generics) but don't mdoel all of the implementation-defined stuff of Rust.
+ *)
+
+
+(*
+
+ The size bounds are anyways kind of awkward, no matter what we do.
+ In principle, the most reasonable thing would be to just remove the bound from the language model.
+ That then kind of assumes, for it to be a reasonable thing overall, that we don't have bounds.
+ Then also the oracle thing would be reasonable.
+
+
+ *)
+
+
+
+Class MemEnv : Type := {
+ struct_layout_alg : fields_def → string → struct_layout;
+ struct_layout_alg_correct : ∀ def name,
+ sl_has_members def (struct_layout_alg def name);
+}.
+
+
+Module oracle.
+
+ Section my_struct_gen_def.
+ Context `{MemEnv}.
+ Context (T_ly : layout).
+
+ Definition my_struct_gen_members : fields_def := [("a", T_ly); ("b", void* ); ("c", T_ly)].
+
+ Definition my_struct_gen_layout : struct_layout := struct_layout_alg my_struct_gen_members "my_struct".
+ Lemma my_struct_gen_layout_mems : sl_has_members my_struct_gen_members my_struct_gen_layout.
+ Proof. apply struct_layout_alg_correct. Qed.
+ End my_struct_gen_def.
+
+ (* But what stops me in the proof from just instantiating it with some way too large type, and then derive a contradiction? Can I somehow convincingly seal that? *)
+ (* TODO: *)
+End oracle.
+
+
+(** Other approach where the oracle gets a correct layout already as a certificate that it can be layed out. *)
+(* This has the disadvantage of carrying around ugly size bounds everywhere....
+ (and if there are multiple generics involved in a definition, they are interdependent.. )
+*)
+
+(*
+Class MemEnv : Type := {
+ (* The layout algorithm, as a guarantee that the data can be layed out, can already assume that there exists a suitable layout. *)
+ struct_layout_alg : fields_def → string → struct_layout → struct_layout;
+ struct_layout_alg_correct : ∀ def name sl,
+ sl_has_members def sl →
+ sl_has_members def (struct_layout_alg def name sl);
+}.
+*)
+
+(* Maximum alignment of generics is 16 bytes or 128 bits. *)
+Definition max_align_log : nat := 4.
+
+(* Generate padding to correctly align the field starting at [offset] *)
+Definition pad_field (offset : nat) (align_log : nat) : layout :=
+ let alignment := (2^align_log)%nat in
+ let misalignment := (offset `mod` alignment)%nat in
+ if decide (misalignment > 0%nat) then
+ Layout (alignment - misalignment)%nat 0%nat
+ else Layout 0%nat 0%nat.
+(* Alignment of a struct. *)
+Definition struct_align_log (fields : fields_def) :=
+ foldr Nat.max 0%nat ((λ '(_, ly), ly.(ly_align_log)) <$> fields).
+
+Fixpoint layout_struct_with_reprC' (full_align : nat) (offset : nat) (fields : fields_def) : field_list :=
+ match fields with
+ | [] =>
+ (* pad the end of the struct to match its alignment *)
+ let pad := pad_field offset full_align in
+ [(None, pad)]
+ | (x, ly) :: fields =>
+ let pad := pad_field offset ly.(ly_align_log) in
+ let r := layout_struct_with_reprC' full_align (pad.(ly_size) + ly.(ly_size) + offset) fields in
+ (None, pad) :: (Some x, ly) :: r
+ end.
+Definition layout_struct_with_reprC (fields : fields_def) : field_list :=
+ layout_struct_with_reprC' (struct_align_log fields) 0%nat fields.
+Lemma check_fields_aligned_reprC fields pos : check_fields_aligned (layout_struct_with_reprC fields) pos = true.
+Proof.
+ induction fields as [ | [x ly] fields] in pos |-*.
+ - cbn. unfold pad_field. cbn.
+ case_decide; first lia. unfold ly_align. cbn.
+ rewrite Z.mod_1_r. case_bool_decide; last lia. done.
+ - cbn. rewrite !andb_true_iff. split_and!.
+Abort.
+
+Ltac solve_size_bound :=
+ cbv delta -[Z.add Z.max Z.lt Nat.succ Z.pow Z.mul Z.of_nat Nat.add foldl sum_list fmap Nat.pow max_list Z.opp] in *;
+ simpl;
+ lia.
+
+Section arbitrary_layouts.
+ (* Consider
+
+ struct my_struct {
+ a : i32,
+ c : Box<i32>
+ }
+
+ Rust does not make any layout guarantees (except if it is declared as repr(C)).
+ As an approximation of this, we can do the verification for all struct_layouts with the right members.
+ Ideally, we want to do our verification no matter what valid concrete layout the compiler chooses.
+ *)
+
+ (* TODO: parameteize over pointer size? or set statically. *)
+ (* TODO: packed structs? not handled by current def. *)
+ (* TODO: max size of structs (Signed size_t) *)
+ Section my_struct_def.
+ Definition my_struct_members : fields_def := [("a", it_layout i16); ("b", void*)].
+
+ Program Definition my_struct_sl_reprC : struct_layout :=
+ {| sl_members := [(Some "a", it_layout i32); (None, Layout 4%nat 0%nat); (Some "b", void* )]; |}.
+ Solve Obligations with solve_struct_obligations.
+ (*Lemma my_struct_reprC_members : sl_has_members my_struct_members my_struct_sl_reprC.*)
+ (*Proof. reflexivity. Qed.*)
+ End my_struct_def.
+
+ (*
+ Section my_struct_gen_def.
+ Context (T_ly : layout) (T_ly_align_bound : T_ly.(ly_align_log) ≤ max_align_log).
+ Definition my_struct_gen_members : fields_def := [("a", T_ly); ("b", void* ); ("c", T_ly)].
+
+ Definition size_bound_of_my_struct_gen : Z :=
+ sum_list (ly_size <$> my_struct_gen_members.*2) +
+ (* this is quite a loose bound *)
+ 2^max_align_log * length (my_struct_gen_members).
+
+ (*Program Definition my_struct_sl_reprC : struct_layout :=*)
+ (*{| sl_members := [(Some "a", it_layout i32); (None, Layout 4%nat 0%nat); (Some "b", void* )]; |}.*)
+ (*Solve Obligations with solve_struct_obligations.*)
+
+ (*Lemma my_struct_reprC_members : sl_has_members my_struct_members my_struct_sl_reprC.*)
+ (*Proof. reflexivity. Qed.*)
+
+ (* Want to calculate the correct number of alignment bits.
+ TODO: how to do this in an easy way?
+ *)
+ (* Examples:
+ 0, 1 => 2
+ *)
+
+
+ (* Note: key to making all of this feasible/modular would be to resolve this to _concrete_ bounds on the size at some point.
+ i.e.: solve the equation for size(T)
+ *)
+ (* moreover, just assume that align_log < 8 or so. Since alignment in structs goes by max and we don't have stuff > 128 bits, that seems fine *)
+ (* a very loose bound for structs: just assume we need the maximum possible padding, 2^7, between every two fields *)
+ (* under that condition, we should always be able to define the repr(C) layout. *)
+
+ (* the alignment of the whole struct *)
+ Definition my_struct_gen_align fields : nat :=
+ struct_align_log fields.
+
+ Program Definition my_struct_gen_reprC : struct_layout :=
+ {| sl_members :=
+ [(Some "a", T_ly); (None, Layout (pad_field T_ly.(ly_size) (void*.(ly_align_log))) 0%nat);
+ (Some "b", void* ); (None, Layout (pad_field (void*.(ly_size)) (T_ly.(ly_align_log))) 0%nat);
+ (Some "c", T_ly); (None, Layout (pad_field (T_ly.(ly_size)) (my_struct_gen_align)) 0%nat)]
+ |}.
+ Next Obligation.
+ done.
+ Qed.
+ Next Obligation.
+ simpl.
+ (* TODO: padding *)
+ Admitted.
+ Next Obligation.
+ simpl.
+ (* TODO: prove that alignment is fine *)
+ Admitted.
+ End my_struct_gen_def.
+
+ (* experiments for the size bound approach *)
+ Definition max_size_in_fun (T_ly : layout) : Z :=
+ foldl Z.max 0%Z [size_of_my_struct_gen T_ly; (Z.of_nat (layout_of unit_layout).(ly_size))].
+
+ (* how can we bound the alignment? *)
+ (* we always need at most 63 padding bits, assuming that none of our types has alignment greater than 8byte. *)
+
+ Section fundef.
+ Context (T_ly : layout) (Hsz : max_size_in_fun T_ly < max_int size_t + 1).
+ (* assumption for the function *)
+ (* from Hsz, we should be able to define repr(C) layouts to pass to the oracle *)
+
+
+
+ End fundef.
+
+
+ Section inst.
+ (* we instantiate the function's assumptions *)
+ Goal (max_size_in_fun (i32) < max_int size_t + 1)%Z.
+ Proof.
+ solve_size_bound.
+ Abort.
+
+ (* this should also be compositional: in the assumption of our own function, we can just include the (instantiated) assumptions of the other functions we are using *)
+ End inst.
+ *)
+
+End arbitrary_layouts.
+
+
+(** Old approach where we have parameters for all used layouts is below: *)
+
+(*
+ fn my_struct_bar(x : my_struct) -> i32{
+ let y = x.a;
+ 42
+ }
+*)
+Section assume.
+ Context (my_struct_sl : struct_layout).
+
+
+ (*
+
+
+
+ fn do_something<T>(x : T) where T: Sized {
+ // use some structs
+ }
+ ∀ T: type, safe(do_something<T>)
+
+
+ oracle:
+ - sizeof((T, i32)) <= isize_max
+ above proposal:
+ - provide layout for (T, i32)
+ just bound size for generic types statically
+ - not clear how that works with nesting.
+ try to just "assume" it:
+ -
+ assumes for "layout is fine", we abort otherwise:
+ -> try out this approach.
+
+ struct_members + proof: struct members fit in isize -> struct_layout
+
+ *)
+
+
+ Context (my_struct_sl_has_members : sl_has_members my_struct_members my_struct_sl).
+
+ Definition my_struct_bar : function := {|
+ f_args := [
+ ("x", my_struct_sl : layout)
+ ];
+ f_local_vars := [
+ ("__0", it_layout i32);
+ ("y", it_layout i16)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "y" <-{ IntOp i16 } use{IntOp i16} ("x" at{my_struct_sl} "a");
+ "__0" <-{ IntOp i32 } i2v 42 i32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+End assume.
+
+Section generics.
+ (*
+ Consider the struct
+ struct<T> my_struct2 {
+ a : T,
+ b : i32,
+ }
+ *)
+
+ Section my_struct2_def.
+ Context (T_ly : layout).
+
+ Definition my_struct2_members := [("a", T_ly); ("b", it_layout i32)].
+
+ (* no repr(C) definition as it is generic *)
+ End my_struct2_def.
+
+ (*
+ fn my_struct2_bar<T>(x : my_struct2<T>) -> i32 {
+ let y = x.a;
+ 42
+ }
+ *)
+ Section assume.
+ Context (T_ly : layout).
+ (* build in more assumptions into T_ly: has size <= isize_max
+ *)
+
+ (*
+ assume (exists_layout my_struct2_members)
+ *)
+
+
+ (*Context (my_struct2_sl : struct_layout). *)
+
+
+ Context (my_struct2_sl_has_members : sl_has_members (my_struct2_members T_ly) my_struct2_sl).
+ Definition my_struct2_bar : function := {|
+ f_args := [
+ ("x", my_struct2_sl : layout)
+ ];
+ f_local_vars := [
+ ("__0", it_layout i32);
+ ("y", it_layout i16)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "y" <-{ UntypedOp T_ly } use{UntypedOp T_ly } ("x" at{my_struct2_sl} "a");
+ "__0" <-{ IntOp i32 } i2v 42 i32;
+ Return (use{ IntOp i32 } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+ End assume.
+
+ Section spec.
+ (* the specification and proof should also be generic in the layout, as well as T *)
+ Import typing.
+ Context `{typeGS Σ}.
+ Context (rt : Type) (T : type rt).
+ Context (my_struct2_sl : struct_layout).
+ Context (my_struct2_sl_has_members : sl_has_members (my_struct2_members T.(ty_layout)) my_struct2_sl).
+ End spec.
+
+ Section monomorphic_client.
+ (*
+ fn foo(x : my_struct2<i32>) {
+ my_struct2_bar(x);
+ }
+ *)
+ Context (my_struct2_sl : struct_layout).
+ Context (my_struct2_sl_has_members : sl_has_members (my_struct2_members i32) my_struct2_sl).
+
+ Context (my_struct2_bar_loc : loc).
+
+ Definition foo : function := {|
+ f_args := [
+ ("x", my_struct2_sl : layout)
+ ];
+ f_local_vars := [
+ ("__0", unit_layout : layout);
+ ("__1", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "__1" <-{UntypedOp unit_layout} Call my_struct2_bar_loc [use{UntypedOp my_struct2_sl} "x"];
+ "__0" <-{ UntypedOp unit_layout } (Val []);
+ Return (use{ UntypedOp unit_layout } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+ End monomorphic_client.
+ Section monomorphic_client_proof.
+
+ (*fntbl_entry my_struct2_bar_loc (my_struct2_bar i32 my_struct2_sl)*)
+ End monomorphic_client_proof.
+
+ (* What's the tldr of this?
+ - when defining a struct, we should define the list of actual members.
+ - when defining a function using a struct, we just assume _some_ layout for that struct
+ - when proving a specification for such a function, we assume sl_has_members for that layout
+
+ - when defining a function with type parameters, we assume some layout
+ - when proving a specification for a generic function, we assume some rtype and instantiate the code's layout with that type's layout
+ *)
+
+ (* For enums/structs, for now:
+ - only handle layouts that do not reorder the struct fields.
+ - for enums, this means in particular that it is a
+ struct {
+ variant: usize,
+ content: union ...
+ }
+ *)
+End generics.
+
+Section tuples.
+ (* Tuples are like structs, but they don't get a special name. *)
+
+End tuples.
+
+(* Not a goal currently: deal with layout optimizations like the one for Option that rustc does.
+ - in a sense, the following representation is too concrete.
+
+ unsafe code can even rely on this layout optimization specifically for Option.
+
+
+ Alternative: introduce enums as first-class constructs into Caesium for a less concrete model.
+ *)
+Section enum.
+ (* Represent an enum as struct with discriminant + union of variants *)
+
+ (* the other repr with discriminant in each variant is NOT equivalent. TODO: think about why.
+
+ enum repr(C) -> some RFC2195 TODO lookup.
+ *)
+
+ (* TODO rust unions allow different padding at start for different variants; look at this.
+ -> Shelve this.
+ *)
+
+
+ (* global oracle = member_list + identifier -> layout
+ => different structs with same fields can have different layout
+
+ *)
+
+ (*
+ enum Option<T> {
+ Some(t : T),
+ None
+ }
+
+ *)
+
+
+ (* We define structs for each of the variants *)
+
+ Section variant_def.
+ Context (T_ly : layout).
+ Definition Option_T_Some_members : fields_def := [("t", T_ly)].
+ End variant_def.
+
+ Section variant_def.
+ Context (T_ly : layout).
+ Definition Option_T_None_members : fields_def := [].
+ End variant_def.
+
+ Section union_def.
+ Context (T_ly : layout).
+ Context (Option_T_Some_sl : struct_layout).
+ Context (Option_T_None_sl : struct_layout).
+
+ Definition Option_T_union_members : fields_def := [("Some", Option_T_Some_sl : layout); ("None", Option_T_None_sl : layout)].
+ End union_def.
+
+ Section enum_def.
+ Context (T_ly : layout).
+ Context (Option_T_Some_sl : struct_layout).
+ Context (Option_T_None_sl : struct_layout).
+ Context (Option_T_union_ul : union_layout).
+
+ Definition Option_T_members : fields_def := [("discriminant", u64 : layout); ("data", Option_T_union_ul : layout)].
+ End enum_def.
+
+ Section reprC_i32.
+ Program Definition Option_i32_Some_reprC_sl : struct_layout :=
+ {| sl_members := [(Some "t", i32 : layout)] |}.
+ Solve Obligations with solve_struct_obligations.
+
+ Program Definition Option_i32_None_reprC_sl : struct_layout :=
+ {| sl_members := [] |}.
+ Solve Obligations with solve_struct_obligations.
+
+ Program Definition Option_i32_union_reprC_ul : union_layout :=
+ {| ul_members := [("Some", Option_i32_Some_reprC_sl); ("None", Option_i32_None_reprC_sl)] |}.
+ Solve Obligations with solve_struct_obligations.
+
+ Program Definition Option_i32_reprC_sl : struct_layout :=
+ {| sl_members := [(Some "discriminant", u64); (Some "data", Option_i32_union_reprC_ul)] |}.
+ Solve Obligations with solve_struct_obligations.
+ End reprC_i32.
+
+ (*
+ fn unwrap(x : Option<T>) -> T {
+ match x {
+ None => assert!(false),
+ Some(i) => i
+ }
+ }
+ *)
+
+
+ Section unwrap_code.
+ Context (T_ly : layout).
+ Context (Option_T_Some_sl : struct_layout).
+ Context (Option_T_None_sl : struct_layout).
+ Context (Option_T_union_ul : union_layout).
+ Context (Option_T_sl : struct_layout).
+
+ Definition unwrap : function := {|
+ f_args := [
+ ("x", Option_T_sl : layout)
+ ];
+ f_local_vars := [
+ ("__0", unit_layout : layout);
+ ("__1", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ Switch u64 (use{IntOp u64} ("x" at{Option_T_sl} "discriminant")) (<[0%Z := 0%nat]> (∅ : gmap Z nat)) [Goto "_bb1"] (Goto "_bb2")
+ ]>%E $
+ <["_bb1" :=
+ "__0" <-{UntypedOp T_ly} use{UntypedOp T_ly} ((("x" at{Option_T_sl} "data") at_union{Option_T_union_ul} "Some") at{Option_T_Some_sl} "t");
+ Return (use{UntypedOp T_ly} "__0")
+ ]>%E $
+ <["_bb2" :=
+ StuckS
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+ End unwrap_code.
+
+
+End enum.
diff --git a/theories/rust_typing/examples/test.v b/theories/rust_typing/examples/test.v
new file mode 100644
index 0000000000000000000000000000000000000000..823a7cc18abb18e3d8d1c704044e87d1268f56a6
--- /dev/null
+++ b/theories/rust_typing/examples/test.v
@@ -0,0 +1,587 @@
+From iris.proofmode Require Import coq_tactics reduction string_ident.
+From caesium Require Import lang notation tactics.
+From refinedrust Require Import functions programs int references automation uninit arrays.
+
+Section test.
+ Arguments ltype_own : simpl never.
+ Context `{typeGS Σ}.
+
+ (** OnEndlft tests *)
+ Lemma endlft_test_1 E L κ s fn R Ï€ Ï :
+ L = [κ ⊑ₗ{0} []] →
+ named_lfts (<["κ" := κ]> ∅) -∗
+ typed_stmt Ï€ E L (annot: (EndLftAnnot "κ"); s) fn R Ï.
+ Proof.
+ intros ->.
+ iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ Lemma endlft_test_2 E L κ s fn R Ï€ Ï Îº2 :
+ L = [κ ⊑ₗ{0} []; κ2 ⊑ₗ{1} []] →
+ Inherit κ InheritDynIncl (llft_elt_toks [κ2]) -∗
+ named_lfts (<["κ" := κ]> ∅) -∗
+ typed_stmt Ï€ E L (annot: (EndLftAnnot "κ"); s) fn R Ï.
+ Proof.
+ intros ->.
+ iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ Lemma endlft_test_3 E L κ s fn R Ï€ Ï :
+ L = [κ ⊑ₗ{0} []] →
+ named_lfts (<["κ1" := κ]> ∅) -∗
+ typed_stmt Ï€ E L (annot: (EndLftAnnot "κ2"); s) fn R Ï.
+ Proof.
+ intros ->. iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ (** CopyLftName tests *)
+ Lemma copy_lft_name_test_1 Ï€ E L κ s fn R Ï :
+ L = [κ ⊑ₗ{0} []] →
+ named_lfts (<["κ" := κ]> ∅) -∗
+ typed_stmt Ï€ E L (annot: (CopyLftNameAnnot "κ2" "κ"); s) fn R Ï.
+ Proof.
+ intros ->. iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ (** DynInclude tests *)
+ Lemma dyn_include_test_1 Ï€ E L κ1 κ2 s fn R Ï :
+ L = [κ1 ⊑ₗ{0} []; κ2 ⊑ₗ{0} []] →
+ named_lfts (<["κ1" := κ1]> $ <["κ2" := κ2]> $ ∅) -∗
+ typed_stmt π E L (
+ annot: (DynIncludeLftAnnot "κ1" "κ2");
+ annot: (EndLftAnnot "κ1");
+ annot: (EndLftAnnot "κ2");
+ s) fn R Ï.
+ Proof.
+ intros ->. iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ (** ExtendLft tests *)
+ Lemma extendlft_test_1 Ï€ E L κ1 κ2 s fn R Ï :
+ L = [κ1 ⊑ₗ{1} [κ2]; κ2 ⊑ₗ{0} []] →
+ named_lfts (<["κ1" := κ1]> $ <["κ2" := κ2]> $ ∅) -∗
+ typed_stmt π E L (
+ annot: (ExtendLftAnnot "κ1");
+ annot: (EndLftAnnot "κ2");
+ s) fn R Ï.
+ Proof.
+ intros ->. iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ (** AliasLft tests *)
+ Lemma aliaslft_test_1 Ï€ E L κ1 κ2 s fn R Ï :
+ L = [κ1 ⊑ₗ{0} [κ2]; κ2 ⊑ₗ[]] →
+ named_lfts (<["κ1" := κ1]> $ <["κ2" := κ2]> $ ∅) -∗
+ typed_stmt π E L (
+ annot: (AliasLftAnnot "κ3" ["κ1"; "κ2"]);
+ s) fn R Ï.
+ Proof.
+ intros ->. iStartProof.
+ repeat liRStep; liShow.
+ Abort.
+
+ (** AssertType tests *)
+ Lemma assert_type_test1 π E L (T : (llctx → val → ∀ rt : Type, type rt → rt → iProp Σ)) :
+ named_lfts ∅ -∗
+ T L (I2v 42 I32) Z (int i32) 42%Z -∗
+ typed_val_expr π E L (AnnotExpr 0 (AssertTypeAnnot (Int i32)) (I2v 42 I32)) T.
+ Proof.
+ iStartProof.
+ init_tyvars ∅.
+ repeat liRStep; liShow.
+ done.
+ Abort.
+
+ Lemma assert_type_test2 π E (T : (llctx → val → ∀ rt : Type, type rt → rt → iProp Σ)) κ1 κ2 v γ :
+ named_lfts (<["κ1" := κ1]> $ <["κ2" := κ2]> ∅) -∗
+ v â—áµ¥{Ï€} (#42%Z, γ) @ mut_ref (int i32) κ2 -∗
+ T [κ1 ⊑ₗ{ 0} [κ2]] v (place_rfn Z * gname)%type (mut_ref (int i32) κ1) (# 42%Z, γ) -∗
+ typed_val_expr π E [κ1 ⊑ₗ{0} [κ2]] (AnnotExpr 0 (AssertTypeAnnot (annotations.Ref Mut "κ1" (Int i32))) v) T.
+ Proof.
+ iStartProof.
+ init_tyvars ∅.
+ repeat liRStep; liShow.
+ done.
+ Unshelve. li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ (** prove_with_subtype tests *)
+
+ Lemma prove_with_subtype_1 E L ( P Q : iProp Σ) T :
+ ⊢ prove_with_subtype E L (P ∗ Q) T.
+ Proof.
+ iStartProof.
+ repeat liRStep.
+ Abort.
+
+ Lemma prove_with_subtype_2 π E L T l z :
+ T L -∗
+ (l â—â‚—[Ï€, Owned false] PlaceIn z @ â— int i32)%I -∗
+ prove_with_subtype E L (l â—â‚—[Ï€, Owned false] PlaceIn z @ â— int i32) T.
+ Proof.
+ iStartProof. repeat liRStep. liShow. done.
+ Abort.
+
+ Lemma prove_with_subtype_3 π E L T v z :
+ T L -∗
+ (v â—áµ¥{Ï€} z @ int i32)%I -∗
+ prove_with_subtype E L (v â—áµ¥{Ï€} z @ int i32) T.
+ Proof.
+ iStartProof. repeat liRStep. liShow. done.
+ Abort.
+
+ (** Subtyping for mut refs *)
+ Lemma sub_test_evar1 κ1 γ1 z1:
+ ⊢ ∃ ty2, weak_subltype [] [κ1 ⊑ₗ{0} []] (Owned false) #(#z1, γ1) #(#z1, γ1) (MutLtype (â— int i32) κ1) (â—ty2) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ Lemma sub_test_evar2 κ1 γ1 z1:
+ ⊢ ∃ ty2, weak_subltype [] [κ1 ⊑ₗ{0} []] (Owned false) #(#z1, γ1) #(#z1, γ1) (MutLtype (â— int i32) κ1) (â—(mut_ref (ty2) κ1)) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ Lemma sub_test_evar3 κ1 γ1 z1:
+ ⊢ ∃ ty2 κ2, weak_subltype [] [κ1 ⊑ₗ{0} []] (Owned false) #(#z1, γ1) #(#z1, γ1) (MutLtype (â— int i32) κ1) (â—(mut_ref (ty2) κ2)) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ Lemma sub_test_evar4 κ1 γ1 z1:
+ ⊢ ∃ (ty2 : type Z) κ2 r2, weak_subltype [] [κ1 ⊑ₗ{0} []] (Owned false) #(#z1, γ1) #r2 (MutLtype (â— int i32) κ1) (â—(mut_ref (ty2) κ2)) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ (** Subtyping for arrays *)
+ Lemma sub_test_array1 r1 len1 :
+ ⊢ ∃ (ty2 : type Z) len2, weak_subtype [] [] r1 r1 (array_t (int i32) len1) (array_t ty2 len2) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ Lemma sub_test_array2 r1 len1 :
+ ⊢ ∃ (ty2 : type Z) len2 lts2, weak_subltype [] [] (Owned false) r1 r1 (◠array_t (int i32) len1) (ArrayLtype ty2 len2 lts2) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ Lemma sub_test_array3 r1 len1 :
+ ⊢ weak_subltype [] [] (Owned false) r1 r1 (ArrayLtype (int i32) len1 []) (◠array_t (int i32) len1) True.
+ Proof.
+ iStartProof. repeat liRStep; solve [fail].
+ Abort.
+
+ Lemma sub_test_array4 r1 len1 i :
+ i < len1 →
+ ⊢ weak_subltype [] [] (Owned false) r1 r1 (ArrayLtype (int i32) len1 [(i, ◠int i32)]) (◠array_t (int i32) len1) True.
+ Proof.
+ intros.
+ iStartProof. repeat liRStep; solve [fail].
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma sub_test_array5 r1 len1 i :
+ i < len1 →
+ ⊢ ∃ r2, weak_subltype [] [] (Owned false) #(<[i := #42%Z]> r1) #(<[i := #r2]> r1) (ArrayLtype (int i32) len1 [(i, ◠int i32)]) (◠array_t (int i32) len1) True.
+ Proof.
+ intros.
+ iStartProof. repeat liRStep; solve [fail].
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma sub_test_array6 r1 len1 i :
+ i < len1 →
+ ⊢ ∃ r2, weak_subltype [] [] (Owned false) #(<[i := #42%Z]> r1) #(<[i := #r2]> r1) (ArrayLtype (int i32) len1 [(i, ◠int i32)]) (ArrayLtype (int i32) len1 []) True.
+ Proof.
+ intros.
+ iStartProof. repeat liRStep; solve [fail].
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ (* TODO: ideally we should get some additional knowledge from the fact the own the array -- however, this doesn't quite work because of the order of quantifiers.
+ Can we add this to the context before initiating the subtyping?
+
+ In principle, it is learnable just from the type interpretation, so we should not need to add it as a precondition.
+ We could add it as a hook to the subsume_full -> weak_subtype rule?
+ *)
+ Abort.
+
+ (* subsume interaction:
+ - when proving something in the goal, look for related_to
+ - related_to will trigger a find_in_context.
+ - afterwards, will trigger a subsume between the found item and the goal.
+
+ But: will not trigger for prove_with_subtype in the goal, since that is not an atom.
+ -> for prove_with_subtype, need custom instances that emulate this sequence.
+
+ currently:
+ do find_in_context, then weak_subltype.
+ instead, of weak_subltype, I would rather trigger something else -- a subsume_full
+
+ *)
+
+
+ (** Misc tests *)
+ Lemma subsume_test l π :
+ l â—â‚—[Ï€, Owned false] PlaceIn 42%Z @ (â— int i32) -∗
+ (l â—â‚—[Ï€, Owned false] PlaceIn () @ â— uninit (IntSynType i32)) ∗ True.
+ Proof.
+ iStartProof.
+ Set Typeclasses Debug.
+ liRStep. liRStep.
+ liRStep. liShow.
+ repeat liRStep.
+ Qed.
+
+ Lemma gvar_test γ (z : Z):
+ gvar_pobs γ z -∗
+ gvar_pobs γ z ∗ True.
+ Proof.
+ iStartProof.
+ repeat liRStep; liShow.
+ Qed.
+
+ Lemma gvar_test' γ (z : Z):
+ True -∗
+ gvar_pobs γ z -∗
+ find_in_context (FindOptGvarPobs γ) (λ a,
+ match a with
+ | inl (existT rt r) => gvar_pobs γ r -∗ gvar_pobs γ r ∗ True
+ | _ => True
+ end%I).
+ Proof.
+ iStartProof.
+ repeat liRStep.
+ Qed.
+
+ Lemma gvar_test'' γ (z : Z):
+ True -∗
+ find_in_context (FindOptGvarPobs γ) (λ a,
+ match a with
+ | inl (existT rt r) => gvar_pobs γ r -∗ gvar_pobs γ r ∗ True
+ | _ => True
+ end%I).
+ Proof.
+ iStartProof.
+ repeat liRStep.
+ Qed.
+
+ Lemma llctx_kill_lft_test L κ :
+ L = [κ ⊑ₗ{0} []] →
+ ⊢@{iPropI Σ} (tactic_hint (llctx_kill_llft_goal L κ) (λ L',
+ ⌜L' = []⌠∗ True))%I.
+ Proof.
+ intros ->. iStartProof.
+ repeat liRStep; solve[fail].
+ Abort.
+
+ Lemma lctx_lft_alive_count_test E L κ κ0 κ' :
+ L = [κ ⊑ₗ{2} [κ']; κ' ⊑ₗ{3} []] →
+ E = [κ' ⊑ₑ κ0] →
+ (* doing a roundtrip *)
+ ⊢@{iPropI Σ} (tactic_hint (lctx_lft_alive_count_goal E L κ) (λ '(κs, L'),
+ tactic_hint (llctx_release_toks_goal L' κs) (λ L'', ⌜L = L''⌠∗ True)))%I.
+ Proof.
+ intros -> ->. iStartProof.
+ repeat liRStep; solve[fail].
+ Abort.
+
+ (** Tests for credit tracking *)
+ Lemma test1 :
+ ⊢@{iPropI Σ} let n := 4 + 4 in True -∗ True.
+ Proof.
+ iStartProof.
+ (* unfortunately, this doesn't work. We'll need some more heavy lifting to introduce abstractions. *)
+ assert_fails liStep.
+ (* one option:
+ - have a judgment [introduce_credits n m] that wraps the wand,
+ add a rule for that to liRIntroduceLetInGoal,
+ then have an intro rule for that that adds the credit assertion to the context again.
+ *)
+ Abort.
+
+
+ (** Stratify context *)
+ Lemma unblock_test_none E L Ï€ s fn ls R Q Ï l :
+ l â—â‚—[Ï€, Owned false] PlaceIn 32%Z @ (â— int i32) -∗
+ typed_pre_context_fold Ï€ E L (CtxFoldStratifyAllInit) s fn ls R Q Ï.
+ Proof.
+ iStartProof.
+ repeat liRStep.
+ liShow.
+ Abort.
+
+ Lemma unblock_test_none2 E L Ï€ s fn ls R Q Ï l :
+ l â—â‚—[Ï€, Owned false] PlaceIn 32%Z @ (â— int i32) -∗
+ typed_pre_context_fold Ï€ E L (CtxFoldStratifyAllInit) s fn ls R Q Ï.
+ Proof.
+ iStartProof.
+ repeat liRStep. liShow.
+ Abort.
+
+ Lemma unblock_test_obs E L Ï€ κ s fn ls R Q l γ Ï :
+ (□ [†κ]) -∗
+ (□ gvar_pobs γ (42%Z)) -∗
+ l â—â‚—[Ï€, Owned false] PlaceGhost γ @ (BlockedLty (int i32) κ) -∗
+ typed_stmt Ï€ E L s fn ls R Q Ï -∗
+ typed_pre_context_fold Ï€ E L (CtxFoldStratifyAllInit) s fn ls R Q Ï.
+ Proof.
+ iStartProof.
+ repeat liRStep. liShow.
+ done.
+ Abort.
+
+
+
+ Lemma subtype_test E L :
+ ⊢ weak_subtype E L (int i32) (int i32) True ∗ True.
+ Proof.
+ iStartProof. repeat liRStep; solve[fail].
+ Abort.
+
+ Lemma subtype_test2 E κ κ' c :
+ ⊢ weak_subtype E [κ ⊑ₗ{c} [κ']] (mut_ref (int i32) κ') (mut_ref (int i32) κ) True ∗ True.
+ Proof.
+ iStartProof. unshelve (repeat liRStep).
+ all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma shorten_lft_mut_test E κ κ' v γ Ï€ fn ls R Q s c Ï :
+ v â—áµ¥{Ï€} (PlaceIn 42%Z, γ) @ mut_ref (int i32) κ -∗
+ named_lfts (<["κ" := κ]> (<["κ'" := κ']> ∅)) -∗
+ typed_stmt Ï€ E ([κ' ⊑ₗ{c} [κ]]) (ExprS (AnnotExpr 0 (ShortenLftAnnot ["κ'"]) v) s) fn ls R Q Ï.
+ Proof.
+ iStartProof. repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma shorten_lft_shr_test E κ κ' v Ï€ fn ls R Q Ï s c :
+ v â—áµ¥{Ï€} PlaceIn 42%Z @ shr_ref (int i32) κ -∗
+ named_lfts (<["κ" := κ]> (<["κ'" := κ']> ∅)) -∗
+ typed_stmt Ï€ E ([κ' ⊑ₗ{c} [κ]]) (ExprS (AnnotExpr 0 (ShortenLftAnnot ["κ'"]) v) s) fn ls R Q Ï.
+ Proof.
+ iStartProof. repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_box E L π (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) :
+ (∀ l : loc, T L (val_of_loc l) (place_rfn unit) (box (uninit i32)) (PlaceIn ())) -∗
+ typed_val_expr π E L (box{i32}) T.
+ Proof.
+ iStartProof. repeat liRStep. liShow. done; solve[fail].
+ Abort.
+
+ (** ** Read tests *)
+ Lemma test_read1 E L (l : loc) γ π κ (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) :
+ lctx_lft_alive E L κ →
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn 42%Z, γ) @ (â— mut_ref (int i32) κ ) -∗
+ (*(∀ v, l â—â‚—[Ï€, Owned false] 42 @ (â— mut_ref i32) -∗ T v Z (int i32) 42) -∗*)
+ typed_read π E L (!{PtrOp} l)%E (IntOp i32) T.
+ Proof.
+ iIntros (?) "?". repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read2 E L (l : loc) π (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) :
+ l â—â‚—[Ï€, Owned false] (PlaceIn 42%Z) @ (â— int i32) -∗
+ (∀ v, l â—â‚—[Ï€, Owned false] PlaceIn 42%Z @ (â— int i32) -∗ T L v Z (int i32) 42) -∗
+ typed_read π E L (l) (IntOp i32) T.
+ Proof.
+ iIntros "Hl HT".
+ repeat liRStep; liShow.
+ iApply "HT"; done; solve[fail].
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read3 E L (l : loc) Ï€ fn Ï (s : stmt) (T : val → ∀ rt, type rt → rt → iProp Σ) :
+ l â—â‚—[Ï€, Owned false] PlaceIn 42%Z @ (â— int i32) -∗
+ typed_stmt Ï€ E L (ExprS (use{IntOp i32} (l)) s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hl".
+ repeat liRStep. liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read4 E L (l : loc) Ï€ fn Ï (s : stmt) T :
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn 42%Z) @ (â— box (int i32)) -∗
+ (∀ v, v â—áµ¥{Ï€} PlaceIn 42%Z @ box (int i32) -∗ l â—â‚—[Ï€, Owned false] PlaceIn () @ (â— uninit void*) -∗ typed_stmt Ï€ E L s fn [] T ∅ Ï) -∗
+ typed_stmt Ï€ E L (ExprS (use{PtrOp} l) s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hl Hc".
+ (* we move the box out *)
+ repeat liRStep. liShow.
+ iApply ("Hc" with "[$] [$]").
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read5 E L (l : loc) Ï€ fn Ï (s : stmt) T κ γ :
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn(PlaceIn 42%Z, γ)) @ (â— box (mut_ref (int i32) κ)) -∗
+ (∀ v, v â—áµ¥{Ï€} (PlaceIn 42%Z, γ) @ mut_ref (int i32) κ -∗ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn ()) @ (BoxLty (â— uninit void*)) -∗ typed_stmt Ï€ E L s fn [] T ∅ Ï) -∗
+ typed_stmt Ï€ E L (ExprS (use{PtrOp} (!{PtrOp} l)) s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hl Hc".
+ (* we move out of the box *)
+ repeat liRStep. liShow.
+ iApply ("Hc" with "[$] [$]").
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read_unblock1 E L (l : loc) Ï€ fn Ï s T γ :
+ gvar_pobs γ 42%Z -∗
+ l â—â‚—[Ï€, Owned false] PlaceGhost γ @ (â— int i32) -∗
+ typed_stmt Ï€ E L (ExprS (use{IntOp i32} l)%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hobs Hl". repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read_unblock2 E L (l : loc) Ï€ fn Ï s T γ :
+ gvar_pobs γ (PlaceIn 42%Z) -∗
+ l â—â‚—[Ï€, Owned false] PlaceGhost γ @ BoxLty (â— int i32) -∗
+ typed_stmt Ï€ E L (ExprS (use{IntOp i32} (!{PtrOp} l)%E)%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hobs Hl". repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_read_unblock3 E (l : loc) Ï€ fn Ï s T γ (γ' : gname) κ :
+ gvar_pobs γ (PlaceIn 42%Z, γ') -∗
+ l â—â‚—[Ï€, Owned false] PlaceGhost γ @ MutLty (â— int i32) κ -∗
+ typed_stmt Ï€ E [κ ⊑ₗ{0} []] (ExprS (use{IntOp i32} (!{PtrOp} l)%E)%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hobs Hl". repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ (** ** Write tests *)
+ Lemma test_write1 E L (l : loc) Ï€ fn Ï (s : stmt) (T : val → ∀ rt, type rt → rt → iProp Σ) :
+ l â—â‚—[Ï€, Owned false] PlaceIn 1337%Z @ (â— int i32) -∗
+ typed_stmt Ï€ E L (l <-{IntOp i32} (i2v 42 i32); s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hl".
+ repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ (* does a strong write *)
+ Lemma test_write2 E L (l : loc) Ï€ fn Ï (s : stmt) (T : val → ∀ rt, type rt → rt → iProp Σ) :
+ l â—â‚—[Ï€, Owned false] PlaceIn () @ (â— uninit i32) -∗
+ typed_stmt Ï€ E L (l <-{IntOp i32} (i2v 42 i32); s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros "Hl".
+ repeat liRStep; liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook; solve[fail].
+ Abort.
+
+ Lemma test_write3 E L (l : loc) Ï€ fn γ κ Ï (s : stmt) (T : val → ∀ rt, type rt → rt → iProp Σ) c :
+ L = [κ ⊑ₗ{c} []] →
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn 1337%Z, γ) @ (â— (mut_ref (int i32) κ)) -∗
+ typed_stmt Ï€ E L ((!{PtrOp} l) <-{IntOp i32} (i2v 42 i32); s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros (->) "Hl".
+ repeat liRStep. liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ Lemma test_write_unblock1 E L (l : loc) Ï€ fn Ï (γ γ' : gname) κ (s : stmt) (T : val → ∀ rt, type rt → rt → iProp Σ) c :
+ L = [κ ⊑ₗ{c} []] →
+ gvar_pobs γ (PlaceIn 1337%Z, γ') -∗
+ l â—â‚—[Ï€, Owned false] PlaceGhost γ @ (â— (mut_ref (int i32) κ)) -∗
+ typed_stmt Ï€ E L ((!{PtrOp} l) <-{IntOp i32} (i2v 42 i32); s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros (->) "Hl".
+ repeat liRStep. liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ (** ** Borrow tests *)
+ Lemma test_borrow1 E L l s fn Ï T Ï€ κ :
+ lctx_lft_alive E L κ →
+ named_lfts (<["κ" := κ]> ∅) -∗
+ l â—â‚—[Ï€, Owned false] (PlaceIn 1337%Z) @ (â— (int i32)) -∗
+ typed_stmt Ï€ E L (ExprS (&ref{Mut, "κ"} l)%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros (Hal) "Hlfts Hl".
+ repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ Lemma test_borrow2 E L l s fn Ï T Ï€ κ κ' γ :
+ lctx_lft_alive E L κ →
+ lctx_lft_alive E L κ' →
+ lctx_lft_incl E L κ κ' →
+ named_lfts (<["κ" := κ]> ∅) -∗
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn 1337%Z, γ) @ (â— (mut_ref (int i32) κ')) -∗
+ typed_stmt Ï€ E L (ExprS (&ref{Mut, "κ"} (!{PtrOp} l))%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros (Halκ Halκ' Hincl) "Hlfts Hl".
+ repeat liRStep. liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ Lemma test_borrow3 E L l s fn Ï T Ï€ κ :
+ lctx_lft_alive E L κ →
+ named_lfts (<["κ" := κ]> ∅) -∗
+ l â—â‚—[Ï€, Owned false] (PlaceIn 1337%Z) @ (â— ((int i32))) -∗
+ typed_stmt Ï€ E L (ExprS (&ref{Shr, "κ"} l)%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros (Hal) "Hlfts Hl".
+ repeat liRStep. liShow.
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ (** ** Subtyping *)
+ Lemma test_shortenlft E L l s fn Ï T Ï€ κ κ' c :
+ L = [κ' ⊑ₗ{c} [κ]] →
+ named_lfts (<["κ" := κ]> (<["κ'" := κ']> ∅)) -∗
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn 1337%Z) @ (â— (shr_ref (int i32) κ)) -∗
+ typed_stmt Ï€ E L (ExprS (AnnotExpr 0 (ShortenLftAnnot ["κ'"]) (use{PtrOp} l))%E s) fn [] T ∅ Ï.
+ Proof.
+ iIntros (->) "Hlfts Hl".
+ repeat liRStep; liShow.
+ (* somehow, the typeclass search diverges.. *)
+ (*
+ notypeclasses refine (apply_simpl_and _ _ _ _ _).
+ { Set Typeclasses Debug.
+ eapply simpland_simplunsafe.
+ eapply simpl_and_both_inst.
+ eapply simpl_both_rel_inst1.
+ (*apply simpl_lookup_insert_map_neq. *)
+ refine _.
+ }
+ *)
+ (* using the vm_compute hack in [solve_protected_eq_unfold_tac] makes it work *)
+ (*repeat liRStep. liShow.*)
+ Unshelve. all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+ (* test subtyping on writes below references *)
+ Lemma test_subtype1 E L (l l' : loc) Ï€ fn Ï Î³ γ' γ'' κ κ' κ'' (s : stmt) (T : val → ∀ rt, type rt → rt → iProp Σ) c1 c2 c3:
+ L = [κ ⊑ₗ{c1} [κ''; κ']; κ' ⊑ₗ{c2} [κ'']; κ'' ⊑ₗ{c3} []] →
+ l â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn (PlaceIn 1337%Z, γ), γ') @ (â— (mut_ref (mut_ref (int i32) κ) κ' )) -∗
+ l' â—â‚—[Ï€, Owned false] PlaceIn (PlaceIn 42%Z, γ'') @ (â— (mut_ref (int i32) κ'')) -∗
+ typed_stmt Ï€ E L ((!{PtrOp} l) <-{PtrOp} (use{PtrOp} l'); s)%E fn [] T ∅ Ï.
+ Proof.
+ iIntros (->) "Hl Hl'".
+ do 24 liRStep. liShow.
+ (* successfully moves out the reference *)
+ repeat liRStep. liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Abort.
+
+
+ (* TODO unblocking tests *)
+
+
+End test.
diff --git a/theories/rust_typing/examples/traits.v b/theories/rust_typing/examples/traits.v
new file mode 100644
index 0000000000000000000000000000000000000000..b9c94dc9b952ccea75c5780bddd96e29e91e5bbf
--- /dev/null
+++ b/theories/rust_typing/examples/traits.v
@@ -0,0 +1,493 @@
+From refinedrust Require Import typing.
+
+
+(** Some experiments with traits and trait translation *)
+
+(*
+trait<T> Foo<T> {
+ #[rr::params(x)]
+ #[rr::args(x)]
+ #[rr::returns("()")]
+ fn foo(x : T) -> ();
+}
+ *)
+Section foo_spec.
+ Context `{typeGS Σ}.
+
+ Definition type_of_foo {rt} (T : type rt) :=
+ fn(∀ (x) : rt, (λ Ï, []); x @ T; True)
+ → ∃ () : unit, () @ unit_t; (True).
+End foo_spec.
+
+(*
+fn bar<T>(x : T) where T : Foo {
+ x.foo();
+}
+*)
+Section bar_code.
+ Context (T_ly : layout).
+ Definition bar (Foo_T_foo_loc : loc) : function := {|
+ f_args := [("x", T_ly)];
+ f_local_vars := [
+ ("__0", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ expr: Call Foo_T_foo_loc [use{UntypedOp T_ly} "x"];
+ "__0" <-{ UntypedOp (unit_layout) } zst_val;
+ Return (use{ UntypedOp (unit_layout) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+End bar_code.
+Section bar_spec.
+ Context `{typeGS Σ}.
+ Definition type_of_bar π {rt} (foo_loc : loc) :=
+ fn(∀ (T, r) : (type rt * rt), (λ Ï, []); r @ T;
+ â–¡foo_loc â—áµ¥{Ï€} foo_loc @ function_ptr [T.(ty_layout)] (type_of_foo T))
+ → ∃ (x) : unit, x @ unit_t; (True).
+
+ Lemma bar_typed π {rt} foo_loc T_ly :
+ ⊢ typed_function π (bar T_ly foo_loc) (type_of_bar π (rt := rt) foo_loc).
+ Proof.
+ iStartProof.
+ start_function "bar" ( (T, r) ) => arg_x local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ (* TODO extend the solver to handle these generic things *)
+ Abort.
+End bar_spec.
+
+(*
+impl Foo<i32> for i32 {
+ fn foo(x : i32) -> () {
+ ()
+ }
+}
+ *)
+Section Foo_i32_code.
+ Context `{typeGS Σ}.
+
+ Definition foo_i32 : function := {|
+ f_args := [("x", i32 : layout)];
+ f_local_vars := [
+ ("__0", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "__0" <-{ UntypedOp (unit_layout) } zst_val;
+ Return (use{ UntypedOp (unit_layout) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+End Foo_i32_code.
+Section Foo_i32_spec.
+ Context `{typeGS Σ}.
+
+ Lemma foo_i32_typed π :
+ ⊢ typed_function π (foo_i32) (type_of_foo (int i32)).
+ Proof.
+ iStartProof.
+ start_function "foo_i32" ( r ) => arg_x local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Qed.
+End Foo_i32_spec.
+
+(*
+fn baz() {
+ bar::<i32>(42)
+}
+ *)
+Section baz_code.
+ Context `{typeGS Σ}.
+
+ Definition baz (bar_i32_loc : loc) : function := {|
+ f_args := [];
+ f_local_vars := [
+ ("__0", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ expr: Call bar_i32_loc [Val(i2v 42 i32)];
+ "__0" <-{ UntypedOp (unit_layout) } zst_val;
+ Return (use{ UntypedOp (unit_layout) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+End baz_code.
+Section baz_spec.
+ Context `{typeGS Σ}.
+ Definition type_of_baz :=
+ fn(∀ () : (), (λ Ï, []); True)
+ → ∃ () : unit, () @ unit_t; (True).
+
+ (* Not sure if this is bad: the function requires code for foo, even though it doesn't directly call it (but transitively, and this is locally visible in the code of baz) *)
+ Lemma baz_typed π foo_i32_loc bar_i32_loc :
+ â–¡foo_i32_loc â—áµ¥{Ï€} foo_i32_loc @ function_ptr [i32 : layout] (type_of_foo (int i32)) -∗
+ â–¡bar_i32_loc â—áµ¥{Ï€} bar_i32_loc @ function_ptr [i32 : layout] (type_of_bar Ï€ (rt := Z) foo_i32_loc) -∗
+ typed_function π (baz bar_i32_loc) (type_of_baz).
+ Proof.
+ iStartProof.
+ start_function "foo_i32" ( () ) => local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Qed.
+End baz_spec.
+
+
+(* Q: in this setting, how do I say that certain impls are generic in other things?
+ For instance:
+
+ impl<'a> Foo for &'a i32 {
+ fn foo(x : &'a i32) -> () {
+ ()
+ }
+ }
+
+or:
+ impl<T> Foo for (T, T) {
+ fn foo(x : (T, T)) -> () {
+ ()
+ }
+ }
+
+
+ Essentially: an implementation of the type should be able to introduce new parameters?
+*)
+
+Section Foo_T_T_code.
+ Context `{typeGS Σ}.
+ Axiom T_pair_layout : layout → layout → struct_layout.
+
+ Definition foo_T_T (T_ly : layout) : function := {|
+ f_args := [("x", T_pair_layout T_ly T_ly: layout)];
+ f_local_vars := [
+ ("__0", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ "__0" <-{ UntypedOp (unit_layout) } zst_val;
+ Return (use{ UntypedOp (unit_layout) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+End Foo_T_T_code.
+
+Section Foo_T_T_spec.
+ Context `{typeGS Σ}.
+
+ (* If the function was standing on its own: *)
+ Definition type_of_foo_T_T {rt} :=
+ fn(∀ (T, r) : (type rt * (place_rfn rt * place_rfn rt)), (λ Ï, []); r @ pair_t T T (T_pair_layout T.(ty_layout) T.(ty_layout)); True)
+ → ∃ (x) : unit, x @ unit_t; (True).
+
+ Lemma foo_T_T_typed {rt} T_ly π :
+ ⊢ typed_function π (foo_T_T T_ly) (type_of_foo_T_T (rt :=rt)).
+ Proof.
+ iStartProof.
+ start_function "foo_T_T" ( (T, r) ) => arg_x local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Qed.
+
+ (* but now: (this has the parameter at Coq level) *)
+ Lemma foo_T_T_typed' {rt} T_ly (T : type rt) π :
+ ⊢ typed_function π (foo_T_T T_ly) (type_of_foo (pair_t T T (T_pair_layout T.(ty_layout) T.(ty_layout)))).
+ Proof.
+ iStartProof.
+ start_function "foo_T_T" ( r ) => arg_x local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ Qed.
+ (* i.e., saying: forall T, I can get a function pointer to a function foo<(T, T)> *)
+
+
+ (* Can I prove some subtyping relation between the two?
+ ->: Assume I have the first type assignment. Give me a T for the second one. Give me all the parameters for the second one, now I can instantiate the first one. This works fine.
+ <- Assume I have the seocnd type assignment. Introduce all the parameters for the first one. Now can instantiate the second one.
+ This works fine, too.
+
+
+ Point: It's just a bit of quantifier commutation, nothing bad.
+ In practice: I'd still like to assume the "direct" specification (i.e. the second one), because that better matches and is what I actually require.
+ But the question is at which point to specialize.
+ *)
+End Foo_T_T_spec.
+
+(* Which of the specs can I actually use? *)
+(*
+ fn foobaz<T>(x : T * T) {
+ bar::<(T, T)>(x)
+}
+ *)
+Section foobaz_code.
+ Context `{typeGS Σ}.
+
+ Definition foobaz (T_ly : layout) (bar_T_T_loc : loc) : function := {|
+ f_args := [("x", T_pair_layout T_ly T_ly : layout)];
+ f_local_vars := [
+ ("__0", unit_layout : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ expr: Call bar_T_T_loc [use{UntypedOp (T_pair_layout T_ly T_ly)} "x"];
+ "__0" <-{ UntypedOp (unit_layout) } zst_val;
+ Return (use{ UntypedOp (unit_layout) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+End foobaz_code.
+Section foobaz_spec.
+ Context `{typeGS Σ}.
+
+ (* This uses the spec that we'd give it on its own *)
+ Definition type_of_foobaz {rt} (T_ly : layout) :=
+ fn(∀ (T, r1, r2) : (type rt * rt * rt), (λ Ï, []); (PlaceIn r1, PlaceIn r2) @ pair_t T T (T_pair_layout T_ly T_ly); True)
+ → ∃ () : unit, () @ unit_t; (True).
+
+ Lemma foobaz_typed π {rt} T_ly bar_T_T_loc foo_T_T_loc :
+ â–¡foo_T_T_loc â—áµ¥{Ï€} foo_T_T_loc @ function_ptr [T_pair_layout T_ly T_ly : layout] (type_of_foo_T_T (rt := rt)) -∗
+ â–¡bar_T_T_loc â—áµ¥{Ï€} bar_T_T_loc @ function_ptr [T_pair_layout T_ly T_ly : layout]
+ (type_of_bar π (rt := (place_rfn rt * place_rfn rt)) foo_T_T_loc) -∗
+ typed_function π (foobaz T_ly bar_T_T_loc) (type_of_foobaz (rt := rt) T_ly).
+ Proof.
+ iStartProof.
+ start_function "foobaz" ( ((T & r1) & r2) ) => arg_x local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ (* Of course, this doesn't quite work: we'd need to prove a subsumption for the type now.
+
+ *)
+ (*Qed.*)
+ Abort.
+
+ (* This uses the "direct" spec *)
+ (* Note that we need to "glue" the function assumption directly into the type of foobaz here, as the instance for (T, T) depends on T at the logic-level, not at the function level. *)
+ (* So this one is not as great... *)
+ Definition type_of_foobaz' {rt} π (T_ly : layout) (foo_T_T_loc : loc ) :=
+ fn(∀ (T, r1, r2) : (type rt * rt * rt), (λ Ï, []); (PlaceIn r1, PlaceIn r2) @ pair_t T T (T_pair_layout T_ly T_ly);
+ â–¡foo_T_T_loc â—áµ¥{Ï€} foo_T_T_loc @ function_ptr [T_pair_layout T_ly T_ly : layout] (type_of_foo (pair_t T T (T_pair_layout T_ly T_ly))))
+ → ∃ () : unit, () @ unit_t; (True).
+ Lemma foobaz_typed' π {rt} T_ly bar_T_T_loc foo_T_T_loc :
+ â–¡bar_T_T_loc â—áµ¥{Ï€} bar_T_T_loc @ function_ptr [T_pair_layout T_ly T_ly : layout]
+ (type_of_bar π (rt := (place_rfn rt * place_rfn rt)) foo_T_T_loc) -∗
+ typed_function π (foobaz T_ly bar_T_T_loc) (type_of_foobaz' (rt := rt) π T_ly foo_T_T_loc ).
+ Proof.
+ iStartProof.
+ start_function "foobaz" ( ((T & r1) & r2) ) => arg_x local_0.
+ intros.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+
+ Unshelve.
+ all: li_unshelve_sidecond; sidecond_hook.
+ (*Qed.*)
+ Abort.
+
+ (* Downside: it is basically impossible to properly comprehend this... *)
+ (*
+ Also: I wonder if having to include it in the spec as an assumption, below receiving the type, is the right thing.
+
+ Is there some kind of system as for what belongs where?
+ e.g. why is bar in a different position as foo?
+
+ I guess the difference is: for foo we use an instance which depends on the generic. for bar we merely call a function that works for any parameter and just need to predetermine the layout.
+
+ Also the difference is: When another function uses the function, the _caller_ needs to care about providing the ones that directly appear in the type, while the ones that appear only in the statement are provided by adequacy/the linking theorem.
+
+ TODO: think more about the core principles underlying this.
+ *)
+
+ (*
+ One Q: should I just assume the formulation of a particular instance that is being used (not necessarily fully specialized to how i actually use it) or rather require something specialized to what I require?
+ This might also have implications on where/how we resolve which instances actually get used.
+
+ -> Is a function pointer that I assuem there for one trait instance or for one specializationi of a trait instance?
+ -> It might be somewhere in-between. E.g. consider that we anyways have to specify the layout for generics already, so it can't really be the fully generic instance.
+ -> so maybe just make it consistent and take it as corresponding to concrete specializations.
+ -> otoh, the middle point also seems to be valid, since I anyways need to quantify over the layout; so making it fully generic modulo the layout seems like a fine design choice.
+
+
+ -> Trait resolution time:
+ - if I assume fully specialized, then we essentially resolve it in adequacy when linking up. [also may have multiple function assumptions for the same instances?]
+ Specialization: Instance + layout + type (as far as possible)
+ - if I just assume generic instances, I might in principle have conflicts. These get resolved at codegen time, and the type checker doesn't have to do anything for that, because the locaiton keys which one we use.
+ Specialization: Instance + layout
+ => In both cases, the type system itself doesn't need to do any resolution. It is essentially performed at code generation time. Only the degree of specialization is really different.
+ *)
+End foobaz_spec.
+
+
+
+
+
+(* Improving ergonomics of this handling... can we encapsulate stuff into a typeclass for instance?
+ [ e.g. : does it make sense to somehow shift the resolution to typeclass search instead of doing it statically? ]
+
+
+ Point: other code that uses it doesn't care about the concrete code that implements the trait, but only about the spec + a function ptr (location) implementing it.
+ The existential for the code can be dispatched at linking time (adequacy).
+
+
+ For bundling up a whole trait:
+ - create a definition that takes a list of locations and does a bigsep?
+ For associated types:
+ - what happens if I quantify over some implementor of the trait? -> I get some arbitrary type there. I only know that it is "coherent" among the trait methods
+ one option: quantify externally (universally) over the type.
+ other option: bundle it in the "implements trait" assumption, existentially. I think I prefer the latter, since it makes types easier to read.
+ Need some special support in the start_function automation to destruct that.
+
+ e.g. for Iterator:
+ implements_Iterator {rt] (T : type rt) (fn_locs : list loc) :=
+ ∃ Item_rt (Item_type : type Item_rt),
+ match_functions fn_locs fn_types
+ where fn_types := [next : &mut T -> Option<Item_type>; ... ]
+ and match_functions fn_locs fn_types := [∗ list] l; ty ∈ fn_locs; fn_types, l ◠l @ fn_ptr ty
+
+*)
+
+
+
+
+
+
+
+
+
+(** ** The special case of drop *)
+(** Drop is a bit special due to drop glue:
+
+ Also, there are essentially two Drop "traits" that we care about:
+ - one is the Drop from Rust, which we should try to translate faithfully. It is handled as a normal
+ - the other is DoDrop, which is auto-generated and corresponds to what the drop glue does, roughly.
+ I.e.: it will first call Drop (if it is implemented), then go over all "droppable" fields of a struct and DoDrop them. All non-"droppable" fields are ghost-dropped.
+ Finally, all the ownership collected from the second step is collected and returned.
+
+ "droppable" fields include box, structs, enums, unions. (everything which may have some ownership/memory that needs to be freed?), but in particular not references or integers.
+
+ DoDrop features custom postconditions per type. Arguably, it maybe just shouldn't be seen as a trait, but as some "normal" function that is called in the background.
+
+ NOTE: Drop is also somewhat weird in that it takes only a mutable reference, but often it will deinitialize the type and break some invariants that will normally hold. This is also why Drop::drop can normally not be called explicitly.
+ Conjecture: I think that Drop should always uphold safety invariants of the structs fields, so that the drop glue may afterwards safely call drop on them. But it may be break the safety invariant of the whole struct itself.
+ In most interesting cases, this means that it deinitializes memory and leaves some raw pointers dangling (which doesn't affect their safety invariants!).
+
+ How do we model this adequately?
+
+
+ For the case of box, maybe just manually implement it for now, instead of translating properly. We anyways do that for other things already.
+*)
+
+
+(*
+
+ trait<T> Drop<T> {
+ // NOTE: this mutable reference will in general not uphold the safety invariants associated with it.
+ // Thus, we should semantically interpret it as an owned pointer.
+
+ fn drop(&mut self);
+ }
+
+ impl<T> Drop<Box<T>> {
+ unsafe {
+ drop_in_place(self.ptr.as_ptr());
+ // this should be translated to our intrinsic memdealloc operation
+ // and this is not actually what happens in Rust, because Rust's box doesn't use the Global API
+ let c: NonNull<T> = self.ptr.into();
+ Global.deallocate(c.cast(), Layout::new::<T>())
+
+ // Note: after this, the type contract of Box is broken, because there is no backing memory anymore, even though we just have a mutable ref..
+ }
+ }
+
+
+ unsafe fn drop_in_place<T: ?Sized>(to_drop: *mut T) {
+ // implemented as a compiler intrinsic, doesn't have an actual impl
+ // replaced by drop glue
+ }
+ // i.e.: drop_in_place is essentially the DoDrop function impl.
+
+
+ DoDrop<Box>(mut self) {
+ drop(&mut self);
+ // this isn't really a box here anymore!
+
+ // do nothing, because Unique<T> doesn't have an interesting Drop/DoDrop implementation
+ // I move out of it here, is that fine? I think it should be.
+ Unique::do_drop(self.ptr);
+ }
+
+ *)
+
+(*
+ For the translation: make drop get an owned_ptr essentially (it's really not a mutable reference from a safety invariant perspective).
+
+ Q: how does it differ from a Box?
+ We don't have the right to deallocate the pointer. Maybe we want to have an extra own_ptr type that doesn't have this, similar to lambdarust, and replace the box ltype with that.
+
+ How does box relate to own_ptr?
+ it just has the deallocation permission on top?
+
+ Essentially, we need to handle raw/owned pointers properly. drop should also return some ownership _explicitly_, but what that is will depend on the concrete implementation.
+ In principle, that ownership is similar to a mutable reference: we are not allowed to deallocate or move out of it.
+ But we are allowed to remove some "logical" ownership (e.g. the ownership of an allocated Unique, or the backing memory of a Vec) that is not directly captured by the Rust types, and leave some pointers dangling.
+
+
+ *)
+
+(*
+ What is the simplest working solution to get drop working to a reasonable degree?
+ - two orthogonal challenges: the interface trouble with the Rust Drop trait, and the dynamic drop check stuff
+ - what is safe to say: to handle drop for generics, we will require every type T to provide a drop shim,
+ of type T → () [to support unsized types, need to have *mut T -> () where the raw pointer has ownership.
+ This will consume ownership [ in the unsized case, we afterwards get a location pointing to uninit].
+ For simple types/copy types that don't need any dropping (like i32), this will just be empty.
+ Internally, this should handle both Drop and the drop glue.
+
+
+ For now, we manually write these drop shims. Later on, we generate them from the Drop implementation.
+
+
+ When instantiating generics with mutable references, what about getting back observations?
+ - we may say that the drop shim returns ghost_drop. This may be passed through to the postcond of the function.
+ -> drop shims have custom postconditions per type. How do we formulate this well for generics?
+
+ *)
+
+
+
+
+
+
+
+(* TODO: work out some examples with this *)
+
+(** Some experiments with Drop *)
+
diff --git a/theories/rust_typing/existentials.v b/theories/rust_typing/existentials.v
new file mode 100644
index 0000000000000000000000000000000000000000..eaf19a539b1bca0b752f2ade625b2d814c8c0871
--- /dev/null
+++ b/theories/rust_typing/existentials.v
@@ -0,0 +1,912 @@
+From refinedrust Require Export type ltypes programs.
+From refinedrust Require Import uninit int ltype_rules.
+Set Default Proof Using "Type".
+
+(** * Existential types and invariants *)
+
+ (* Flow when using OpenedLtype:
+ 1. OpenedLtype lt_cur lt_inner lt_full (where lt_cur and lt_inner do not necessarily have the same refinement type?)
+ 2. OpenedLtype lt_cur2 lt_inner lt_full
+ 3. (close) CoreableLtype lt_full (requiring that lt_cur2 is unblockable to lt_inner)
+ - this contains a closing viewshift that can go from the core of lt_inner to lt_full.
+ This is proved when initially unfolding into OpenedLtype.
+ - in the Uniq case of Coreable, pinned borrows play a big role.
+ in the pinned part, we have lt_full. in the current part, we have lt_inner, with a vs to lt_full.
+ => we must already set this up when originally opening up the OpenedLtype -- the VS needs to give us the possibility to close with a different ltype that is unblockable to lt_inner.
+ - the important part that let's us close stuff above again: the core of Coreable is lt_full.
+ i.e. we need to show imp_unblockable
+
+ How does the first part of 3. look for different types?
+ - for our plain stuff, already need to show that the new refinement satisfies the invariant again.
+ This depends on the invariant.
+ - for Cell: we can't borrow below when closing the invariant. Here, we will have a very strong condition: the refinement is allowed to change, but the type has to be directly shiftable to the original type.
+ This will be a condition for the contained type at folding time (we can disregard the place_cond we get from nested folding).
+ *)
+
+(*
+ How do we generally formulate a version where P is not persistent?
+ -> challenge: specifying sharing.
+
+ e.g. what should the thing for Vec look like?
+ - we have ltype ownership in P, which is not persistent.
+ (e.g.: specify a specific Pshr, which is persistent. Then need to know that we can do P ==∗ Pshr.)
+ We could require the shared ltype, and thus that it is contained in a borrow.
+ -> for that, need specific instances for ltypes where sharing is actually persistent. In our case it is fine, as we should not have opened ltypes there.
+ Can we have a general sharing mechanism for ltype ownership, which would be required here?
+ - in the case of â— ty, it should work at least for the Owned case. Probably also for Uniq.
+ - in general, only if it is does not contain OpenedLtype or BlockedLtype; but ShrBlocked should be fine.
+ (but for shrblocked only under conditions: the sharing lifetime must be at most as long as the existing shrblocked -- lifting this seems possible, but more complicated)
+ Sharing below pinned borrows uses the new reborrow/unnesting laws.
+ -
+
+
+ *)
+(*Definition ltype_shareable := .... *)
+
+(** ** Existential types with "simple" invariants that are tacked on via a separating conjunction *)
+(* Note: this does not allow for, e.g., Cell or Mutex -- we will need a different version using non-atomic/atomic invariants for those *)
+
+Record ex_inv_def `{!typeGS Σ} (X : Type) (Y : Type) : Type := mk_ex_inv_def' {
+ inv_P : thread_id → X → Y → iProp Σ;
+ inv_P_shr : thread_id → lft → X → Y → iProp Σ;
+ (* extra requirements on E and lfts, e.g. in case that P asserts extra location ownership *)
+ inv_P_lfts : list lft;
+ inv_P_wf_E : elctx;
+ inv_P_shr_pers : ∀ π κ x y, Persistent (inv_P_shr π κ x y);
+ inv_P_shr_mono : ∀ π κ κ' x y, κ' ⊑ κ -∗ inv_P_shr π κ x y -∗ inv_P_shr π κ' x y;
+ inv_P_share :
+ ∀ F π κ x y q,
+ lftE ⊆ F →
+ rrust_ctx -∗
+ let κ' := lft_intersect_list inv_P_lfts in
+ q.[κ ⊓ κ'] -∗
+ &{κ} (inv_P π x y) -∗
+ logical_step F (inv_P_shr π κ x y ∗ q.[κ ⊓ κ']);
+}.
+(* Stop Typeclass resolution for the [inv_P_shr_pers] argument, to make it more deterministic. *)
+Definition mk_ex_inv_def `{!typeGS Σ} {X Y : Type}
+ (inv_P : thread_id → X → Y → iProp Σ)
+ inv_P_shr
+ inv_P_lfts
+ (inv_P_wf_E : elctx)
+ (inv_P_shr_pers : TCNoResolve (∀ (π : thread_id) (κ : lft) (x : X) (y : Y), Persistent (inv_P_shr π κ x y)))
+ inv_P_shr_mono
+ inv_P_share := mk_ex_inv_def' _ _ _ _ inv_P inv_P_shr inv_P_lfts inv_P_wf_E inv_P_shr_pers inv_P_shr_mono inv_P_share.
+Global Arguments inv_P {_ _ _ _}.
+Global Arguments inv_P_shr {_ _ _ _}.
+Global Arguments inv_P_lfts {_ _ _ _}.
+Global Arguments inv_P_wf_E {_ _ _ _}.
+Global Arguments inv_P_share {_ _ _ _}.
+Global Arguments inv_P_shr_mono {_ _ _ _}.
+Global Arguments inv_P_shr_pers {_ _ _ _}.
+Global Existing Instance inv_P_shr_pers.
+
+(** Smart constructor for persistent and timeless [P] *)
+Program Definition mk_pers_ex_inv_def `{!typeGS Σ} {X : Type} {Y : Type} (P : X → Y → iProp Σ)
+ (_: TCNoResolve (∀ x y, Persistent (P x y))) (_:TCNoResolve (∀ x y, Timeless (P x y))) : ex_inv_def X Y :=
+ mk_ex_inv_def (λ _, P) (λ _ _, P) [] [] _ _ _.
+Next Obligation.
+ rewrite /TCNoResolve.
+ eauto with iFrame.
+Qed.
+Next Obligation.
+ rewrite /TCNoResolve. eauto with iFrame.
+Qed.
+Next Obligation.
+ rewrite /TCNoResolve.
+ iIntros (???? P ?? F ? κ x y q ?) "#CTX Htok Hb".
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply fupd_logical_step.
+ rewrite right_id. iMod (bor_persistent with "LFT Hb Htok") as "(>HP & Htok)"; first done.
+ iApply logical_step_intro. by iFrame.
+Qed.
+
+Section ex.
+ Context `{!typeGS Σ}.
+ (* [Y] is the abstract refinement type, [X] is the inner refinement type *)
+ Context (X Y : Type)
+ (* invariant on the contained refinement *)
+ (P : ex_inv_def X Y)
+ .
+
+ (** Provide an abstraction over [ty], by accepting a refinement [Y] and existentially quantifying over [X].
+ [P] is a predicate specifying an invariant, potentially containing additional ownership.
+ [R] determines a relation between the inner and outer refinement. *)
+ Program Definition ex_plain_t (ty : type X) : type Y := {|
+ ty_own_val π r v :=
+ (∃ x : X, P.(inv_P) π x r ∗ ty.(ty_own_val) π x v)%I;
+ ty_shr κ π r l :=
+ (∃ x : X, P.(inv_P_shr) π κ x r ∗ ty.(ty_shr) κ π x l)%I;
+ ty_syn_type := ty.(ty_syn_type);
+ ty_has_op_type ot mt := ty.(ty_has_op_type) ot mt;
+ ty_sidecond := ty.(ty_sidecond);
+ (* TODO generalize ghost_drop in the type def *)
+ ty_ghost_drop π r := (∃ x, P.(inv_P) π x r ∗ ty.(ty_ghost_drop) π x)%I;
+ ty_lfts := P.(inv_P_lfts) ++ ty.(ty_lfts);
+ ty_wf_E := P.(inv_P_wf_E) ++ ty.(ty_wf_E);
+ |}.
+ Next Obligation.
+ iIntros (ty π r v) "(%x & HP & Hv)".
+ by iApply ty_has_layout.
+ Qed.
+ Next Obligation.
+ iIntros (ty ot mt Hot). by eapply ty_op_type_stable.
+ Qed.
+ Next Obligation.
+ iIntros (ty π r v) "(%x & HP & Hv)". by iApply ty_own_val_sidecond.
+ Qed.
+ Next Obligation.
+ iIntros (ty κ π l r) "(%x & HP & Hv)". by iApply ty_shr_aligned.
+ Qed.
+ Next Obligation.
+ iIntros (ty E κ l ly π r q ?) "#(LFT & TIME & LLCTX) Htok %Halg %Hly Hlb Hb".
+ iApply fupd_logical_step.
+ setoid_rewrite bi.sep_exist_l. setoid_rewrite bi_exist_comm.
+ iDestruct "Htok" as "(Htok & Htok2)".
+ rewrite lft_intersect_list_app.
+ rewrite -{1}lft_tok_sep -{1}lft_tok_sep. iDestruct "Htok" as "(Htok & HtokP & Htoki)".
+ rewrite lft_intersect_assoc. rewrite -lft_tok_sep. iDestruct "Htok2" as "(Htok2 & Htoki2)".
+ iMod (bor_exists_tok with "LFT Hb Htok") as "(%x & Hb & Htok)"; first solve_ndisj.
+ iPoseProof (bor_iff _ _ (P.(inv_P) Ï€ x r ∗ (∃ a : val, l ↦ a ∗ a â—áµ¥{ Ï€} x @ ty)) with "[] Hb") as "Hb".
+ { iNext. iModIntro. iSplit; [iIntros "(% & ? & ? & ?)" | iIntros "(? & (% & ? & ?))"]; eauto with iFrame. }
+ iMod (bor_sep with "LFT Hb") as "(HP & Hb)"; first solve_ndisj.
+ iPoseProof (P.(inv_P_share) E with "[$LFT $TIME $LLCTX] Htok2 HP") as "HP"; first done.
+ iCombine "Htok Htoki" as "Htok". rewrite lft_tok_sep.
+ iPoseProof (ty_share with "[$] Htok [//] [//] Hlb Hb") as "Hb"; first solve_ndisj.
+ iModIntro. iApply (logical_step_compose with "HP"). iApply (logical_step_wand with "Hb").
+ iIntros "(Hshr & Htok) (HP & Htok2)".
+ iSplitL "HP Hshr". { eauto with iFrame. }
+ iCombine "Htok2 Htoki2" as "Htok2". rewrite lft_tok_sep -lft_intersect_assoc.
+ iCombine "Htok HtokP" as "Htok". rewrite lft_tok_sep -lft_intersect_assoc.
+ rewrite [lft_intersect_list (ty_lfts ty) ⊓ lft_intersect_list P.(inv_P_lfts)]lft_intersect_comm.
+ iCombine "Htok Htok2" as "$".
+ Qed.
+ Next Obligation.
+ iIntros (ty κ κ' π r l) "#Hincl (%x & HP & Hshr)".
+ iExists x. iSplitL "HP".
+ { by iApply P.(inv_P_shr_mono). }
+ iApply (ty_shr_mono with "Hincl Hshr").
+ Qed.
+ Next Obligation.
+ iIntros (ty π r v F ?) "(%x & HP & Ha)".
+ iPoseProof (ty_own_ghost_drop with "Ha") as "Ha"; first done.
+ iApply (logical_step_compose with "Ha").
+ iApply logical_step_intro.
+ iIntros "Hdrop". eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (ty ot mt st π r v Hot) "(%x & HP & Hv)".
+ iPoseProof (ty_memcast_compat with "Hv") as "Hm"; first done.
+ destruct mt; eauto with iFrame.
+ Qed.
+End ex.
+
+Notation "'∃;' P ',' τ" := (ex_plain_t _ _ P τ) (at level 40) : stdpp_scope.
+Section open.
+ Context `{!typeGS Σ}.
+ Context {rt X : Type} (P : ex_inv_def rt X).
+
+ Lemma ex_plain_t_open_owned F π (ty : type rt) wl l (x : X) :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned wl] PlaceIn x @ (â— (∃; P, ty)) ={F}=∗
+ ∃ r : rt, P.(inv_P) π r x ∗
+ l â—â‚—[Ï€, Owned false] PlaceIn r @ (â— ty) ∗
+ (∀ rt' (lt' : ltype rt') (r' : place_rfn rt'),
+ l â—â‚—[Ï€, Owned false] r' @ lt' -∗
+ ⌜ltype_st lt' = ty_syn_type ty⌠-∗
+ l â—â‚—[Ï€, Owned wl] r' @
+ (OpenedLtype lt' (◠ty) (◠∃; P, ty)
+ (λ (r : rt) (x : X), P.(inv_P) π r x)
+ (λ r x, True)))%I.
+ Proof.
+ iIntros (?) "Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcred & %x' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iDestruct "Hb" as "(%v & Hl & %r & HP & Hv)".
+ iDestruct "Hrfn" as "<-".
+ iModIntro. iExists r. iFrame.
+ iSplitL "Hl Hv".
+ { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iFrame "#%". iSplitR; first done.
+ iExists r. iSplitR; first done. iModIntro. eauto with iFrame. }
+ iIntros (rt' lt' r') "Hb %Hst".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iExists ly. rewrite Hst. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ iFrame. clear -Halg Hly.
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred' !>".
+ iIntros (r' r'' κs) "HP".
+ iSplitR; first done.
+ iIntros "Hdead Hl".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly' & _ & _ & Hsc' & _ & _ & %r0 & -> & >Hb)".
+ iDestruct "Hb" as "(%v' & Hl & Hv)".
+ iMod ("HP" with "Hdead" ) as "HP".
+ iModIntro.
+ rewrite ltype_own_core_equiv. simp_ltypes.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. simpl. iFrame "#%". iFrame.
+ iExists r''. iSplitR; first done. iModIntro.
+ iExists v'. iFrame. iExists r0. by iFrame.
+ Qed.
+
+ (* We open this into a ShadowedLtype for [Shared].
+ In terms of ownership, this doesn't do anything interesting, because we are working with persistent sharing predicates.
+ However, we basically "overrride" the type at this place with [â— ty], in order to not have to eliminate the existentials multiple times on subsequent accesses.
+ This allows us to retain more information.
+
+ This is not to be confused with "properly opening" the shared type, which we can only do for types with interior mutability.
+ *)
+ Lemma ex_plain_t_open_shared F π (ty : type rt) κ l (x : X) :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Shared κ] PlaceIn x @ (â— (∃; P, ty)) ={F}=∗
+ ∃ r : rt, P.(inv_P_shr) π κ r x ∗
+ l â—â‚—[Ï€, Shared κ] PlaceIn x @ (ShadowedLtype (â— ty) #r (â— (∃; P, ty))).
+ Proof.
+ iIntros (?) "#Ha". iPoseProof "Ha" as "Hb".
+ rewrite {2}ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & Hsc & Hlb & %r' & -> & #Hb)".
+ iMod (fupd_mask_mono with "Hb") as "#Hb'"; first done. iClear "Hb".
+ iDestruct "Hb'" as "(%r & HP & Hb)".
+ iModIntro. iExists r. iFrame "#".
+ rewrite ltype_own_shadowed_unfold /shadowed_ltype_own.
+ simp_ltypes. iSplitR; first done. iSplitL; last done.
+ iApply ltype_own_ofty_unfold. rewrite /lty_of_ty_own.
+ iExists ly. iSplitR; first done. iSplitR; first done. iFrame "#".
+ iExists r. iSplitR; first done. iModIntro. done.
+ Qed.
+
+ Lemma ex_plain_t_open_uniq F π (ty : type rt) l (x : X) q κ γ κs :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ (q.[κ] ={lftE}=∗ llft_elt_toks κs) -∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn x @ (â— (∃; P, ty)) ={F}=∗
+ ∃ r : rt, P.(inv_P) π r x ∗
+ l â—â‚—[Ï€, Owned false] PlaceIn r @ (â— ty) ∗
+ (∀ rt' (lt' : ltype rt') (r' : place_rfn rt'),
+ l â—â‚—[Ï€, Owned false] r' @ lt' -∗
+ ⌜ltype_st lt' = ty_syn_type ty⌠-∗
+ l â—â‚—[Ï€, Uniq κ γ] r' @
+ (OpenedLtype (lt') (◠ty) (◠∃; P, ty)
+ (λ (r : rt) (x : X), P.(inv_P) π r x)
+ (λ r x, llft_elt_toks κs)))%I.
+ Proof.
+ (* TODO duplicated a lot with opened_ltype_create_uniq_simple, mostly due to the different invariant.
+ Can we generalize? *)
+ iIntros (?) "#(LFT & TIME & LLCTX) Htok Hcl_tok Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcred & Hat & Hrfn & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (pinned_bor_acc_strong lftE with "LFT Hb Htok") as "(%κ' & #Hincl & Hb & ? & Hcl_b)"; first done.
+ iMod "Hcl_F" as "_".
+ iApply (lc_fupd_add_later with "Hcred1"). iNext.
+ iDestruct "Hb" as "(%r' & Hauth & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ iPoseProof (gvar_agree with "Hauth Hrfn") as "#->".
+ iDestruct "Hb" as "(%v & Hl & %r & HP & Hv)".
+ iModIntro. iExists r. iFrame.
+ iSplitL "Hl Hv".
+ { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iFrame "#%". iSplitR; first done.
+ iExists r. iSplitR; first done. iModIntro. eauto with iFrame. }
+ iIntros (rt' lt' r') "Hb %Hst".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iExists ly. rewrite Hst. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ iFrame. clear -Hly Halg.
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "Hcred' Hat". iModIntro.
+ iIntros (own_lt_cur' κs' r0 r') "HP #Hincl' Hown #Hub".
+ rewrite ltype_own_core_equiv. simp_ltypes.
+ (* update *)
+ iMod (gvar_update r' with "Hauth Hrfn") as "(Hauth & $)".
+
+ iAssert (□ ([†κ] ={lftE}=∗ lft_dead_list κs'))%I as "#Hkill".
+ { iModIntro. iIntros "#Hdead".
+ iApply big_sepL_fupd. iApply big_sepL_intro. iIntros "!>" (?? Hlook).
+ iPoseProof (big_sepL_lookup with "Hincl'") as "Ha"; first done.
+ iApply (lft_incl_dead with "[] Hdead"); first done.
+ done. }
+ (*iApply lft_incl_trans; done. }*)
+
+ (* close the borrow *)
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ set (V := (gvar_auth γ r' ∗ (lft_dead_list κs' ={lftE}=∗ P.(inv_P) π r0 r') ∗ own_lt_cur' π r0 l)%I).
+ iMod ("Hcl_b" $! V with "[] Hcred1 [HP Hown Hauth ]") as "(Hb & Htok)".
+ { iNext. iIntros "(Hauth & HP & Hb) Hdead".
+ iModIntro. iNext. iExists r'. iFrame.
+ iMod (lft_incl_dead _ κ with "[] Hdead") as "#Hdead"; [done.. | ].
+ iMod ("Hkill" with "Hdead") as "#Hdead'".
+ iMod ("HP" with "Hdead'") as "HP".
+ iMod ("Hub" with "Hdead' Hb") as "Hown".
+ rewrite {2}ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hown" as "(% &_ & _ & _ & _ & _ & %r1 & -> & >(%v1 & Hl & Hv))".
+ iModIntro. iExists v1. iFrame. iExists r1. iFrame. }
+ { iNext. rewrite /V. iFrame. }
+ iMod ("Hcl_tok" with "Htok") as "$".
+
+ (* show that we can shift it back *)
+ iModIntro. iIntros "#Hdead Hobs". iModIntro.
+ rewrite ltype_own_core_equiv. simp_ltypes.
+ rewrite (ltype_own_ofty_unfold _ (Uniq _ _)) /lty_of_ty_own.
+ iExists ly. iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iFrame.
+ iModIntro.
+ iApply (pinned_bor_shorten with "Hincl").
+ iApply (pinned_bor_impl with "[] Hb").
+ iNext. iModIntro. iSplit; first last. { eauto. }
+ iIntros "(Hauth & HP & Hcur)".
+ iExists r'. iFrame. iMod ("Hub" with "Hdead Hcur") as "Hb".
+ iClear "Hub". rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(% & _ & _ & _ & _ & _ & Hb)".
+ iDestruct "Hb" as "(%r1 & -> & >(%v1 & Hl & Hv1))".
+ iMod ("HP" with "Hdead") as "HP".
+ iModIntro. iExists v1. iFrame. iExists r1. iFrame.
+ Qed.
+End open.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+ Context {rt X : Type}.
+ Lemma weak_subtype_ex_plain_t E L (P1 P2 : ex_inv_def rt X) (ty1 ty2 : type rt) (r1 r2 : X) T :
+ ⌜r1 = r2⌠∗ ⌜ty1 = ty2⌠∗ ⌜P1 = P2⌠∗ T
+ ⊢ weak_subtype E L r1 r2 (∃; P1, ty1) (∃; P2, ty2) T.
+ Proof.
+ iIntros "(-> & -> & -> & HT)".
+ iIntros (? ?) "#CTX #HE HL".
+ iFrame. iApply type_incl_refl.
+ Qed.
+ Global Instance weak_subtype_ex_plain_t_inst E L P1 P2 (ty1 ty2 : type rt) (r1 r2 : X) :
+ Subtype E L r1 r2 (∃; P1, ty1) (∃; P2, ty2) := λ T, i2p (weak_subtype_ex_plain_t E L P1 P2 ty1 ty2 r1 r2 T).
+ Lemma mut_subtype_ex_plain_t E L (P1 P2 : ex_inv_def rt X) (ty1 ty2 : type rt) T :
+ ⌜P1 = P2⌠∗ ⌜ty1 = ty2⌠∗ T
+ ⊢ mut_subtype E L (∃; P1, ty1) (∃; P2, ty2) T.
+ Proof.
+ iIntros "(-> & -> & HT)". iFrame. iPureIntro. intros ?. apply subtype_refl.
+ Qed.
+ Global Instance mut_subtype_ex_plain_t_inst E L P1 P2 (ty1 ty2 : type rt) :
+ MutSubtype E L (∃; P1, ty1) (∃; P2, ty2) := λ T, i2p (mut_subtype_ex_plain_t E L P1 P2 ty1 ty2 T).
+ Lemma mut_eqtype_ex_plain_t E L (P1 P2 : ex_inv_def rt X) (ty1 ty2 : type rt) T :
+ ⌜P1 = P2⌠∗ ⌜ty1 = ty2⌠∗ T ⊢ mut_eqtype E L (∃; P1, ty1) (∃; P2, ty2) T.
+ Proof.
+ iIntros "(-> & -> & HT)". iFrame. iPureIntro. intros ?. apply eqtype_refl.
+ Qed.
+ Global Instance mut_eqtype_ex_plain_t_inst E L P1 P2 (ty1 ty2 : type rt) :
+ MutEqtype E L (∃; P1, ty1) (∃; P2, ty2) := λ T, i2p (mut_eqtype_ex_plain_t E L P1 P2 ty1 ty2 T).
+End subtype.
+
+Section stratify.
+ Context `{!typeGS Σ}.
+ Context {rt X : Type} (P : ex_inv_def rt X).
+
+ (** Subsumption rule for introducing an existential *)
+ (* TODO could have a more specific instance for persistent invariants with pers = true *)
+ Lemma owned_subtype_ex_plain_t π E L (ty : type rt) (r : rt) (r' : X) T :
+ (prove_with_subtype E L false ProveDirect (P.(inv_P) π r r') (λ L1 _ R, R -∗ T L1))
+ ⊢ owned_subtype π E L false r r' ty (∃; P, ty) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L2 & % & %R2 & >(Hinv & HR2) & HL & HT)".
+ iExists L2. iFrame. iPoseProof ("HT" with "HR2") as "$". iModIntro.
+ iSplitR; last iSplitR.
+ - simpl. iPureIntro.
+ intros ly1 ly2 Hly1 HLy2. f_equiv. by eapply syn_type_has_layout_inj.
+ - simpl. eauto.
+ - iIntros (v) "Hv0".
+ iEval (rewrite /ty_own_val/=).
+ eauto with iFrame.
+ Qed.
+ Global Instance owned_subtype_ex_plain_t_inst π E L (ty : type rt) (r : rt) (r' : X) :
+ OwnedSubtype π E L false r r' ty (∃; P, ty) :=
+ λ T, i2p (owned_subtype_ex_plain_t π E L ty r r' T).
+
+ (*
+ Lemma owned_subtype_unfold_ex_plain_t π E L (ty : type rt) (r : rt) (r' : X) T :
+ (∀ r2 : rt, introduce_with_hooks E L (P.(inv_P) π r2 r') (λ L1,
+ owned_subtype π E L1 false r2 r ty ty T)) -∗
+ owned_subtype π E L false r' r (∃; P, ty) ty T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL".
+
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L2 & % & %R2 & >(Hinv & HR2) & HL & HT)".
+ iExists L2. iFrame. iPoseProof ("HT" with "HR2") as "$". iModIntro.
+ iSplitR; last iSplitR.
+ - simpl. iPureIntro.
+ intros ly1 ly2 Hly1 HLy2. f_equiv. by eapply syn_type_has_layout_inj.
+ - simpl. eauto.
+ - iIntros (v) "Hv0".
+ iEval (rewrite /ty_own_val/=).
+ eauto with iFrame.
+ Qed.
+ Global Instance owned_subtype_ex_plain_t_inst π E L (ty : type rt) (r : rt) (r' : X) :
+ OwnedSubtype π E L false r r' ty (∃; P, ty) :=
+ λ T, i2p (owned_subtype_ex_plain_t π E L ty r r' T).
+ *)
+
+
+
+ (** Stratification rules *)
+
+ (* Unfolding by stratification *)
+ Lemma stratify_unfold_ex_plain_t_owned {M} π E L smu sa (sm : M) l (ty : type rt) x wl T :
+ (∀ r, P.(inv_P) π r x -∗ stratify_ltype π E L smu StratDoUnfold sa sm l (◠ty) (#r) (Owned false)
+ (λ L2 R' rt' lt' r',
+ T L2 R' _ (OpenedLtype lt' (◠ty) (◠(∃; P, ty)) (λ (r : rt) (x : X), P.(inv_P) π r x) (λ r x, True)) r'))
+ ⊢ stratify_ltype π E L smu StratDoUnfold sa sm l (◠(∃; P, ty)) (#x) (Owned wl) T.
+ Proof.
+ iIntros "HT". iIntros (F ??) "#CTX #HE HL Hb".
+ iMod (ex_plain_t_open_owned with "Hb") as "(%r & HP & Hb & Hcl)"; first done.
+ iMod ("HT" with "HP [//] [//] CTX HE HL Hb") as "Ha".
+ iDestruct "Ha" as "(%L2 & %R' & %rt' & %lt' & %r' & HL & %Hst & Hstep & HT)".
+ iExists _, _, _, _, _. iFrame.
+ iModIntro.
+ iSplitR. { iPureIntro. simp_ltypes. rewrite -Hst. done. }
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro. iIntros "(Hb & $)".
+ iApply ("Hcl" with "Hb []").
+ iPureIntro; done.
+ Qed.
+ (*Global Instance stratify_unfold_ex_plain_t_owned_inst {M} π E L smu sa (sm : M) l (ty : type rt) x wl :*)
+ (*StratifyLtype π E L smu StratDoUnfold sa sm l (◠(∃; P, ty))%I (PlaceIn x) (Owned wl) :=*)
+ (*λ T, i2p (stratify_unfold_ex_plain_t_owned π E L smu sa sm l ty x wl T).*)
+
+ Lemma stratify_unfold_ex_plain_t_uniq {M} π E L smu sa (sm : M) l (ty : type rt) x κ γ T :
+ li_tactic (lctx_lft_alive_count_goal E L κ) (λ '(κs, L'),
+ (∀ r, P.(inv_P) π r x -∗ stratify_ltype π E L' smu StratDoUnfold sa sm l (◠ty) (PlaceIn r) (Owned false)
+ (λ L2 R' rt' lt' r',
+ T L2 R' _ (OpenedLtype lt' (◠ty) (◠(∃; P, ty)) (λ (r : rt) (x : X), P.(inv_P) π r x) (λ r x, llft_elt_toks κs)) r')))
+ ⊢ stratify_ltype π E L smu StratDoUnfold sa sm l (◠(∃; P, ty)) (PlaceIn x) (Uniq κ γ) T.
+ Proof.
+ rewrite /lctx_lft_alive_count_goal. iIntros "(%κs & %L' & %Hal & HT)".
+ iIntros (F ??) "#CTX #HE HL Hb".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (lctx_lft_alive_count_tok lftE with "HE HL") as "(%q & Htok & Hcl_tok & HL)"; [done.. | ].
+ iMod "Hcl_F" as "_".
+ iMod (ex_plain_t_open_uniq with "CTX Htok Hcl_tok Hb") as "(%r & HP & Hb & Hcl)"; first done.
+ iMod ("HT" with "HP [//] [//] CTX HE HL Hb") as "Ha".
+ iDestruct "Ha" as "(%L2 & %R' & %rt' & %lt' & %r' & HL & %Hst & Hstep & HT)".
+ iExists _, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. simp_ltypes. done. }
+ iModIntro.
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro. iIntros "(Hb & $)".
+ iApply ("Hcl" with "Hb []").
+ done.
+ Qed.
+ (*Global Instance stratify_unfold_ex_plain_t_uniq_inst {M} π E L smu sa (sm : M) l (ty : type rt) x κ γ :*)
+ (*StratifyLtype π E L smu StratDoUnfold sa sm l (◠(∃; P, ty))%I (PlaceIn x) (Uniq κ γ) :=*)
+ (*λ T, i2p (stratify_unfold_ex_plain_t_uniq π E L smu sa sm l ty x κ γ T).*)
+
+
+ Lemma stratify_unfold_ex_plain_t_shared {M} π E L smu sa (sm : M) l (ty : type rt) x κ T :
+ (∀ r, P.(inv_P_shr) π κ r x -∗ stratify_ltype π E L smu StratDoUnfold sa sm l (◠ty) (PlaceIn r) (Shared κ)
+ (λ L2 R' rt' lt' r',
+ ∃ r'', ⌜r' = PlaceIn r''⌠∗ T L2 R' _ (ShadowedLtype lt' #r'' (◠(∃; P, ty))) (PlaceIn x)))
+ ⊢ stratify_ltype π E L smu StratDoUnfold sa sm l (◠(∃; P, ty)) (PlaceIn x) (Shared κ) T.
+ Proof.
+ iIntros "HT" (F ??) "#CTX #HE HL Hb".
+ iMod (ex_plain_t_open_shared with "Hb") as "(%r & HP & Hb)"; first done.
+ iPoseProof (shadowed_ltype_acc_cur with "Hb") as "(Hb & Hcl_b)".
+ iMod ("HT" with "HP [//] [//] CTX HE HL Hb") as (L2 R' rt' lt' r') "(HL & Hst & Hstep & HT)".
+ iDestruct "HT" as "(%r'' & -> & HT)".
+ iModIntro. iExists _, _, _, _, _. iFrame.
+ simp_ltypes. iSplitR; first done.
+ iApply (logical_step_wand with "Hstep"). iIntros "(Ha & $)".
+ iApply ("Hcl_b" with "Hst Ha").
+ Qed.
+ (*Global Instance stratify_unfold_ex_plain_t_shared_inst {M} π E L smu sa (sm : M) l (ty : type rt) x κ :*)
+ (*StratifyLtype π E L smu StratDoUnfold sa sm l (◠(∃; P, ty))%I (PlaceIn x) (Shared κ) :=*)
+ (*λ T, i2p (stratify_unfold_ex_plain_t_shared π E L smu sa sm l ty x κ T).*)
+
+ (** Unfolding by place access *)
+ Lemma typed_place_ex_plain_t_owned π E L l (ty : type rt) x wl bmin K T :
+ (∀ r, introduce_with_hooks E L (P.(inv_P) π r x) (λ L2, typed_place π E L2 l
+ (OpenedLtype (◠ty) (◠ty) (◠(∃; P, ty)) (λ (r : rt) (x : X), P.(inv_P) π r x) (λ r x, True)) (#r) bmin (Owned wl) K
+ (λ L2 κs li b2 bmin' rti ltyi ri strong weak,
+ (* no weak update possible - after all, we have just opened this invariant *)
+ T L2 κs li b2 bmin' rti ltyi ri strong None)))
+ ⊢ typed_place π E L l (◠(∃; P, ty))%I (#x) bmin (Owned wl) K T.
+ Proof.
+ iIntros "HT". iIntros (F ???) "#CTX #HE HL Hincl Hb Hcont".
+ iApply fupd_place_to_wp.
+ iMod (ex_plain_t_open_owned with "Hb") as "(%r & HP & Hb & Hcl)"; first done.
+ iPoseProof ("Hcl" with "Hb []") as "Hb"; first done.
+ iMod ("HT" with "[] HE HL HP") as "(%L2 & HL & HT)"; first done.
+ iApply ("HT" with "[//] [//] CTX HE HL Hincl Hb").
+ iModIntro. iIntros (L' κs l2 b2 bmin0 rti ltyi ri strong weak) "Hincl Hl Hc".
+ iApply ("Hcont" with "Hincl Hl").
+ iSplit; last done.
+ iDestruct "Hc" as "[Hc _]".
+ destruct strong; last done.
+ simp_ltypes. done.
+ Qed.
+ Global Instance typed_place_ex_plain_t_owned_inst π E L l (ty : type rt) x wl bmin K `{!TCDone (K ≠[])} :
+ TypedPlace E L π l (◠(∃; P, ty))%I #x bmin (Owned wl) K | 15 :=
+ λ T, i2p (typed_place_ex_plain_t_owned π E L l ty x wl bmin K T).
+
+ Lemma typed_place_ex_plain_t_uniq π E L l (ty : type rt) x κ γ bmin K T :
+ li_tactic (lctx_lft_alive_count_goal E L κ) (λ '(κs, L2),
+ (∀ r, introduce_with_hooks E L2 (P.(inv_P) π r x) (λ L3, typed_place π E L3 l
+ (OpenedLtype (◠ty) (◠ty) (◠(∃; P, ty)) (λ (r : rt) (x : X), P.(inv_P) π r x) (λ r x, llft_elt_toks κs)) (#r) bmin (Uniq κ γ) K
+ (λ L4 κs li b2 bmin' rti ltyi ri strong weak,
+ (* no weak update possible - after all, we have just opened this invariant *)
+ T L4 κs li b2 bmin' rti ltyi ri strong None))))
+ ⊢ typed_place π E L l (◠(∃; P, ty))%I (#x) bmin (Uniq κ γ) K T.
+ Proof.
+ iIntros "HT". iIntros (F ???) "#CTX #HE HL Hincl Hb Hcont".
+ rewrite /lctx_lft_alive_count_goal.
+ iDestruct "HT" as "(%κs & %L' & %Hal & HT)".
+ iApply fupd_place_to_wp.
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (lctx_lft_alive_count_tok lftE with "HE HL") as "(%q & Htok & Hcl_tok & HL)"; [done.. | ].
+ iMod "Hcl_F" as "_".
+ iMod (ex_plain_t_open_uniq with "CTX Htok Hcl_tok Hb") as "(%r & HP & Hb & Hcl)"; first done.
+ iPoseProof ("Hcl" with "Hb []") as "Hb"; first done.
+ iMod ("HT" with "[] HE HL HP") as "(%L2 & HL & HT)"; first done.
+ iApply ("HT" with "[//] [//] CTX HE HL Hincl Hb").
+ iModIntro. iIntros (L'' κs' l2 b2 bmin0 rti ltyi ri strong weak) "Hincl Hl Hc".
+ iApply ("Hcont" with "Hincl Hl").
+ iSplit; last done.
+ iDestruct "Hc" as "[Hc _]".
+ destruct strong; last done.
+ simp_ltypes. done.
+ Qed.
+ Global Instance typed_place_ex_plain_t_uniq_inst π E L l (ty : type rt) x κ γ bmin K `{!TCDone (K ≠[])} :
+ TypedPlace E L π l (◠(∃; P, ty))%I #x bmin (Uniq κ γ) K | 15 :=
+ λ T, i2p (typed_place_ex_plain_t_uniq π E L l ty x κ γ bmin K T).
+
+ Lemma typed_place_ex_plain_t_shared π E L l (ty : type rt) x κ bmin K T :
+ (∀ r, introduce_with_hooks E L (P.(inv_P_shr) π κ r x) (λ L2, typed_place π E L2 l (ShadowedLtype (◠ty) #r (◠(∃; P, ty))) (#x) bmin (Shared κ) K
+ (λ L3 κs li b2 bmin' rti ltyi ri strong weak,
+ (* TODO: maybe also allow weak access? *)
+ T L3 κs li b2 bmin' rti ltyi ri strong None)))
+ ⊢ typed_place π E L l (◠(∃; P, ty))%I (#x) bmin (Shared κ) K T.
+ Proof.
+ iIntros "HT". iIntros (F ???) "#CTX #HE HL Hincl Hb Hcont".
+ iApply fupd_place_to_wp.
+ iMod (ex_plain_t_open_shared with "Hb") as "(%r & HP & Hb)"; first done.
+ iMod ("HT" with "[] HE HL HP") as "(%L2 & HL & HT)"; first done.
+ iApply ("HT" with "[//] [//] CTX HE HL Hincl Hb").
+ iModIntro. iIntros (L'' κs' l2 b2 bmin0 rti ltyi ri strong weak) "Hincl Hl Hc".
+ iApply ("Hcont" with "Hincl Hl").
+ iSplit.
+ - iDestruct "Hc" as "[Hc _]".
+ simp_ltypes. done.
+ - iDestruct "Hc" as "[_ Hc]".
+ destruct weak; last done.
+ (*
+ iIntros (ltyi2 ri2 bmin') "Hincl Hl Hcond".
+ iMod ("Hc" with "Hincl Hl Hcond") as "(Hl & Hcond & Htoks & HR)".
+ iFrame.
+ iApply (typed_place_cond_trans with "[] Hcond").
+
+ (* What do we actually want to allow on place access to Shared?
+ - we can not write, of course.
+ this is a property of the immediate borkind.
+ - But the interpretation of references itself should be fine with replacing types below.
+ i.e. the bmin should not be restricted much by Shared.
+ even the refinement should be allowed to change, because it is just passed through.
+ But in principle I dont' need it now, so just stay away from it.
+
+ *)
+
+ typed_place_cond_ty_mono
+ lty_core
+ typed_place_cond_ty.
+ *)
+
+ done.
+ Qed.
+ Global Instance typed_place_ex_plain_t_shared_inst π E L l (ty : type rt) x κ bmin K `{!TCDone (K ≠[])} :
+ TypedPlace E L π l (◠(∃; P, ty))%I #x bmin (Shared κ) K | 15 :=
+ λ T, i2p (typed_place_ex_plain_t_shared π E L l ty x κ bmin K T).
+
+End stratify.
+
+(* TODO move *)
+(* ty_share *)
+Lemma ltype_own_ofty_share `{!typeGS Σ} π F κ q l {rt} (ty : type rt) wl r :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ let κ' := lft_intersect_list (ty_lfts ty) in
+ q.[κ ⊓ κ'] -∗
+ (&{κ} (l â—â‚—[Ï€, Owned wl] r @ â— ty)) -∗
+ logical_step F ((l â—â‚—[Ï€, Shared κ] r @ â— ty) ∗ q.[κ ⊓ κ']).
+Proof.
+ iIntros (?) "#CTX Htok Hl".
+ iApply fupd_logical_step.
+ iEval (rewrite ltype_own_ofty_unfold /lty_of_ty_own) in "Hl".
+
+ (* Point:
+ - I need to deal with the update here.
+ - I concluded at some earlier point that I need credits for that.
+ bor_fupd_later
+ - Can I just give more credits to the type and require ty_share to deal with that?
+ => I think this is the way to go.
+ Otherwise I don't really have any handle to do that.
+
+ - Otherwise, I'd need credits here.
+ One option: have Owned true, then I have credits.
+ Not a good option for now, see below.
+
+
+ TODO for getting the right contractiveness result for using vec in recursive types, we would anyways need Owned true.
+ But we don't handle that anyways currently, so it's fine.
+ (One Q: where do we get the credits from for initializing that?)
+ (would generally need better support for Owned true for that in subsumption rules.
+ Basically can go from Owned true to Owned false and get receipts in the process.
+ And go from Owned false to Owned true by getting receipts + credits.
+ )
+ *)
+
+
+ (*
+ ty_share
+ iMod (
+ iDestruct "Hl" as "(%ly & %Hst & %Hly & Hsc & Hlb & _ & %r' & Hrfn & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "(%v & Hl & Hv)"
+ *)
+Admitted.
+
+
+(* TODO : make lft_intersect_list simpl never in the lemmas using this. *)
+Lemma ltype_own_ofty_share' `{!typeGS Σ} π F κ κ' q l {rt} (ty : type rt) wl r :
+ lftE ⊆ F →
+ (ty_lfts ty) ⊆ κ' →
+ rrust_ctx -∗
+ q.[κ] -∗
+ q.[lft_intersect_list κ'] -∗
+ (&{κ} (l â—â‚—[Ï€, Owned wl] r @ â— ty)) -∗
+ logical_step F ((l â—â‚—[Ï€, Shared κ] r @ â— ty) ∗ q.[κ] ∗ q.[lft_intersect_list κ']).
+Proof.
+ iIntros (? Hsub) "#CTX Htok1 Htok2 Hl".
+ iApply fupd_logical_step.
+ iMod (lft_incl_acc _ _ (lft_intersect_list (ty_lfts ty)) with "[] Htok2") as "(%q' & Htok2 & Hcltok2)"; first done.
+ { iApply list_incl_lft_incl_list. done. }
+ set (q0 := Qp.min q q').
+ iPoseProof (Fractional_fractional_le (λ q, q.[κ])%I q q0 with "Htok1") as "[Htok1 Hcltok1]".
+ { apply Qp.le_min_l. }
+ iPoseProof (Fractional_fractional_le (λ q, q.[lft_intersect_list (ty_lfts ty)])%I q' q0 with "Htok2") as "[Htok2 Hcltok2']".
+ { apply Qp.le_min_r. }
+ iPoseProof (ltype_own_ofty_share with "CTX [Htok1 Htok2] Hl") as "Hstep"; first done.
+ { rewrite -lft_tok_sep. iFrame. }
+ iApply logical_step_fupd.
+ iApply (logical_step_wand with "Hstep").
+ rewrite -lft_tok_sep.
+ iIntros "!> ($ & Htok1 & Htok2)".
+ iPoseProof ("Hcltok1" with "Htok1") as "$".
+ iPoseProof ("Hcltok2'" with "Htok2") as "Htok2".
+ iMod ("Hcltok2" with "Htok2") as "$". done.
+Qed.
+Lemma ltype_own_ofty_share_tac `{!typeGS Σ} π F κ κ' q l {rt} (ty : type rt) wl r P :
+ lftE ⊆ F →
+ (ty_lfts ty) ⊆ κ' →
+ rrust_ctx -∗
+ q.[κ] -∗
+ q.[lft_intersect_list κ'] -∗
+ (&{κ} (l â—â‚—[Ï€, Owned wl] r @ â— ty)) -∗
+ ((q/2).[κ] -∗ (q/2).[lft_intersect_list κ'] -∗ logical_step F (((l â—â‚—[Ï€, Shared κ] r @ â— ty) ∗ (q/2).[κ] ∗ (q/2).[lft_intersect_list κ']) -∗ P)) -∗
+ logical_step F P.
+Proof.
+ iIntros (??) "#CTX [Htok11 Htok12] [Htok21 Htok22] Hl Hstep".
+ iPoseProof (ltype_own_ofty_share' with "CTX Htok11 Htok21 Hl") as "Hstep'"; [done.. | ].
+ iApply (logical_step_compose with "(Hstep Htok12 Htok22)").
+ iApply (logical_step_wand with "Hstep'").
+ iIntros "Ha Hb". by iApply "Hb".
+Qed.
+
+
+(** ** Automation for solving obligations generated by defining existential types for sharing etc.*)
+(** Currently tailored specifically to our needs.
+ TODO In future, it might be more robust to instantiate Diaframe for this. *)
+From iris.proofmode Require Import coq_tactics reduction string_ident.
+(* Recursively destruct a product in hypothesis H, using the given name as template. *)
+Ltac destruct_product_hypothesis name H :=
+ match goal with
+ | H : _ * _ |- _ => let tmp1 := fresh "tmp" in
+ let tmp2 := fresh "tmp" in
+ destruct H as [tmp1 tmp2];
+ destruct_product_hypothesis name tmp1;
+ destruct_product_hypothesis name tmp2
+ | |- _ => let id := fresh name in
+ rename H into id
+ end.
+
+Ltac prepare_initial_coq_context :=
+ (* The automation assumes that all products in the context are destructed, see liForall *)
+ repeat lazymatch goal with
+ | H : _ * _ |- _ => destruct_product_hypothesis H H
+ | H : unit |- _ => destruct H
+ end.
+Ltac iTypeOfGoal := match goal with |- envs_entails _ ?Δ => Δ end.
+
+Tactic Notation "iModStrict" open_constr(iH) "as" constr(iG) :=
+ iDestructCore iH as false (fun H => iModCore H as H; last iDestructHyp H as iG).
+Tactic Notation "iDestructStrict" open_constr(iH) "as" constr(iG) :=
+ iDestructCore iH as false (fun H => iDestructHyp H as iG).
+
+Ltac iTypeOf' iH :=
+ let a := iTypeOf iH in
+ match a with
+ | Some (_, ?b) => b
+ end.
+
+(** Solve [Persistent]/[Timeless] assumptions. *)
+Ltac ex_t_solve_persistent :=
+ rewrite /TCNoResolve; intros; prepare_initial_coq_context; apply _.
+Ltac ex_t_solve_timeless :=
+ rewrite /TCNoResolve; intros; prepare_initial_coq_context; apply _.
+
+(** Solve the sharing assumption *)
+Definition SHELVED_ASSUM `{!typeGS Σ} (P : iProp Σ) := P.
+Global Typeclasses Opaque SHELVED_ASSUM.
+Global Arguments SHELVED_ASSUM : simpl never.
+Lemma shelve_assum `{!typeGS Σ} (P : iProp Σ) :
+ P -∗ SHELVED_ASSUM P.
+Proof. rewrite /SHELVED_ASSUM. auto. Qed.
+
+Lemma ex_t_lft_solve_sublist_test1 (l : list lft) :
+ [] ⊆ l.
+Proof. set_solver; solve[fail]. Abort.
+Lemma ex_t_lft_solve_sublist_test2 (l1 l3 l : list lft) :
+ l ⊆ (l1 ++ l ++ l3).
+Proof. set_solver; solve[fail]. Abort.
+Lemma ex_t_lft_solve_sublist_test3 (l1 l3 l : list lft) :
+ l3 ⊆ (l1 ++ l ++ l3).
+Proof. set_solver; solve[fail]. Abort.
+
+Ltac ex_t_destruct_bor :=
+ iSelect (&{_} (_))%I (fun iH =>
+ let ty := iTypeOf' iH in
+ iRename iH into "__H0";
+ lazymatch ty with
+ | (&{_} (?P))%I =>
+ lazymatch P with
+ | (_ ∗ _)%I =>
+ iModStrict (bor_sep with ("LFT __H0")) as "(? & ?)";
+ [done | ]
+ | (bi_exist ?Φ)%I =>
+ iModStrict (bor_exists_tok with ("LFT __H0 Htok1")) as "(% & __H0 & Htok1)";
+ [done | ]
+ | (⌜?Ï•âŒ)%I =>
+ iModStrict (bor_persistent with ("LFT __H0 Htok1")) as ("(>% & Htok1)");
+ [done | ]
+ | (?l â—â‚—[?Ï€, Owned ?wl] ?r @ (â— ?ty))%I =>
+ iApply (ltype_own_ofty_share_tac with "[$] Htok1 Htok __H0"); [done | set_solver | ];
+ iIntros "!> Htok1 Htok";
+ iApply fupd_logical_step
+ | _ =>
+ first
+ [ let _ := constr:(_ : Persistent P) in
+ iModStrict (bor_persistent with ("LFT __H0 Htok1")) as ("(__H0 & Htok1)");
+ [done | ];
+ first [ iDestruct "__H0" as ">?" | iDestruct "__H0" as "?" ]
+ | idtac "solve_shr: do not know how to share " P ", discarding";
+ iPoseProof (shelve_assum with "__H0") as "?"
+ ]
+ end
+ end
+ ).
+
+Ltac ex_t_intros_after_logstep :=
+ repeat match goal with
+ | |- envs_entails _ (_ -∗ _)%I =>
+ (* lhs is the actual ownership, rhs are the lifetime tokens *)
+ iIntros "(? & ? & ?)"
+ end.
+
+Ltac ex_t_merge_lft_tokens' κ frac :=
+ iSelect (frac.[κ])%I (fun H =>
+ iRevert H;
+ first [
+ (* try to find the matching partner *)
+ iSelect (frac.[κ])%I (fun H =>
+ once(
+ iIntros "__H0";
+ iRename H into "__H1";
+ iCombine ("__H0 __H1") as "__H0"))
+ | (* no matching partner found, find a smaller fraction first *)
+ ex_t_merge_lft_tokens' κ constr:((frac / 2)%Qp);
+ (* this was recursively constructed, now find it *)
+ iSelect (frac.[κ])%I (fun H =>
+ iRename H into "__H1";
+ iIntros "__H0";
+ iCombine ("__H0 __H1") as "__H0")
+ ]
+ ).
+Ltac ex_t_merge_lft_tokens tokty ident :=
+ lazymatch tokty with
+ | (?q.[?κ])%I =>
+ first [
+ (* check if it is already complete *)
+ iSelect (q.[κ])%I (fun H => iRename H into ident)
+ | (* otherwise, merge *)
+ ex_t_merge_lft_tokens' κ constr:((q/2)%Qp);
+ iRename "__H0" into ident
+ ]
+ end.
+
+
+(** Hook for proving the shared predicate after having shared all the assumptions *)
+Ltac ex_plain_t_solve_shr_solve_hook :=
+ repeat iExists _;
+ iFrame "%∗";
+ try done. (* TODO generalize *)
+
+Ltac ex_plain_t_solve_shr :=
+ iIntros (???????); prepare_initial_coq_context;
+ iIntros "#(LFT & TIME & LLCTX) Htok Hb";
+ iEval (rewrite -lft_tok_sep) in "Htok";
+ iDestruct "Htok" as "(Htok1 & Htok)";
+ let ty_of_Htok1 := iTypeOf' "Htok1" in
+ let ty_of_Htok := iTypeOf' "Htok" in
+ iApply fupd_logical_step;
+ repeat ex_t_destruct_bor;
+ unfold SHELVED_ASSUM;
+ iApply logical_step_intro;
+ iIntros "!>";
+ ex_t_intros_after_logstep;
+ ex_t_merge_lft_tokens ty_of_Htok1 "Htok1";
+ ex_t_merge_lft_tokens ty_of_Htok "Htok";
+ iSplitR "Htok1 Htok";
+ [ ex_plain_t_solve_shr_solve_hook
+ | iCombine "Htok1 Htok" as "Htok"; iEval (rewrite lft_tok_sep) in "Htok"; iApply "Htok"
+ ].
+
+(** Solve the monotonicity assumption. *)
+Ltac handle_monotonicity_prim iH :=
+ let ty := iTypeOf' iH in
+ match ty with
+ | (_ â—â‚—[_, Shared _] _ @ _)%I =>
+ iApply (ltype_rules.ltype_own_shr_mono with "[]");
+ [ | iApply iH];
+ done (* TODO: generalize? *)
+ | (⌜_âŒ)%I => iApply iH
+ | _ => iApply iH
+ end.
+
+Ltac prove_assumption_monotonicity iH :=
+ let ty := iTypeOf' iH in
+ lazymatch ty with
+ | (_ ∗ _)%I =>
+ iDestructStrict iH as ("( __H0 & " +:+ iH +:+ ")");
+ iSplitL "__H0";
+ [handle_monotonicity_prim "__H0" | ]
+ | (bi_exist ?Φ)%I =>
+ let a := fresh "_x" in
+ iDestruct iH as (a) iH;
+ iExists a
+ | _ => handle_monotonicity_prim iH
+ end.
+
+Ltac ex_plain_t_solve_shr_mono :=
+ iIntros (?????); prepare_initial_coq_context;
+ iIntros "#Hincl"; iIntros "Ha";
+ rewrite -?bi.sep_assoc;
+ repeat prove_assumption_monotonicity "Ha".
+
+Module test.
+ Context `{!typeGS Σ}.
+
+ (* The subtype of positive integers *)
+ Local Definition P_a := λ (x : Z) (y : Z), (∃ z : Z, ⌜x = (y + z)%Z⌠∗ ⌜(0 < x)%ZâŒ)%I : iProp Σ.
+ Local Program Definition Pdef := mk_pers_ex_inv_def P_a _ _.
+ Next Obligation. ex_t_solve_persistent. Qed.
+ Next Obligation. ex_t_solve_timeless. Qed.
+ Local Definition Pty := (∃; Pdef, int i32)%I.
+
+ Local Definition P_b := λ (Ï€ : thread_id) (x : Z) (y : Z), (∃ (z : Z) (l : loc), ⌜x = (y + z)%Z⌠∗ ⌜(0 < x)%Z⌠∗ l â—â‚—[Ï€, Owned false] #42%Z @ (â— int i32))%I : iProp Σ.
+ Local Definition S_b := λ (Ï€ : thread_id) (κ : lft) (x : Z) (y : Z), (∃ (z : Z) (l : loc), ⌜x = (y + z)%Z⌠∗ ⌜(0 < x)%Z⌠∗ l â—â‚—[Ï€, Shared κ] #42%Z @ (â— int i32))%I : iProp Σ.
+
+ Local Program Definition Adef := mk_ex_inv_def P_b S_b [] [] _ _ _.
+ Next Obligation. ex_t_solve_persistent. Qed.
+ Next Obligation. rewrite /S_b. ex_plain_t_solve_shr_mono. Qed.
+ Next Obligation. rewrite /P_b. ex_plain_t_solve_shr. Qed.
+End test.
diff --git a/theories/rust_typing/fraction_counting.v b/theories/rust_typing/fraction_counting.v
new file mode 100644
index 0000000000000000000000000000000000000000..73561dcf6fa202f4990a04dd70658d273d230e84
--- /dev/null
+++ b/theories/rust_typing/fraction_counting.v
@@ -0,0 +1,234 @@
+From iris.proofmode Require Import tactics.
+From iris.base_logic Require Import ghost_map.
+From iris.bi.lib Require Export fractional.
+From iris.algebra Require Import frac.
+From iris Require Import prelude options.
+Set Default Proof Using "Type".
+
+(** * Ghost state for turning fractional permissions into counting permissions *)
+
+
+Class fraction_mapG Σ := {
+ fraction_map_ghost_inG :: ghost_mapG Σ nat frac;
+}.
+#[export] Hint Mode fraction_mapG - : typeclass_instances.
+Definition fraction_mapΣ := #[ghost_mapΣ nat frac].
+Global Instance subG_fraction_mapΣ Σ :
+ subG (fraction_mapΣ) Σ → fraction_mapG Σ.
+Proof. solve_inG. Qed.
+
+Local Definition sum_frac_cod (M : list (nat * Qp)) : option frac :=
+ foldr (λ (p : nat * Qp) (acc : option Qp) ,
+ let '(_, q) := p in
+ match acc with | Some acc_q => Some (acc_q + q)%Qp | _ => Some q end) None M.
+
+Local Definition remaining_frac (M : list (nat * frac)) : option Qp :=
+ match sum_frac_cod M with
+ | None => Some 1%Qp
+ | Some q => (1-q)%Qp
+ end.
+
+Section defs.
+ Context `{fraction_mapG Σ}.
+
+ Definition fraction_map_auth_def (γ : gname) (Φ : Qp → iProp Σ) (q : frac) (n : nat) : iProp Σ :=
+ ∃ (M : gmap nat frac) (next_fresh : nat),
+ ghost_map_auth γ q M ∗ ⌜size (dom M) = n⌠∗
+ (* track the next fresh id ready for use *)
+ ⌜∀ i q, M !! i = Some q → i < next_fresh⌠∗
+ (* have the remaining fraction here *)
+ ∃ qr, ⌜remaining_frac (map_to_list M) = Some qr⌠∗ Φ (q * qr)%Qp.
+ Definition fraction_map_auth_aux : seal (@fraction_map_auth_def). Proof. by eexists. Qed.
+ Definition fraction_map_auth := fraction_map_auth_aux.(unseal).
+ Definition fraction_map_auth_eq : @fraction_map_auth = @fraction_map_auth_def := fraction_map_auth_aux.(seal_eq).
+
+ Definition fraction_map_elem_def (γ : gname) (Φ : Qp → iProp Σ) : iProp Σ :=
+ ∃ q, Φ q ∗ ∃ k, ghost_map_elem γ k (DfracOwn 1) q.
+ Definition fraction_map_elem_aux : seal (@fraction_map_elem_def). Proof. by eexists. Qed.
+ Definition fraction_map_elem := fraction_map_elem_aux.(unseal).
+ Definition fraction_map_elem_eq : @fraction_map_elem = @fraction_map_elem_def := fraction_map_elem_aux.(seal_eq).
+End defs.
+
+Section laws.
+ Context `{fraction_mapG Σ} (Φ : Qp → iProp Σ) `{Hfrac: !Fractional Φ}.
+
+ Instance sum_frac_cod_permutation_invariant :
+ Proper ((≡ₚ) ==> eq) sum_frac_cod.
+ Proof.
+ intros M1 M2.
+ induction 1 as [ | [] ??? IH| [] [] ?| ???? IH1 ? IH2]; simpl.
+ - done.
+ - rewrite IH. destruct (sum_frac_cod _); done.
+ - destruct (sum_frac_cod _); f_equiv.
+ + rewrite -!assoc. rewrite [(q+_)%Qp]comm. done.
+ + rewrite [(q+_)%Qp]comm. done.
+ - rewrite IH1 IH2. done.
+ Qed.
+
+ Local Lemma sum_frac_cod_cons n q a :
+ sum_frac_cod ((n, q) :: a) =
+ match sum_frac_cod a with
+ | Some qacc => Some (qacc + q)%Qp
+ | None => Some q
+ end.
+ Proof. done. Qed.
+
+ Instance remaining_frac_permutation_invariant :
+ Proper ((≡ₚ) ==> eq) remaining_frac.
+ Proof.
+ intros M1 M2 Hperm. rewrite /remaining_frac.
+ rewrite (sum_frac_cod_permutation_invariant _ M2); done.
+ Qed.
+
+ Local Lemma remaining_frac_nil :
+ remaining_frac [] = Some 1%Qp.
+ Proof. done. Qed.
+
+ Lemma fraction_map_elem_acc γ :
+ fraction_map_elem γ Φ -∗ ∃ q, Φ q ∗ (Φ q -∗ fraction_map_elem γ Φ).
+ Proof.
+ rewrite fraction_map_elem_eq.
+ iIntros "(%q & Hf & Ha)". iExists q. iFrame.
+ iIntros "Hf". iExists q. iFrame.
+ Qed.
+
+ Lemma fraction_map_auth_alloc :
+ Φ 1 -∗ |==> ∃ γ, fraction_map_auth γ Φ 1 0.
+ Proof.
+ iIntros "Hfull".
+ iMod (ghost_map_alloc_empty) as "(%γ & Hauth)".
+ iModIntro. iExists γ. rewrite fraction_map_auth_eq.
+ iExists ∅, 0. iFrame.
+ rewrite dom_empty_L size_empty. iSplitR; first done.
+ iSplitR. { iPureIntro. intros ?? []%lookup_empty_Some. }
+ iExists 1%Qp. rewrite Qp.mul_1_l. iFrame.
+ done.
+ Qed.
+
+ Global Instance fraction_map_auth_fractional γ n :
+ Fractional (λ q, fraction_map_auth γ Φ q n).
+ Proof using Type*.
+ iIntros (q1 q2). rewrite fraction_map_auth_eq. iSplit.
+ - iIntros "(%M & %nf & [Ha1 Ha2] & % & % & %qr & % & Hf)".
+ rewrite Qp.mul_add_distr_r. rewrite fractional. iDestruct "Hf" as "(Hf1 & Hf2)".
+ iSplitL "Ha1 Hf1"; iExists M, nf; eauto 8 with iFrame.
+ - iIntros "((%M1 & %nf1 & Ha1 & % & %Hf1 & %qr1 & %Hrem1 & Hf1) & (%M2 & %nf2 & Ha2 & % & %Hf2 & %qr2 & %Hrem2 & Hf2))".
+ iDestruct (ghost_map_auth_agree with "Ha1 Ha2") as %<-.
+ iExists M1, (min nf1 nf2). rewrite ghost_map_auth_fractional. iFrame.
+ iSplitR; first done. iSplitR.
+ { iPureIntro. intros ?? Hlook. specialize (Hf1 _ _ Hlook). specialize (Hf2 _ _ Hlook). lia. }
+ rewrite Hrem2 in Hrem1. injection Hrem1 as ->. iExists qr1.
+ rewrite Qp.mul_add_distr_r fractional. eauto with iFrame.
+ Qed.
+
+ (** get the remaining fraction *)
+ Lemma fraction_map_auth_access' γ q n :
+ fraction_map_auth γ Φ q n -∗
+ ∃ q' q'', Φ q' ∗ fraction_map_auth γ Φ q'' n ∗
+ (Φ q' -∗ fraction_map_auth γ Φ q'' n -∗ fraction_map_auth γ Φ q n).
+ Proof using Type*.
+ rewrite fraction_map_auth_eq.
+ iIntros "(%M & %next_fresh & Hauth & %Hsz & %Hfresh & %qr & %Hrem & Hprop)".
+ iExists ((q/2) * qr)%Qp, (q/2)%Qp.
+ rewrite -{1 2}(Qp.div_2 (q)) Qp.mul_add_distr_r.
+ rewrite ghost_map_auth_fractional. iDestruct "Hauth" as "(Hauth' & Hauth)".
+ rewrite Hfrac. iDestruct "Hprop" as "($ & Hprop)".
+ iSplitL "Hauth' Hprop".
+ { iExists _, _. iFrame. iSplitR; first done. iSplitR; first done.
+ iExists qr. iSplitR; done.
+ }
+ iIntros "Hprop Hauth'".
+ iDestruct "Hauth'" as "(%M' & %next_fresh' & Hauth' & _ & _ & %qr' & % & Hfrac)".
+ iExists M, next_fresh. iDestruct (ghost_map_auth_agree with "Hauth Hauth'") as %<-.
+ iCombine "Hauth Hauth'" as "$".
+ iSplitR; first done. iSplitR; first done. iExists qr. iSplitR; first done.
+ assert (qr = qr') as <- by congruence.
+ iCombine "Hprop Hfrac" as "Hprop". by rewrite -Hfrac -Qp.mul_add_distr_r Qp.div_2.
+ Qed.
+ Lemma fraction_map_auth_access γ q n :
+ fraction_map_auth γ Φ q n -∗
+ ∃ q', Φ q' ∗ fraction_map_auth γ Φ q' n ∗
+ (Φ q' -∗ fraction_map_auth γ Φ q' n -∗ fraction_map_auth γ Φ q n).
+ Proof using Type*.
+ iIntros "Hauth".
+ iPoseProof (fraction_map_auth_access' with "Hauth") as "(%q' & %q'' & Hprop & Hauth & Hcl)".
+ destruct (Qp.lower_bound q' q'') as (q0 & q1 & q2 & -> & ->).
+ rewrite Hfrac fraction_map_auth_fractional. iExists q0.
+ iDestruct "Hprop" as "($ & Hprop)". iDestruct "Hauth" as "($ & Hauth)".
+ iIntros "Hprop' Hauth'". iApply ("Hcl" with "[$] [$]").
+ Qed.
+
+ (** obtain a new fraction *)
+ Lemma fraction_map_auth_increase γ n :
+ fraction_map_auth γ Φ 1 n ==∗
+ fraction_map_auth γ Φ 1 (S n) ∗ fraction_map_elem γ Φ.
+ Proof using Type*.
+ rewrite fraction_map_auth_eq fraction_map_elem_eq.
+ iIntros "(%M & %next_fresh & Hauth & %Hsz & %Hfresh & %q' & %Hrem & Hprop)".
+ rewrite Qp.mul_1_l.
+ rewrite -{1}(Qp.div_2 q') fractional. iDestruct "Hprop" as "[Hprop1 Hprop]".
+ assert (M !! next_fresh = None) as Hfresh'.
+ { destruct (M !! next_fresh) eqn:Heq; last done.
+ apply Hfresh in Heq. lia.
+ }
+ iMod (ghost_map_insert next_fresh (q'/2)%Qp with "Hauth") as "(Hauth & He)"; first done.
+ iSplitR "He Hprop1"; first last. { iExists (q'/2)%Qp. eauto with iFrame. }
+ iModIntro. iExists _, (S next_fresh). iFrame "Hauth".
+ iSplitR. {
+ rewrite dom_insert_L size_union.
+ 2: { apply disjoint_singleton_l. intros (? & ?%Hfresh)%elem_of_dom. lia. }
+ by rewrite size_singleton Hsz.
+ }
+ iSplitR. { iPureIntro. intros i q. rewrite lookup_insert_Some. intros [(<- & <-) | (Hneq & ?%Hfresh)]; lia. }
+ iExists (q'/2)%Qp. rewrite Qp.mul_1_l. iFrame. iPureIntro.
+ rewrite map_to_list_insert; last done.
+ unfold remaining_frac in Hrem. unfold remaining_frac. rewrite sum_frac_cod_cons.
+ destruct (sum_frac_cod _).
+ - apply Qp.sub_Some in Hrem. rewrite Hrem.
+ rewrite -{1}(Qp.div_2 q') Qp.add_assoc Qp.add_comm Qp.add_sub. done.
+ - injection Hrem as <-.
+ rewrite -{1}Qp.half_half Qp.add_sub. done.
+ Qed.
+
+ (** access a full fraction when the count is 0 *)
+ Lemma fraction_map_auth_acc_0 γ :
+ fraction_map_auth γ Φ 1 0 -∗ Φ 1 ∗ (Φ 1 -∗ fraction_map_auth γ Φ 1 0).
+ Proof.
+ rewrite fraction_map_auth_eq.
+ iIntros "(%M & %nf & Hauth & %Hsz & %Hfresh & %q' & %Hrem & Hprop)".
+ rewrite Qp.mul_1_l. apply size_empty_inv in Hsz. apply dom_empty_inv in Hsz. subst M.
+ rewrite map_to_list_empty remaining_frac_nil in Hrem.
+ injection Hrem as <-. iFrame. iIntros "Hprop".
+ iExists ∅, 0. iFrame.
+ iSplitR. { by rewrite dom_empty_L size_empty. }
+ iSplitR. { iPureIntro. intros ? ? []%lookup_empty_Some. }
+ iExists 1%Qp. rewrite Qp.mul_1_l. iFrame.
+ rewrite map_to_list_empty remaining_frac_nil. done.
+ Qed.
+
+ Lemma fraction_map_auth_decrease γ n :
+ fraction_map_auth γ Φ 1 n -∗
+ fraction_map_elem γ Φ ==∗
+ fraction_map_auth γ Φ 1 (n - 1).
+ Proof using Type*.
+ rewrite fraction_map_auth_eq fraction_map_elem_eq.
+ iIntros "(%M & %nf & Hauth & %Hsz & %Hfresh & %q' & %Hrem & Hprop) (%q & Hprop' & %k & Helem)".
+ iPoseProof (ghost_map_lookup with "Hauth Helem") as "%Hlook".
+ iMod (ghost_map_delete with "Hauth Helem") as "Hauth".
+ iModIntro. iExists (delete k M), nf. iFrame.
+ iSplitR. { iPureIntro.
+ rewrite dom_delete_L size_difference.
+ 2: { apply singleton_subseteq_l. apply elem_of_dom. eauto. }
+ rewrite Hsz size_singleton. done.
+ }
+ iSplitR. { iPureIntro. intros ?? [_ ?%Hfresh]%lookup_delete_Some. done. }
+ iExists (q' + q)%Qp. rewrite !Qp.mul_1_l. rewrite fractional. iFrame.
+ iPureIntro.
+ rewrite -map_to_list_delete in Hrem; last apply Hlook.
+ unfold remaining_frac in Hrem. rewrite sum_frac_cod_cons in Hrem.
+ unfold remaining_frac. destruct (sum_frac_cod _).
+ - apply Qp.sub_Some in Hrem. rewrite Hrem.
+ rewrite Qp.add_comm [(_ + q)%Qp]Qp.add_comm Qp.add_assoc Qp.add_sub. done.
+ - apply Qp.sub_Some in Hrem. rewrite Hrem. rewrite Qp.add_comm. done.
+ Qed.
+End laws.
diff --git a/theories/rust_typing/functions.v b/theories/rust_typing/functions.v
new file mode 100644
index 0000000000000000000000000000000000000000..3cacf451f20c1579a408b74a32ced66b3beb0f59
--- /dev/null
+++ b/theories/rust_typing/functions.v
@@ -0,0 +1,429 @@
+From refinedrust Require Export type.
+From refinedrust Require Import programs uninit.
+Set Default Proof Using "Type".
+
+(* "entry-point" statement *)
+Definition to_runtime_function (fn : function) (lsa lsv : list loc) (lya lyv : list layout) : runtime_function :=
+ let rf := subst_function (zip (fn.(f_args).*1 ++ fn.(f_local_vars).*1) (val_of_loc <$> (lsa ++ lsv))) fn in
+ {| rf_fn := rf; rf_locs := zip lsa lya ++ zip lsv lyv |}.
+Definition introduce_typed_stmt {Σ} `{!typeGS Σ} (Ï€ : thread_id) (E : elctx) (L : llctx) (Ï : lft) (fn : function) (lsa lsv : list loc) (lya lyv : list layout) (R : val → iProp Σ) : iProp Σ :=
+ let rf := to_runtime_function fn lsa lsv lya lyv in
+ typed_stmt Ï€ E L (Goto fn.(f_init)) rf R Ï.
+Global Typeclasses Opaque introduce_typed_stmt.
+Global Arguments introduce_typed_stmt : simpl never.
+
+
+(* TODO: equip function types with namespace parameters for atomic and non-atomic invariants that need to be active when calling it. *)
+
+Fixpoint prod_vec (A : Type) (n : nat) : Type :=
+ match n with
+ | 0 => ()%type
+ | S n => (prod_vec A n * A)%type
+ end.
+Fixpoint list_to_tup {A} (l : list A) : prod_vec A (length l) :=
+ match l with
+ | [] => tt
+ | x :: xs => (list_to_tup xs, x)
+ end.
+
+Section function.
+ (* [A] is the parameter type (i.e., it bundles up all the Coq-level parameters of a function) *)
+ (* [n] is the number of lifetime parameters *)
+ Context `{!typeGS Σ} {A : Type} {lfts : nat}.
+ (* function return type and condition *)
+ (* this does not take an rtype, since we essentially pull that part out to
+ [fp_rtype] and [fp_fr] below, in order to support existential quantifiers *)
+ Record fn_ret := mk_FR {
+ fr_rt : Type;
+ fr_ty : type fr_rt;
+ fr_ref : fr_rt;
+ fr_R : thread_id → iProp Σ;
+ }.
+
+ Record fn_params := FP {
+ (** Argument types with refinement.
+ We also directly require an inG proof for ghost variables to that type.
+ Maybe there is a nicer way to bundle that up?
+ *)
+ fp_atys : list (@sigT Type (λ rt, type rt * rt)%type);
+ (* bundled assume condition *)
+ fp_Pa : thread_id → iProp Σ;
+ (* external lifetimes, parameterized over a lifetime for the function *)
+ fp_elctx : lft → elctx;
+ (* existential condition for return type *)
+ fp_extype : Type;
+ (* return type *)
+ fp_fr: fp_extype → fn_ret;
+ }.
+
+ (**
+ Compute a [fn_params] definition that includes the required lifetime constraints for the
+ used argument and return types (according to their typeclass instances).
+ This is currently a bit more restrictive than it needs to be:
+ We don't allow [retty] to depend on [exty], since [exty] should not quantify over any lifetimes for this computation to work.
+ FIXME Maybe we can generalize this with some more typeclass magic.
+ *)
+ Definition map_rtype : (@sigT Type (λ rt, type rt * rt)%type) → rtype :=
+ (λ '(existT rt (ty, _)), {| rt_rty := rt; rt_ty := ty|}).
+ Definition FP_wf
+ E
+ (atys : list (@sigT Type (λ rt, type rt * rt)%type))
+ (pa : thread_id → iProp Σ)
+ (exty : Type)
+ (retrt : Type)
+ (retty : type retrt)
+ (fr_ref : exty → retrt)
+ (fr_R : exty → thread_id → iProp Σ) :=
+ FP
+ atys
+ pa
+ (λ Ï, E Ï ++
+ tyl_wf_E (map map_rtype atys) ++
+ tyl_outlives_E (map map_rtype atys) Ï ++
+ ty_wf_E retty ++
+ ty_outlives_E retty Ï)
+ exty
+ (λ e, mk_FR retrt retty (fr_ref e) (fr_R e)).
+
+
+ (* the return continuation for type-checking the body.
+ We need to be able to transform ownership of the return type given by [typed_stmt]
+ to the type + ensures condition that the function really needs to return *)
+ Definition fn_ret_prop {B} π (fr : B → fn_ret) : val → iProp Σ :=
+ (λ v,
+ (* there exists an inhabitant of the spec-level existential *)
+ ∃ x,
+ (* st. the return type is satisfied *)
+ v â—áµ¥{Ï€} (fr x).(fr_ref) @ (fr x).(fr_ty) ∗
+ (* and the ensures-condition is satisfied *)
+ (fr x).(fr_R) π ∗
+ (* for Lithium compatibility *)
+ True)%I.
+
+ Definition fn_arg_layout_assumptions
+ (atys : list (@sigT Type (λ rt, type rt * rt)%type)) (lya : list layout) :=
+ Forall2 (λ '(existT rt (ty, _)) ly, syn_type_has_layout ty.(ty_syn_type) ly) atys lya.
+ Definition fn_local_layout_assumptions
+ (sts : list syn_type) (lyv : list layout) :=
+ Forall2 (syn_type_has_layout) sts lyv.
+
+ (** This definition is not yet contractive, and also not a full type.
+ We do this below in a separate definition. *)
+ Definition typed_function π (fn : function) (local_sts : list syn_type) (fp : prod_vec lft lfts → A → fn_params) : iProp Σ :=
+ ( (* for any Coq-level parameters *)
+ ∀ κs x,
+ (* and any duration of the function call *)
+ ∀ (Ï : lft),
+ â–¡ (
+ let lya := fn.(f_args).*2 in
+ let lyv := fn.(f_local_vars).*2 in
+ (* the function arg type layouts match what is given in the function [fn]: this is something we assume here *)
+ ⌜fn_arg_layout_assumptions (fp κs x).(fp_atys) lya⌠-∗
+ (* the local var layouts also match the specified syn_types *)
+ ⌜fn_local_layout_assumptions local_sts lyv⌠-∗
+ ∀ (* for any stack locations that get picked nondeterministically... *)
+ (lsa : vec loc (length (fp κs x).(fp_atys)))
+ (lsv : vec loc (length fn.(f_local_vars))),
+ (* initial stack *)
+ let Qinit :=
+ (* initial credits from the beta step *)
+ credit_store 0 0 ∗
+ (* arg ownership *)
+ ([∗list] l;t∈lsa;(fp κs x).(fp_atys), let '(existT rt (ty, r)) := t in l â—â‚—[Ï€, Owned false] PlaceIn r @ (â— ty)) ∗
+ (* local vars ownership *)
+ ([∗list] l;p∈lsv;local_sts, (l â—â‚—[Ï€, Owned false] (PlaceIn ()) @ (â— (uninit p)))) ∗
+ (* precondition *)
+ (fp κs x).(fp_Pa) π in
+ (* external lifetime context: can require external lifetimes syntactically outlive the function lifetime, as well as syntactic constraints between universal lifetimes *)
+ let E := ((fp κs x).(fp_elctx) Ï) in
+ (* local lifetime context: the function needs to be alive *)
+ let L := [Ï âŠ‘â‚—{0} []] in
+ Qinit -∗ introduce_typed_stmt Ï€ E L Ï fn lsa lsv lya lyv (fn_ret_prop Ï€ (fp κs x).(fp_fr)))
+ )%I.
+
+ Global Instance typed_function_persistent π fn local_sts fp : Persistent (typed_function π fn local_sts fp) := _.
+
+ (* TODO: need a notion of equivalence on functions? *)
+
+ (** function pointer type. Requires that the location stores a function that has suitable layouts for the fn_params.
+ Note that the fn_params may contain generics: this means that only for particular choices of types to instantiate this,
+ this is actually a valid function pointer at the type. This is why we expose the list of argument syn_types in this type.
+ The caller will have to show, when calling the function, that the instantiations validate the layout assumptions.
+ *)
+ Program Definition function_ptr (arg_types : list (syn_type)) (fp : prod_vec lft lfts → A → fn_params) : type loc := {|
+ st_own π f v := (∃ fn local_sts, ⌜v = val_of_loc f⌠∗ fntbl_entry f fn ∗
+ ⌜list_map_option use_layout_alg arg_types = Some fn.(f_args).*2⌠∗
+ (* for the local variables, we need to pick [local_sts] at linking time (in adequacy, when we run the layout algorithm) *)
+ ⌜list_map_option use_layout_alg local_sts = Some fn.(f_local_vars).*2⌠∗
+ ▷ typed_function π fn local_sts fp)%I;
+ st_has_op_type ot mt := is_ptr_ot ot;
+ st_syn_type := FnPtrSynType;
+ |}.
+ Next Obligation.
+ simpl. iIntros (fal fp π r v) "(%fn & %local_sts & -> & _)". eauto.
+ Qed.
+ Next Obligation.
+ intros ? ? ot mt Hot. apply is_ptr_ot_layout in Hot. rewrite Hot. done.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (lya fp ot mt st π r v Hot).
+ destruct mt.
+ - eauto.
+ - iIntros "(%fn & %local_sts & -> & Hfntbl & %Halg & Hfn)".
+ iExists fn, _. iFrame. iPureIntro. split; last done.
+ destruct ot; try done. unfold mem_cast. rewrite val_to_of_loc. done.
+ - iApply (mem_cast_compat_loc (λ v, _)); first done.
+ iIntros "(%fn & % & -> & _)". eauto.
+ Qed.
+ Global Instance copyable_function_ptr fal fp : Copyable (function_ptr fal fp) := _.
+
+ (*
+ Typing for function calls:
+ - we get the arguments,
+ - then we instantiate the universal params [x] that the function has
+ this will in particular involve universal lifetimes and generics, but usually as evars.
+ - we show that we can adapt the arguments to have the right types expected by the function,
+ (this resolves some evars)
+ - we prove the additional precondition
+ - we show that lifetimes in the current local context are alive (so that we can obtain tokens to give the function)
+ - we show that the external context required by the function is satisfiable, assuming that Ï is outlived by all local lifetimes.
+ (logically, we will end up instantiating the Ï with the intersection of all local lifetimes + a new atomic lifetime)
+ to show this: we need to have instantiated the universal parameters already.
+ - then we obtain some result value v + an existential x'
+ - and the postcondition
+ - and continue with the result value in the continuation.
+
+ This completely abstracts the handling of the lifetime context for the function.
+ - for the new local lifetime context of the function, we will internally create a new atomic lifetime and instantiate the context with that.
+ *)
+ (* NOTE: to improve performance of the solver, it may make sense to reformulate the elctx_sat assumption. *)
+ (* TODO: how could we directly have lifetime annotations here?
+ Basically, would get a list of lifetimes.
+ But I guess I could make the interpretation give me a vector.
+ Only: how do I formulate that in a way that typechecks?
+ Well, I guess I could use a dependently typed function for that.
+
+ *)
+
+End function.
+Section call.
+ Context `{!typeGS Σ}.
+ Import EqNotations.
+ Lemma type_call_fnptr π E L {A : Type} (lfts : nat) eκs l v vl tys T (fp : prod_vec lft lfts → A → fn_params) sta :
+ let eκs' := list_to_tup eκs in
+ (([∗ list] v;t ∈ vl; tys, let '(existT rt (ty, r)) := t in v â—áµ¥{Ï€} r @ ty) -∗
+ ∃ (Heq : lfts = length eκs),
+ ∃ x,
+ let κs := (rew <- Heq in eκs') in
+ (* show typing for the function's actual arguments. *)
+ prove_with_subtype E L false ProveDirect ([∗ list] v;t ∈ vl; (fp κs x).(fp_atys), let '(existT rt (ty, r)) := t in v â—áµ¥{Ï€} r @ ty) (λ L1 _ R2,
+ R2 -∗
+ (* the syntypes of the actual arguments match with the syntypes the function assumes *)
+ ⌜sta = map (λ '(existT rt (ty, _)), ty.(ty_syn_type)) (fp κs x).(fp_atys)⌠∗
+ (* precondition *)
+ (* TODO it would be good if we could also stratify.
+ However a lot of the subsumption instances relating to values need subsume_full.
+ Maybe we should port them to a form of owned_subltype?
+ but even the logical step thing is problematic.
+ *)
+ prove_with_subtype E L1 true ProveDirect ((fp κs x).(fp_Pa) π) (λ L2 _ R3,
+ ⌜Forall (lctx_lft_alive E L2) (L2.*1.*2)⌠∗
+ ⌜∀ Ï, elctx_sat (((λ '(_, κ, _), Ï âŠ‘â‚‘ κ) <$> L2) ++ E) L2 ((fp κs x).(fp_elctx) Ï)⌠∗
+ (* postcondition *)
+ ∀ v x', (* v = retval, x' = post existential *)
+ introduce_with_hooks E L2 (R3 ∗ ((fp κs x).(fp_fr) x').(fr_R) π) (λ L3,
+ T L3 v ((fp κs x).(fp_fr) x').(fr_rt) ((fp κs x).(fp_fr) x').(fr_ty) ((fp κs x).(fp_fr) x').(fr_ref))))
+ ) ⊢ typed_call Ï€ E L eκs v (v â—áµ¥{Ï€} l @ function_ptr sta fp) vl tys T.
+ Proof.
+ simpl. iIntros "HT (%fn & %local_sts & -> & He & %Halg & %Halgl & Hfn) Htys" (Φ) "#CTX #HE HL HΦ".
+ iDestruct ("HT" with "Htys") as "(%Heq & %x & HP)". subst lfts.
+ set (aκs := list_to_tup eκs).
+ iApply fupd_wp. iMod ("HP" with "[] [] CTX HE HL") as "(%L1 & % & %R2 & >(Hvl & R2) & HL & HT)"; [done.. | ].
+ iDestruct ("HT" with "R2") as "(-> & HT)".
+ iMod ("HT" with "[] [] CTX HE HL") as "(%L2 & % & %R3 & Hstep & HL & HT)"; [done.. | ].
+ iDestruct ("HT") as "(%Hal & %Hsat & Hr)".
+ (* initialize the function's lifetime *)
+ set (Ï' := lft_intersect_list (L2.*1.*2)).
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iApply fupd_wp. iMod (lctx_lft_alive_tok_noend_list with "HE HL") as "(%q & Htok & HL & HL_cl')";
+ [done | apply Hal | ].
+ iDestruct "CTX" as "#(LFT & TIME & LCTX)".
+ iMod (llctx_startlft_extra _ _ _ [] with "LFT LCTX Htok") as "(%Ï & HÏ & %Hincl & Hkill)"; [set_solver.. | ].
+ iPoseProof (Hsat Ï with "HL []") as "#HE'".
+ { iFrame "HE". iApply big_sepL_intro.
+ iIntros "!>" (k [κe1 κe2] Hlook).
+ apply elem_of_list_lookup_2 in Hlook. simpl.
+ apply elem_of_list_fmap in Hlook as (((i & ?) & κs1) & [= <- <-] & ?).
+ iApply lft_incl_trans. { iApply lft_incl_syn_sem. done. }
+ iApply lft_intersect_list_elem_of_incl.
+ rewrite elem_of_list_fmap. exists (i, κe2). split; first done.
+ rewrite elem_of_list_fmap. eexists; split; last done. done.
+ }
+
+ simpl.
+ iAssert ⌜Forall2 has_layout_val vl fn.(f_args).*2âŒ%I as %Hall. {
+ iClear "Hfn Hr HL Hstep HL_cl HL_cl' HÏ Hkill".
+ move: Halg. move: (fp_atys (fp aκs x)) => atys Hl.
+ iInduction (fn.(f_args)) as [|[? ly]] "IH" forall (vl atys Hl).
+ { move: Hl => /=. intros ->%list_map_option_nil_inv_r%map_eq_nil. destruct vl => //=. }
+ move: Hl.
+ simpl. intros (st & atys' & Ha & ? & ?)%list_map_option_cons_inv_r.
+ apply map_eq_cons in Ha as (xa & ? & -> & <- & <-).
+ destruct vl => //=. iDestruct "Hvl" as "[Hv Hvl]".
+ destruct xa as (rt & (ty & r)).
+ iDestruct ("IH" with "[//] He HΦ Hvl") as %?.
+ iDestruct (ty_has_layout with "Hv") as "(%ly' & % & %)".
+ assert (ly = ly') as ->. { by eapply syn_type_has_layout_inj. }
+ iPureIntro. constructor => //.
+ }
+
+ iAssert (|={⊤}=> [∗ list] v;t ∈ vl;fp_atys (fp aκs x), let 'existT rt (ty, r) := t in v â—áµ¥{ Ï€} r @ ty)%I with "[Hvl]" as ">Hvl".
+ { rewrite -big_sepL2_fupd. iApply (big_sepL2_mono with "Hvl").
+ iIntros (?? (rt & (ty & r)) ??) "Hv". eauto with iFrame. }
+
+ iMod (persistent_time_receipt_0) as "Hp".
+ iEval (rewrite /logical_step) in "Hstep".
+ iMod "Hstep" as "(%n & Hc & Hstep)".
+ iApply wp_fupd. iModIntro. iModIntro.
+ (*iApply (wp_logical_step with "TIME Hstep"); [done.. | ].*)
+ iApply (wp_call_credits with "TIME Hc Hp He") => //. { by apply val_to_of_loc. }
+ iIntros "!>" (lsa lsv Hlya) "Ha Hv Hcred Hc".
+ iDestruct (big_sepL2_length with "Ha") as %Hlen1.
+ iDestruct (big_sepL2_length with "Hv") as %Hlen2.
+ iDestruct (big_sepL2_length with "Hvl") as %Hlen3.
+
+ (* use the credits we got to get the precondition *)
+ rewrite lc_succ. iDestruct "Hcred" as "(Hcred & Hcred0)".
+ rewrite additive_time_receipt_succ. iDestruct "Hc" as "(Hc & Hc0)".
+ rewrite !Nat.add_0_r. iMod ("Hstep" with "Hcred0 Hc0") as "(HP & HR)".
+
+ apply list_map_option_alt in Halg. apply list_map_option_alt in Halgl.
+ iDestruct ("Hfn" $! aκs x Ï with "[] []") as "Hfn".
+ { iPureIntro. move: Halg. rewrite Forall2_fmap_l => Halg.
+ eapply Forall2_impl; first done. intros (rt & ty & r) ly; done. }
+ { done. }
+
+ have [lsa' ?]: (∃ (ls : vec loc (length (fp_atys (fp aκs x)))), lsa = ls)
+ by rewrite -Hlen3 -Hlen1; eexists (list_to_vec _); symmetry; apply vec_to_list_to_vec. subst.
+ have [lsv' ?]: (∃ (ls : vec loc (length (f_local_vars fn))), lsv = ls)
+ by rewrite -Hlen2; eexists (list_to_vec _); symmetry; apply vec_to_list_to_vec. subst.
+
+ iDestruct ("Hfn" $! lsa' lsv') as "Hm". unfold introduce_typed_stmt.
+ iExists _. iSplitR "Hr HR HΦ HL HL_cl HL_cl' Hkill" => /=.
+ - iMod (persistent_time_receipt_0) as "#Htime".
+ iApply ("Hm" with "[-HÏ] [$LFT $TIME $LCTX] HE' [$HÏ//]"). iFrame.
+ iSplitL "Hcred Hc". { rewrite credit_store_eq /credit_store_def. iFrame. }
+ move: Hlen1 Hlya. move: (lsa' : list _) => lsa'' Hlen1 Hly. clear lsa' Hall.
+ move: Hlen3 Halg. move: (fp_atys (fp aκs x)) => atys Hlen3 Hl.
+ move: Hly Hl. move: (f_args fn) => alys Hly Hl.
+ iInduction (vl) as [|v vl] "IH" forall (atys lsa'' alys Hlen1 Hly Hlen3 Hl).
+ { destruct atys, lsa'' => //. iSplitR => //.
+ iPoseProof (big_sepL2_fmap_r (λ x, x.2) (λ _ l v, l ↦|v|)%I with "Hv") as "Hv".
+ move: Halgl. rewrite Forall2_fmap_r => Halgl.
+ assert ((f_local_vars fn).*2 = use_layout_alg' <$> local_sts) as Heq.
+ { clear -Halgl. move: Halgl. generalize (f_local_vars fn) => l.
+ induction local_sts as [ | ?? IH] in l |-*; inversion 1; first done.
+ simplify_eq/=. f_equiv. { rewrite /use_layout_alg'.
+ match goal with | H : use_layout_alg _ = Some _ |- _ => rewrite H end. done. }
+ by apply IH. }
+ rewrite Heq. rewrite big_sepL2_fmap_r.
+ iApply (big_sepL2_wand with "Hv").
+ iApply big_sepL2_intro. { rewrite Hlen2. apply Forall2_length in Halgl. done. }
+ iIntros "!>" (?? st ? Hlook) => /=. iDestruct 1 as (? Hly') "[%Hly'' Hl]".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. simpl.
+ eapply (Forall2_lookup_l _ _ _ k) in Halgl as (ly & ? & Halg_st); last done.
+ simpl in Halg_st. rewrite /use_layout_alg' Halg_st in Hly'. rewrite /use_layout_alg' Halg_st in Hly''.
+ iExists _. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done.
+ iPoseProof (heap_mapsto_loc_in_bounds with "Hl") as "#Hlb".
+ rewrite Hly'. iFrame "Hlb". iSplitR; first done.
+ iExists _. iSplitR; first done. iModIntro. iExists _. iFrame.
+ rewrite uninit_own_spec.
+ iExists _. done. }
+ destruct atys, lsa'' => //.
+ move: Hl. simpl. intros (ly & ? & ? & ? & Ha)%Forall2_cons_inv_l.
+ apply map_eq_cons in Ha as ([? ly'] & ? & -> & <- & <-).
+ csimpl in *; simplify_eq.
+ move: Hly => /(Forall2_cons _ _ _ _)[Hly ?].
+ (*apply bind_Some in Hlya as (lys & Hlya & (ly & Halg & [= <- <-])%bind_Some).*)
+ iDestruct "Hvl" as "[Hvl ?]".
+ iDestruct "Ha" as "[Ha ?]".
+ rewrite -bi.sep_assoc. iSplitL "Hvl Ha".
+ { destruct s as (rt & (ty & r)).
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct (ty_has_layout with "Hvl") as "(%ly & % & %Hlyv)".
+ assert (ly = ly') as <-. { by eapply syn_type_has_layout_inj. }
+ iExists _. iSplitR; first done. iSplitR; first done.
+ iPoseProof (ty_own_val_sidecond with "Hvl") as "#$".
+ iPoseProof (heap_mapsto_loc_in_bounds with "Ha") as "#Hlb".
+ rewrite Hlyv. iSplitR; first done. iSplitR; first done.
+ iExists _. iSplitR; first done. iNext. eauto with iFrame. }
+ iApply ("IH" with "[//] [//] [//] [//] [$] [$] [$]").
+ - (* handle the postcondition at return *)
+ iIntros "!>" (v). iDestruct 1 as (κs1) "(Hls & HÏ & HPr)".
+ simpl. rewrite !big_sepL2_alt. iDestruct (big_sepL_app with "Hls") as "[? ?]".
+ rewrite !zip_fmap_r !big_sepL_fmap. iFrame.
+ iSplitR. { iPureIntro. apply Forall2_length in Halg.
+ rewrite map_length in Halg. rewrite Hlen1 Hlen3 Halg fmap_length. done. }
+ iSplitR; first done.
+ iIntros "Hcred". iDestruct "HÏ" as "(HÏ & _)".
+ iPoseProof ("Hkill" with "HÏ") as "(Htok & Hkill)".
+ iMod ("HL_cl'" with "Htok HL") as "HL".
+ iPoseProof ("HL_cl" with "HL") as "HL".
+ (* we currently don't actually kill the lifetime, as we don't conceptually need that. *)
+ iDestruct ("HPr") as (?) "(Hty & HR2 & _)".
+ iMod ("Hr" with "[] HE HL [HR2 HR]") as "(%L3 & HL & Hr)"; first done.
+ { iFrame. }
+ iApply ("HΦ" with "HL Hty").
+ by iApply ("Hr").
+ Qed.
+ Global Instance type_call_fnptr_inst π E L {A} (lfts : nat) eκs l v vl fp lya tys :
+ TypedCall Ï€ E L eκs v (v â—áµ¥{Ï€} l @ function_ptr lya fp) vl tys :=
+ λ T, i2p (type_call_fnptr π E L (A := A)lfts eκs l v vl tys T fp lya).
+End call.
+
+Arguments fn_ret_prop _ _ _ /.
+
+(* In principle we'd like a notation along these lines, but the recursive pattern for the parameter list isn't supported by Coq. *)
+
+(*
+Notation "'fn(∀' x ':' A ',' E ';' r1 '@' T1 ',' .. ',' rN '@' TN ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun x => FP_wf E (@cons type (existT T1%I (r1, _)) .. (@cons type (existT TN%I (rN, _)) (@nil type)) ..) Pa%I B rty (λ y, r%I) (λ y, Pr%I)) : A → fn_params)
+ (at level 99, Pr at level 200, x pattern, y pattern) : stdpp_scope.
+ *)
+
+(* For now, we just define notations for a limited number of arguments (currently up to 6) *)
+(* FIXME: proper printing *)
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@nil _) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' r1 '@' T1 ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@cons (@sigT Type _) (existT _ (T1, r1)) (@nil _)) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' r1 '@' T1 ',' r2 '@' T2 ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@cons _ (existT _ (T1, r1)) $ @cons _ (existT _ (T2, r2)) $ (@nil _)) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' r1 '@' T1 ',' r2 '@' T2 ',' r3 '@' T3 ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@cons _ (existT _ (T1, r1)) $ @cons _ (existT _ (T2, r2)) $ @cons _ (existT _ (T3, r3)) $ (@nil _)) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' r1 '@' T1 ',' r2 '@' T2 ',' r3 '@' T3 ',' r4 '@' T4 ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@cons _ (existT _ (T1, r1)) $ @cons _ (existT _ (T2, r2)) $ @cons _ (existT _ (T3, r3)) $ @cons _ (existT _ (T4, r4)) $ (@nil _)) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' r1 '@' T1 ',' r2 '@' T2 ',' r3 '@' T3 ',' r4 '@' T4 ';' r5 '@' T5 ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@cons _ (existT _ (T1, r1)) $ @cons _ (existT _ (T2, r2)) $ @cons _ (existT _ (T3, r3)) $ @cons _ (existT _ (T4, r4)) $ @cons _ (existT _ (T5, r5)) $ (@nil _)) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+Notation "'fn(∀' κs : n '|' x ':' A ',' E ';' r1 '@' T1 ',' r2 '@' T2 ',' r3 '@' T3 ',' r4 '@' T4 ';' r5 '@' T5 ';' r6 '@' T6 ';' Pa ')' '→' '∃' y ':' B ',' r '@' rty ';' Pr" :=
+ ((fun κs x => FP_wf E (@cons _ (existT _ (T1, r1)) $ @cons _ (existT _ (T2, r2)) $ @cons _ (existT _ (T3, r3)) $ @cons _ (existT _ (T4, r4)) $ @cons _ (existT _ (T5, r5)) $ @cons _ (existT _ (T6, r6)) $ (@nil _)) Pa%I B _ rty (λ y, r%I) (λ y, Pr%I)) : prod_vec lft n → A → fn_params)
+ (at level 99, Pr at level 200, κs pattern, x pattern, y pattern) : stdpp_scope.
+
+Module test.
+Definition bla0 `{typeGS Σ} :=
+ (fn(∀ ((), κ', κ) : 2 | (x) : unit, (λ f, [(κ', κ)]); (λ Ï€, True)) → ∃ y : Z, () @ (uninit PtrSynType) ; λ Ï€, ⌜ (4 > y)%ZâŒ).
+Definition bla1 `{typeGS Σ} :=
+ (fn(∀ (()) : 0 | x : unit, (λ _, []); () @ (uninit PtrSynType) ; (λ Ï€, True)) → ∃ y : Z, () @ (uninit PtrSynType) ; (λ Ï€, ⌜ (4 > y)%ZâŒ)).
+Definition bla2 `{typeGS Σ} :=
+ (fn(∀ () : 0 | x : unit, (λ _, []); () @ (uninit PtrSynType), () @ (uninit PtrSynType) ; (λ Ï€, True)) → ∃ y : Z, () @ (uninit PtrSynType) ; (λ Ï€, ⌜ (4 > y)%ZâŒ)).
+End test.
+
+Global Typeclasses Opaque function_ptr.
+Global Typeclasses Opaque typed_function.
diff --git a/theories/rust_typing/ghost_var_dfrac.v b/theories/rust_typing/ghost_var_dfrac.v
new file mode 100644
index 0000000000000000000000000000000000000000..102119adf1c26ae13d58eca5d4d9aec194553b59
--- /dev/null
+++ b/theories/rust_typing/ghost_var_dfrac.v
@@ -0,0 +1,126 @@
+(** A simple "ghost variable" of arbitrary type with fractional ownership.
+Can be mutated when fully owned. *)
+(* Compared with Iris's version, this can do dfracs. *)
+From iris.algebra Require Import proofmode_classes frac.
+From refinedrust Require Export dfrac_agree.
+From iris.bi.lib Require Import fractional.
+From iris.proofmode Require Import tactics.
+From iris.base_logic.lib Require Export own.
+From iris.prelude Require Import options.
+
+(** The CMRA we need. *)
+Class ghost_varG Σ (A : Type) := GhostVarG {
+ ghost_var_inG :: inG Σ (dfrac_agreeR $ leibnizO A);
+}.
+Global Hint Mode ghost_varG - ! : typeclass_instances.
+
+Definition ghost_varΣ (A : Type) : gFunctors :=
+ #[ GFunctor (dfrac_agreeR $ leibnizO A) ].
+
+Global Instance subG_ghost_varΣ Σ A : subG (ghost_varΣ A) Σ → ghost_varG Σ A.
+Proof. solve_inG. Qed.
+
+Definition ghost_var_def `{!ghost_varG Σ A} (γ : gname) (dq : dfrac) (a : A) : iProp Σ :=
+ own γ (to_dfrac_agree (A:=leibnizO A) dq a).
+Definition ghost_var_aux : seal (@ghost_var_def). Proof. by eexists. Qed.
+Definition ghost_var := ghost_var_aux.(unseal).
+Definition ghost_var_eq : @ghost_var = @ghost_var_def := ghost_var_aux.(seal_eq).
+Global Arguments ghost_var {Σ A _} γ dq a.
+
+Local Ltac unseal := rewrite ?ghost_var_eq /ghost_var_def.
+
+Section lemmas.
+ Context `{!ghost_varG Σ A}.
+ Implicit Types (a b : A) (dq : dfrac) (q : Qp).
+
+ Global Instance ghost_var_timeless γ dq a : Timeless (ghost_var γ dq a).
+ Proof. unseal. apply _. Qed.
+ Global Instance ghost_var_discard_persistent γ a : Persistent (ghost_var γ DfracDiscarded a).
+ Proof. unseal. apply _. Qed.
+
+ Global Instance ghost_var_fractional γ a : Fractional (λ q, ghost_var γ (DfracOwn q) a).
+ Proof. intros q1 q2. unseal. rewrite -own_op -dfrac_agree_own_op //. Qed.
+ Global Instance ghost_var_as_fractional γ a q :
+ AsFractional (ghost_var γ (DfracOwn q) a) (λ q, ghost_var γ (DfracOwn q) a) q.
+ Proof. split; [done|]. apply _. Qed.
+
+ Lemma ghost_var_alloc_strong a (P : gname → Prop) :
+ pred_infinite P →
+ ⊢ |==> ∃ γ, ⌜P γ⌠∗ ghost_var γ (DfracOwn 1) a.
+ Proof. unseal. intros. iApply own_alloc_strong; done. Qed.
+ Lemma ghost_var_alloc a :
+ ⊢ |==> ∃ γ, ghost_var γ (DfracOwn 1) a.
+ Proof. unseal. iApply own_alloc. done. Qed.
+
+ Lemma ghost_var_valid_2 γ a1 q1 a2 q2 :
+ ghost_var γ (DfracOwn q1) a1 -∗ ghost_var γ (DfracOwn q2) a2 -∗ ⌜(q1 + q2 ≤ 1)%Qp ∧ a1 = a2âŒ.
+ Proof.
+ unseal. iIntros "Hvar1 Hvar2".
+ iDestruct (own_valid_2 with "Hvar1 Hvar2") as %[Hq Ha]%dfrac_agree_own_op_valid.
+ done.
+ Qed.
+ (** Almost all the time, this is all you really need. *)
+ Lemma ghost_var_agree γ a1 dq1 a2 dq2 :
+ ghost_var γ dq1 a1 -∗ ghost_var γ dq2 a2 -∗ ⌜a1 = a2âŒ.
+ Proof.
+ unseal. iIntros "Hvar1 Hvar2".
+ iDestruct (own_valid_2 with "Hvar1 Hvar2") as %Ha%dfrac_agree_op_valid. done.
+ Qed.
+
+ Global Instance ghost_var_combine_gives γ a1 q1 a2 q2 :
+ CombineSepGives (ghost_var γ (DfracOwn q1) a1) (ghost_var γ (DfracOwn q2) a2)
+ ⌜(q1 + q2 ≤ 1)%Qp ∧ a1 = a2âŒ.
+ Proof.
+ rewrite /CombineSepGives. iIntros "[H1 H2]".
+ iDestruct (ghost_var_valid_2 with "H1 H2") as %[H1 H2].
+ eauto.
+ Qed.
+
+ Global Instance ghost_var_combine_as γ a1 q1 a2 q2 q :
+ IsOp q q1 q2 →
+ CombineSepAs (ghost_var γ (DfracOwn q1) a1) (ghost_var γ (DfracOwn q2) a2)
+ (ghost_var γ (DfracOwn q) a1) | 60.
+ (* higher cost than the Fractional instance, which is used for a1 = a2 *)
+ Proof.
+ rewrite /CombineSepAs /IsOp => ->. iIntros "[H1 H2]".
+ (* This can't be a single [iCombine] since the instance providing that is
+ exactly what we are proving here. *)
+ iCombine "H1 H2" gives %[_ ->].
+ by iCombine "H1 H2" as "H".
+ Qed.
+
+ (** This is just an instance of fractionality above, but that can be hard to find. *)
+ Lemma ghost_var_split γ a q1 q2 :
+ ghost_var γ (DfracOwn (q1 + q2)) a -∗ ghost_var γ (DfracOwn q1) a ∗ ghost_var γ (DfracOwn q2) a.
+ Proof. iIntros "[$$]". Qed.
+
+ (** Update the ghost variable to new value [b]. *)
+ Lemma ghost_var_update b γ a :
+ ghost_var γ (DfracOwn 1) a ==∗ ghost_var γ (DfracOwn 1) b.
+ Proof.
+ unseal. iApply own_update. apply cmra_update_exclusive. done.
+ Qed.
+ Lemma ghost_var_update_2 b γ a1 q1 a2 q2 :
+ (q1 + q2 = 1)%Qp →
+ ghost_var γ (DfracOwn q1) a1 -∗ ghost_var γ (DfracOwn q2) a2 ==∗
+ ghost_var γ (DfracOwn q1) b ∗ ghost_var γ (DfracOwn q2) b.
+ Proof.
+ iIntros (Hq) "H1 H2".
+ iDestruct (ghost_var_valid_2 with "H1 H2") as %[_ ->].
+ iCombine "H1 H2" as "H".
+ simpl. rewrite Hq.
+ iMod (ghost_var_update with "H") as "H".
+ rewrite -Hq. iApply ghost_var_split. done.
+ Qed.
+ Lemma ghost_var_update_halves b γ a1 a2 :
+ ghost_var γ (DfracOwn (1/2)) a1 -∗
+ ghost_var γ (DfracOwn (1/2)) a2 ==∗
+ ghost_var γ (DfracOwn (1/2)) b ∗ ghost_var γ (DfracOwn (1/2)) b.
+ Proof. iApply ghost_var_update_2. apply Qp.half_half. Qed.
+ Lemma ghost_var_discard γ dq a :
+ ghost_var γ dq a ==∗ ghost_var γ DfracDiscarded a.
+ Proof.
+ unseal. iApply own_update. apply dfrac_agree_discard_update.
+ Qed.
+
+End lemmas.
diff --git a/theories/rust_typing/gvar_refinement.v b/theories/rust_typing/gvar_refinement.v
new file mode 100644
index 0000000000000000000000000000000000000000..e6b70e7806f8cbc3859abf11d008ab8f7592ffbd
--- /dev/null
+++ b/theories/rust_typing/gvar_refinement.v
@@ -0,0 +1,229 @@
+(* TODO: something breaks with the lft logic notations as soon as we import this *)
+(*From refinedc.lang Require Import rust.*)
+From iris.bi Require Export fractional.
+From refinedrust Require Export base.
+From refinedrust Require Export ghost_var_dfrac.
+
+
+(*
+Section retraction.
+ Context {X Y : Type}.
+ Record retraction (f : X → Y) (g : Y → option X) := {
+ retraction_left_inv : ∀ x, g (f x) = Some x;
+ retraction_right_inv : ∀ y x, g y = Some x → f x = y;
+ }.
+
+ (* TODO: lemmas about this *)
+End retraction.
+Arguments retraction_left_inv { _ _ _ _ }.
+Arguments retraction_right_inv { _ _ _ _ }.
+
+(** Closed-world refinement *)
+Section rfn.
+ Context (RT : Type).
+
+ Class RTInj (C : Type → Type) := {
+ RTInj_into : C RT → RT;
+ RTInj_match : RT → option (C RT);
+ RTInj_retraction : retraction RTInj_into RTInj_match;
+ }.
+
+ Global Instance RTInj_inj `{RTInj C} : Inj (=) (=) (RTInj_into).
+ Proof.
+ intros a b Heq. specialize (retraction_left_inv RTInj_retraction a). rewrite Heq.
+ rewrite (retraction_left_inv RTInj_retraction). intros [= <-]; done.
+ Qed.
+End rfn.
+Global Arguments RTInj_into {_ _ _}.
+Global Arguments RTInj_match {_ _ _}.
+
+Section test.
+ Context {RT}
+ `{RTInj RT (const Z)}
+ `{RTInj RT list}
+ .
+
+ Definition Z_rt : RT := RTInj_into 5%Z.
+ Definition list_rt : RT := RTInj_into [RTInj_into 42%Z; Z_rt].
+
+ Definition match_list (x : RT) :=
+ if RTInj_match (C := list) x is Some xs then
+ if RTInj_match (C := const Z) (hd (RTInj_into 0%Z) xs) is Some 42%Z then true else false
+ else false.
+
+ Eval hnf in (match_list list_rt).
+
+
+
+ (* Of course, this doesn't simplify, and simplification/matching is needed a lot in the typing rules. *)
+ (* Q is: can I hide that sufficiently in the typing rules, so that it doesn't actually happen?
+ Ideally, the interface would remain very much the same as it is now.
+
+
+ In principle: Since everything is anyways indexed, I could just do the injection only at the ghost-variable uses.
+ At all other places, just keep it as it is now. This should be relatively easy to encapsulate while not complicating the typing rules much.
+ We might even be able to completely encapsulate that in the ghostvar assertions.
+ - for that, RTInj needs to be able to compose constructors structurally... that seems hard.
+ currently, we'd need to insert the injections everywhere manually at every nesting point.
+
+
+
+
+ Point: I need to somehow compose these injections. That seems difficult.
+
+ e.g. for mutable refs. I need to know that I can inject the refinement type of the nested thing, and that I have the suitable constructor available.
+ How do I do that? For the nested thing, would assume RTInj (const rt).
+ That is hard to demonstrate.
+ *)
+
+
+ (* Otherwise, we could either:
+ - use a lot of symbolic reasoning to do these things. That's not so nice, tbh.
+ - define one instantiation statically when we do the typechecking so it can compute, instead of defining it just for adequacy.
+ We can still keep the whole type system generic over it, but when we actually want to verify programs, we instantiate a global typeclass to declare the refinement type.
+ Of course, Q: how to verify libraries generically. Verifying libraries is a pretty big point for us, esp. around generics.
+ Point: in the generic code, the generic refinement is a leaf that doesn't need any interaction computation.
+ It's fine if there is a `RTInj_into r` that doesn't simplify or so.
+ Might I need RTInj_match (RTInj_into r) and simplify that? I think not, since all my typing rules that want to match will fall into the "type is opaque" case, so I can't simplify anyways and won't even try to do that.
+ Caveat that remains: I need to reinstantiate the type everytime.
+
+ Can I define the type with an "extension point"?
+ I want to take the union of some types without loosing computationality.
+
+
+
+
+ *)
+
+
+ (* Or just do refinements where we treat the injections as purely symbolic, i.e. everywhere in the typing rules we also have the injections.
+ Essentially, the injections would be at similar palces as the place_rfn, since that is how we are able to nest them?
+
+
+ ltypes are refined by place_rfn RT.
+ Ghost variables will store an RT.
+
+ mut_ref.own_val κ v (r: RT, γ) :=
+ gvar_obs γ r ∗
+ &pin κ ( ∃ r', gvar_auth γ r' ∗ ∃ r'' : rt, RT_match r' = Some r'' ∗ inner.own ... )
+
+ then get gvar_obs γ r, without the knowledge that it actually is something of the right type. but maybe that is fine.
+
+ mut_lty_own κ l (r : place_rfn (RT * gname)) (Owned wl) :=
+ ∃ r', rfn_interp_owned r r' ∗
+
+
+
+
+ *)
+
+End test.
+ *)
+
+Section sigma.
+ Record RT : Type := RT_into {
+ RT_rt : Type;
+ RT_r : RT_rt;
+ }.
+ Global Arguments RT_into {_}.
+
+ Import EqNotations.
+ Lemma RT_rt_eq (x y : RT) :
+ x = y → RT_rt x = RT_rt y.
+ Proof.
+ inversion 1. done.
+ Qed.
+ Lemma RT_r_eq (x y : RT) (Heq : x = y) :
+ rew Heq in RT_r x = RT_r y.
+ Proof.
+ inversion Heq. subst. done.
+ Qed.
+
+ Lemma RT_into_inj T (x y : T) :
+ RT_into x = RT_into y → x = y.
+ Proof.
+ revert x y.
+ enough (∀ a b : RT, a = b → ∀ Heq' : RT_rt a = RT_rt b, rew [id] Heq' in RT_r a = RT_r b) as H.
+ { intros x y Heq. by specialize (H _ _ Heq eq_refl). }
+ intros a b Heq. destruct Heq. intros Heq.
+ specialize (UIP_t _ _ _ Heq eq_refl) as ->. done.
+ Qed.
+
+End sigma.
+
+(* NOTE: In principle, I'd like to keep the refinements themselves as-is. Just for the ghost variables, I want to pack stuff up. Maybe the bundling into the sigma types is a good way to achieve that.
+ Potentially, that even works as a general abstraction in the gvar interface.
+ *)
+Section ghost_variables.
+ Context `{ghost_varG Σ RT} {T : Type}.
+ Implicit Types (γ : gname) (t : T).
+
+ Definition gvar_auth γ t := ghost_var γ (DfracOwn (1/2)) (RT_into t).
+ Definition gvar_obs γ t := ghost_var γ (DfracOwn (1/2)) (RT_into t).
+ Definition gvar_pobs γ t := ghost_var γ DfracDiscarded (RT_into t).
+
+ Global Instance gvar_pobs_persistent γ t : Persistent (gvar_pobs γ t).
+ Proof. apply _. Qed.
+
+ Lemma gvar_alloc t :
+ ⊢ |==> ∃ γ, gvar_auth γ t ∗ gvar_obs γ t.
+ Proof.
+ iMod (ghost_var_alloc (RT_into t)) as "(%γ & (? & ?))".
+ iModIntro. iExists γ. iFrame.
+ Qed.
+
+ Lemma gvar_update {γ t1 t2} t :
+ gvar_auth γ t1 -∗ gvar_obs γ t2 ==∗ gvar_auth γ t ∗ gvar_obs γ t.
+ Proof. iApply ghost_var_update_halves. Qed.
+
+ Lemma gvar_obs_persist γ t :
+ gvar_obs γ t ==∗ gvar_pobs γ t.
+ Proof. iApply ghost_var_discard. Qed.
+
+ Lemma gvar_agree γ t1 t2:
+ gvar_auth γ t1 -∗ gvar_obs γ t2 -∗ ⌜t1 = t2âŒ.
+ Proof.
+ iIntros "H1 H2".
+ iPoseProof (ghost_var_agree with "H1 H2") as "%Heq".
+ apply RT_into_inj in Heq. done.
+ Qed.
+
+ Lemma gvar_pobs_agree γ t1 t2:
+ gvar_auth γ t1 -∗ gvar_pobs γ t2 -∗ ⌜t1 = t2âŒ.
+ Proof.
+ iIntros "H1 H2".
+ iPoseProof (ghost_var_agree with "H1 H2") as "%Heq".
+ apply RT_into_inj in Heq. done.
+ Qed.
+
+ Definition Rel2 (γ1 γ2 : gname) (R : T → T → Prop) : iProp Σ :=
+ ∃ v1 v2, gvar_auth γ1 v1 ∗ gvar_obs γ2 v2 ∗ ⌜R v1 v2âŒ.
+
+ Lemma Rel2_use_pobs γ1 γ2 R v1 :
+ gvar_pobs γ1 v1 -∗ Rel2 γ1 γ2 R -∗ ∃ v2, gvar_obs γ2 v2 ∗ ⌜R v1 v2âŒ.
+ Proof.
+ iIntros "Hobs1 (%v1' & %v2 & Hauth1 & Hobs2 & %HR)".
+ iPoseProof (gvar_pobs_agree with "Hauth1 Hobs1") as "->".
+ eauto with iFrame.
+ Qed.
+
+ Lemma Rel2_use_obs γ1 γ2 R v1 :
+ gvar_obs γ1 v1 -∗ Rel2 γ1 γ2 R -∗ ∃ v2, gvar_obs γ2 v2 ∗ gvar_obs γ1 v1 ∗ gvar_auth γ1 v1 ∗ ⌜R v1 v2âŒ.
+ Proof.
+ iIntros "Hobs1 (%v1' & %v2 & Hauth1 & Hobs2 & %HR)".
+ iDestruct (gvar_agree with "Hauth1 Hobs1") as %->.
+ eauto with iFrame.
+ Qed.
+
+ Lemma Rel2_use_trivial γ1 γ2 R :
+ Rel2 γ1 γ2 R -∗ ∃ v2, gvar_obs γ2 v2.
+ Proof.
+ iIntros "(%v1' & %v2 & Hauth1 & Hobs2 & %HR)".
+ eauto with iFrame.
+ Qed.
+
+ Global Instance Rel2_timeless γ1 γ2 R : Timeless (Rel2 γ1 γ2 R).
+ Proof. apply _. Qed.
+
+ (* TODO: define Rel, etc. *)
+End ghost_variables.
diff --git a/theories/rust_typing/hlist.v b/theories/rust_typing/hlist.v
new file mode 100644
index 0000000000000000000000000000000000000000..c75e1542f248ff3f403e549be64ee6e8fc1ff6b6
--- /dev/null
+++ b/theories/rust_typing/hlist.v
@@ -0,0 +1,1438 @@
+From iris.algebra Require Import ofe.
+From iris.proofmode Require Import tactics.
+From refinedrust Require Import axioms base.
+Require Import Coq.Program.Equality.
+Local Set Universe Polymorphism.
+
+(** This file is copied and modified from Yusuke Matsushita's RustHornBelt project. *)
+
+(* TODO: Coq.Program.Equality and dependent destruct introduce axioms. Can I eliminate that? *)
+
+(** List.nth with better pattern matching *)
+Fixpoint lnth {A} (d: A) (xl: list A) (i: nat) : A :=
+ match xl with
+ | [] => d
+ | x :: xl' => match i with 0 => x | S j => lnth d xl' j end
+ end.
+Notation lnthe := (lnth ∅).
+
+Lemma lnth_default {A} D (xl : list A) i :
+ length xl <= i → D = lnth D xl i.
+Proof.
+ generalize dependent xl.
+ induction i; destruct xl; simpl; intros; auto with lia.
+Qed.
+
+Lemma lookup_lnth {X} (l : list X) x i (d : X) :
+ l !! i = Some x → lnth d l i = x.
+Proof.
+ induction l as [ | y l IH] in i |-*; simpl; first done.
+ destruct i as [ | i]; simpl.
+ - intros [= ->]. done.
+ - intros Ha%IH; done.
+Qed.
+
+
+Class Inj3 {A B C D} (R1: relation A) (R2: relation B) (R3: relation C)
+ (S: relation D) (f: A → B → C → D) : Prop :=
+ inj3 x1 x2 x3 y1 y2 y3 :
+ S (f x1 x2 x3) (f y1 y2 y3) → R1 x1 y1 ∧ R2 x2 y2 ∧ R3 x3 y3.
+
+Global Arguments inj3 {_ _ _ _ _ _ _ _} _ {_} _ _ _ _ _ _ _ : assert.
+
+
+(** * Heterogeneous List *)
+
+(* TODO: we probably want to define a separate polymorphic list type here to avoid problems with [list]'s template polymorphism... *)
+(* TODO try *)
+Local Unset Universe Minimization ToSet.
+#[universes(polymorphic)]
+Inductive hlist {A} (F: A → Type) : list A → Type :=
+| hnil: hlist F []
+| hcons {X Xl} : F X → hlist F Xl → hlist F (X :: Xl).
+Notation "+[ ]" := (hnil _) (at level 1, format "+[ ]").
+Notation "+[ ]@{ F }" := (hnil F) (at level 1, only parsing).
+Infix "+::" := (hcons _) (at level 60, right associativity).
+Infix "+::@{ F }" := (hcons F) (at level 60, right associativity, only parsing).
+Notation "+[ x ; .. ; z ]" := (x +:: .. (z +:: +[]) ..)
+ (at level 1, format "+[ x ; .. ; z ]").
+Notation "+[ x ; .. ; z ]@{ F }" := (x +:: .. (z +:: +[]@{F}) ..)
+ (at level 1, only parsing).
+
+Global Instance inhabited_hlist_nil {A} (F : A → Type) :
+ Inhabited (hlist F []).
+Proof. constructor. exact +[]. Qed.
+Global Instance inhabited_hlist {A} (F : A → Type) (l : list A):
+ TCTForall (λ T, Inhabited (F T)) l →
+ Inhabited (hlist F l).
+Proof.
+ intros Ha. induction l as [ | x l IH]; simpl.
+ - econstructor. econstructor.
+ - inversion Ha as [ | ? ? [] HF]; subst. apply IH in HF as [].
+ econstructor. constructor; done.
+Qed.
+
+Section hlist.
+Set Universe Polymorphism.
+Context {A: Type} {F: A → Type}.
+
+Definition hlist_nil_inv (P: hlist F [] → Type) (H: P +[]) (xl : hlist F []) : P xl :=
+ match xl with +[] => H end.
+
+Definition hlist_cons_inv {X Xl'}
+ (P: hlist F (X :: Xl') → Type) (H: ∀x xl', P (x +:: xl')) (xl : hlist F (X :: Xl')): P xl.
+Proof.
+ move: P H. refine match xl with x +:: xl' => λ _ H, H x xl' end.
+Defined.
+
+Fixpoint happ {Xl Yl} (xl: hlist F Xl) (yl: hlist F Yl) : hlist F (Xl ++ Yl) :=
+ match xl with +[] => yl | x +:: xl' => x +:: happ xl' yl end.
+
+Fixpoint hmap {G} (f: ∀ X, F X → G X) {Xl} (xl: hlist F Xl) : hlist G Xl :=
+ match xl with +[] => +[] | x +:: xl' => f _ x +:: hmap f xl' end.
+
+(* constant map *)
+Fixpoint hcmap {Y} (f: ∀ X, F X → Y) {Xl} (xl: hlist F Xl) : list Y :=
+ match xl with +[] => [] | x +:: xl' => f _ x :: hcmap f xl' end.
+
+(* get the nth element *)
+Fixpoint hnth {Xl D} (d: F D) (xl: hlist F Xl)
+ : ∀i, F (lnth D Xl i) :=
+ match xl with
+ | +[] => λ _, d
+ | x +:: xl' =>
+ λ i, match i with 0 => x | S j => hnth d xl' j end
+ end.
+
+Fixpoint hrepeat {X} (x: F X) n : hlist F (repeat X n) :=
+ match n with 0 => +[] | S m => x +:: hrepeat x m end.
+
+Fixpoint max_hlist_with {Xl} (f: ∀ X, F X → nat) (xl: hlist F Xl) : nat :=
+ match xl with +[] => 0 | x +:: xl' => f _ x `max` max_hlist_with f xl' end.
+
+Fixpoint happly {Y Xl} (fl: hlist (λ X, Y → F X) Xl) (x: Y)
+ : hlist F Xl :=
+ match fl with +[] => +[] | f +:: fl' => f x +:: happly fl' x end.
+
+Lemma hnth_default `{EqDecision A} {D Xl} (d : F D) (l : hlist F Xl) i :
+ ∀ (H : D = lnth D Xl i),
+ length Xl <= i →
+ hnth d l i = eq_rect D _ d _ H.
+Proof.
+ generalize dependent i. induction l.
+ - move => /= ? H. by rewrite (proof_irrel H eq_refl).
+ - move => /= [|?] *; auto with lia.
+Qed.
+End hlist.
+
+Ltac inv_hlist xl := let A := type of xl in
+ match eval hnf in A with hlist _ ?Xl =>
+ match eval hnf in Xl with
+ | [] => revert dependent xl;
+ match goal with |- ∀xl, @?P xl => apply (hlist_nil_inv P) end
+ | _ :: _ => revert dependent xl;
+ match goal with |- ∀xl, @?P xl => apply (hlist_cons_inv P) end;
+ (* Try going on recursively. *)
+ try (let x := fresh "x" in intros x xl; inv_hlist xl; revert x)
+ end
+ end.
+
+Section lemmas.
+ Context {A} {F : A → Type}.
+
+ Lemma hnth_apply {Xl Y D} (g: Y → F D)
+ (fl: hlist (λ X, Y → F X) Xl) (x: Y) i :
+ hnth (g x) (happly fl x) i = hnth g fl i x.
+ Proof. move: i. elim fl; [done|]=> > ?. by case. Qed.
+
+
+ Lemma hcmap_length {Y} (f : ∀ X, F X → Y) {Xl} (xl : hlist F Xl) :
+ length (hcmap f xl) = length Xl.
+ Proof.
+ induction Xl as [ | X Xl IH]; simpl.
+ - inv_hlist xl. done.
+ - inv_hlist xl. intros x xl' => /=. rewrite IH. done.
+ Qed.
+
+ Lemma fmap_hcmap {Y Z} (f : ∀ X, F X → Y) (g : Y → Z) {Xl} (xl : hlist F Xl) :
+ fmap g (hcmap f xl) = hcmap (λ _ x, g (f _ x)) xl.
+ Proof.
+ induction Xl as [ | X Xl IH]; simpl.
+ - inv_hlist xl. done.
+ - inv_hlist xl. intros x xl'.
+ simpl. f_equiv. apply IH.
+ Qed.
+
+ Lemma hcmap_ext {Y} (f g : ∀ X, F X → Y) {Xl} (xl : hlist F Xl) :
+ (∀ X x, f X x = g X x) →
+ hcmap f xl = hcmap g xl.
+ Proof.
+ intros Heq. induction Xl as [ | X Xl IH]; simpl.
+ - inv_hlist xl. done.
+ - inv_hlist xl. intros x xl'.
+ simpl. rewrite Heq IH //.
+ Qed.
+
+ Lemma hcmap_hmap {G Y} (f : ∀ X, F X → G X) (g : ∀ X, G X → Y) {Xl} (xl : hlist F Xl) :
+ hcmap g (hmap f xl) = hcmap (λ _ x, g _ (f _ x)) xl.
+ Proof.
+ induction xl as [ | X Xl x xl IH]; first done.
+ simpl. f_equiv. apply IH.
+ Qed.
+End lemmas.
+
+Infix "h++" := happ (at level 60, right associativity).
+Infix "+<$>" := hmap (at level 61, left associativity).
+Infix "+c<$>" := hcmap (at level 61, left associativity).
+Infix "+$" := happly (at level 61, left associativity).
+Notation "( fl +$.)" := (happly fl) (only parsing).
+
+(** * Passive Heterogeneous List *)
+(** Defined as nested pairs *)
+Inductive nil_unit: Set := nil_tt: nil_unit.
+Record cons_prod (A B: Type) : Type := cons_pair { phd' : A; ptl' : B }.
+Arguments cons_pair {_ _} _ _.
+Arguments phd' {_ _} _.
+Arguments ptl' {_ _} _.
+
+Section plist.
+ Context {A} {F : A → Type}.
+ #[universes(polymorphic)]
+ Fixpoint plist (Xl: list A) : Type :=
+ match Xl with [] => nil_unit | X :: Xl' => cons_prod (F X) (plist Xl') end.
+End plist.
+
+Definition pcons {A} {F : A → Type} {a X} (hd : F a) (tl : plist X) : plist (a :: X) :=
+ cons_pair hd tl.
+Definition pnil {A} {F : A → Type} : plist (F := F) [] := nil_tt.
+
+Definition phd {A : Type} {F : A → Type} {X Xs} (pl : plist (X :: Xs)) : F X := phd' pl.
+Definition ptl {A : Type} {F : A → Type} {X Xs} (pl : plist (X :: Xs)) : plist (F := F) Xs := ptl' pl.
+
+Notation "-[ ]" := pnil (at level 1, format "-[ ]").
+Infix "-::" := pcons (at level 60, right associativity).
+Notation "(-::)" := pcons (only parsing).
+Notation "-[ x ; .. ; z ]" := (x -:: .. (z -:: -[]) ..)
+ (at level 1, format "-[ x ; .. ; z ]").
+
+Inductive TCTForall {A} (P : A → Type) : list A → Type :=
+ | TCTForall_nil : TCTForall P []
+ | TCTForall_cons x xs : P x → TCTForall P xs → TCTForall P (x :: xs).
+Existing Class TCTForall.
+Global Existing Instance TCTForall_nil.
+Global Existing Instance TCTForall_cons.
+Global Hint Mode TCTForall ! ! ! : typeclass_instances.
+
+Global Instance inhabited_plist_nil {A} (F : A → Type) :
+ Inhabited (plist (F:=F) []).
+Proof. constructor. exact -[]. Qed.
+Global Instance inhabited_plist {A} (F : A → Type) (l : list A):
+ TCTForall (λ T, Inhabited (F T)) l →
+ Inhabited (plist (F:=F) l).
+Proof.
+ intros Ha. induction l as [ | x l IH]; simpl.
+ - econstructor. exact nil_tt.
+ - inversion Ha as [ | ? ? [] HF]; subst. apply IH in HF as [].
+ econstructor. constructor; done.
+Qed.
+
+Section plist.
+Context {A: Type} {F: A → Type}.
+Set Universe Polymorphism.
+
+Notation plist := (plist (F:=F)).
+
+Fixpoint papp {Xl Yl} (xl: plist Xl) (yl: plist Yl) : plist (Xl ++ Yl) :=
+ match Xl, xl with [], _ => yl | _::_, cons_pair x xl' => x -:: papp xl' yl end.
+
+Fixpoint psepl {Xl Yl} (xl: plist (Xl ++ Yl)) : plist Xl :=
+ match Xl, xl with [], _ => -[] | _::_, cons_pair x xl' => x -:: psepl xl' end.
+Fixpoint psepr {Xl Yl} (xl: plist (Xl ++ Yl)) : plist Yl :=
+ match Xl, xl with [], _ => xl | _::_, cons_pair _ xl' => psepr xl' end.
+
+Lemma papp_sepl {Xl Yl} (xl: plist Xl) (yl: plist Yl) : psepl (papp xl yl) = xl.
+Proof. move: xl yl. elim Xl; [by case|]=>/= > IH [??]?. simpl. by rewrite IH. Qed.
+Lemma papp_sepr {Xl Yl} (xl: plist Xl) (yl: plist Yl) : psepr (papp xl yl) = yl.
+Proof. move: xl yl. elim Xl; [by case|]=>/= > IH [??]?. simpl. by rewrite IH. Qed.
+
+Lemma psep_app {Xl Yl} (xl: plist (Xl ++ Yl)) : papp (psepl xl) (psepr xl) = xl.
+Proof. move: xl. elim Xl; [done|]=>/= > IH [??]. simpl. by rewrite IH. Qed.
+Lemma papp_ex {Xl Yl} (xl: plist (Xl ++ Yl)) :
+ ∃(yl: plist Xl) (zl: plist Yl), xl = papp yl zl.
+Proof. exists (psepl xl), (psepr xl). by rewrite psep_app. Qed.
+
+Fixpoint pnth {Xl D} (d: F D) (xl: plist Xl) : ∀i, F (lnth D Xl i) :=
+ match Xl, xl with
+ | [], _ => λ _, d
+ | _::_, cons_pair x xl' => λ i, match i with 0 => x | S j => pnth d xl' j end
+ end.
+
+Fixpoint hlist_to_plist {Xl} (xl: hlist F Xl) : plist Xl :=
+ match xl with +[] => -[] | x +:: xl' => x -:: hlist_to_plist xl' end.
+Fixpoint plist_to_hlist {Xl} (xl: plist Xl) : hlist F Xl :=
+ match Xl, xl with [], _ => +[] | _::_, cons_pair x xl' => x +:: plist_to_hlist xl' end.
+
+Fixpoint vec_to_plist {X n} (xl: vec (F X) n) : plist (replicate n X) :=
+ match xl with [#] => -[] | x ::: xl' => x -:: vec_to_plist xl' end.
+Fixpoint plist_to_vec {X n} (xl: plist (replicate n X)) : vec (F X) n :=
+ match n, xl with 0, _ => [#] | S _, cons_pair x xl' => x ::: plist_to_vec xl' end.
+End plist.
+
+Arguments plist {_} _ _.
+
+Infix "-++" := papp (at level 60, right associativity).
+Notation psep := (λ xl, (psepl xl, psepr xl)).
+
+Lemma plist_nil_inv {A} {F : A → Type} (P: plist F [] → Type) (H: P -[]) (xl : plist F []) : P xl.
+Proof.
+ destruct xl. apply H.
+Defined.
+
+Definition plist_cons_inv {A} {F : A → Type} {X Xl'}
+ (P: plist F (X :: Xl') → Type) (H: ∀ x (xl' : plist F Xl'), P (x -:: xl')) (xl : plist F (X :: Xl')): P xl.
+Proof.
+ destruct xl as [x xl].
+ apply H.
+Defined.
+
+Fixpoint pmap {A} {F G : A → Type} (f: ∀X, F X → G X) {Xl} : plist F Xl → plist G Xl :=
+ match Xl with [] => id | _::_ => λ '(cons_pair x xl'), f _ x -:: pmap f xl' end.
+Infix "-<$>" := pmap (at level 61, left associativity).
+
+Fixpoint pcmap {A B} {F : A → Type} (f : ∀ X, F X → B) {Xl} : plist F Xl → list B :=
+ match Xl with
+ | [] => λ _, []
+ | _ :: _ =>
+ λ '(cons_pair x xl'), f _ x :: pcmap f xl'
+ end.
+
+Lemma pmap_app {A} {F G : A → Type} {Xl Yl} (f: ∀X, F X → G X)
+ (xl: plist F Xl) (yl: plist F Yl) :
+ f -<$> (xl -++ yl) = (f -<$> xl) -++ (f -<$> yl).
+Proof. move: xl. elim Xl; [done|]=>/= ?? IH [??]. simpl. by rewrite IH. Qed.
+
+Fixpoint papply {A} {F : A → Type} {B Xl}
+ (fl: plist (λ X, B → F X) Xl) (x: B) : plist F Xl :=
+ match Xl, fl with
+ | [], _ => -[]
+ | _::_, cons_pair f fl' => f x -:: papply fl' x
+ end.
+Infix "-$" := papply (at level 61, left associativity).
+Notation "( fl -$.)" := (papply fl) (only parsing).
+
+Lemma papply_app {A} {F: A → Type} {B Xl Yl}
+ (fl: plist (λ X, B → F X) Xl) (gl: plist (λ X, B → F X) Yl) (x: B) :
+ (fl -++ gl) -$ x = (fl -$ x) -++ (gl -$ x).
+Proof. move: fl. elim Xl; [done|]=>/= ?? IH [??]. simpl. by rewrite IH. Qed.
+
+Fixpoint hzip_with {A} {F G H: A → Type} {Xl} (f: ∀X, F X → G X → H X)
+ (xl: hlist F Xl) (yl: plist G Xl) : hlist H Xl :=
+ match xl, yl with
+ | +[], _ => +[]
+ | x +:: xl', cons_pair y yl' => f _ x y +:: hzip_with f xl' yl'
+ end.
+Notation hzip := (hzip_with (λ _, pair)).
+
+Fixpoint pzip_with {A} {F G H: A → Type} {Xl} (f: ∀X, F X → G X → H X)
+ (xl: plist F Xl) (yl: plist G Xl) : plist H Xl :=
+ match Xl, xl, yl with
+ | [], _, _ => -[]
+ | _::_, cons_pair x xl', cons_pair y yl' => f _ x y -:: pzip_with f xl' yl'
+ end.
+Notation pzip := (pzip_with (λ _, pair)).
+
+Lemma plist_fmap_shift {A B : Type} (F : B → Type) (f : A → B) (l : list A) :
+ plist (F ∘ f) l = plist F (fmap f l).
+Proof.
+ induction l; simpl; first done. f_equiv. done.
+Qed.
+
+(* We don't use [∘] here because [∘] is universe-monomorphic
+ and thus causes universe inconsistency *)
+Fixpoint ptrans {A B} {F: A → B} {G Xl} (xl: plist (λ X, G (F X)) Xl)
+ : plist G (map F Xl) :=
+ match Xl, xl with [], _ => -[] | _::_, cons_pair x xl' => x -:: ptrans xl' end.
+
+Fixpoint hlist_to_list {T A Xl} (xl: @hlist T (const A) Xl) : list A :=
+ match xl with +[] => [] | x +:: xl' => x :: hlist_to_list xl' end.
+
+Fixpoint list_to_hlist {T A Xl} (xl: list A) : option (hlist (λ _: T, A) Xl) :=
+ match xl, Xl with
+ | [], [] => mret +[]
+ | x :: xl', X :: Xl' => list_to_hlist xl' ≫= λ tl, mret (x +:: tl)
+ | _, _ => None
+ end.
+
+Lemma list_to_hlist_length {A T Xl} (l : list A) (l' : hlist (λ _: T, A) Xl) :
+ list_to_hlist l = Some l' →
+ length l = length Xl.
+Proof.
+ revert l'. generalize dependent Xl.
+ induction l => - [|? ?] //= ?.
+ destruct (list_to_hlist (Xl := _) _) eqn: X; rewrite ?(IHl _ h) //.
+Qed.
+
+Lemma list_to_hlist_hnth_nth {A T Xl} (t: T) (d : A) i
+ (l : list A) (l' : hlist (λ _: T, A) Xl) :
+ list_to_hlist l = Some l' →
+ hnth (D := t) d l' i = nth i l d.
+Proof.
+ generalize dependent Xl. revert i.
+ induction l => i [| ? Xl] ? //=.
+ - case: i => [|?] [= <-] //=.
+ - destruct (list_to_hlist (Xl := _) _) eqn:X, i => //= [= <-] //=. auto.
+Qed.
+
+(** Some eqcasting facts *)
+Import EqNotations.
+Lemma plist_cons_rew1 {X Y} {G : Y → Type} {F : X → Type} (x : X) (y : Y) (Xl : list X) (Yl : list Y) (l : plist F (Xl)) (fx : F x)
+ (Heq : plist F (x :: Xl) = plist G (y :: Yl)) (Heq1 : F x = G y) (Heq2 : plist F Xl = plist G Yl) :
+ rew [id] Heq in (cons_pair fx l) = cons_pair (rew [id] Heq1 in fx) (rew [id] Heq2 in l).
+Proof.
+ move : l fx Heq Heq1 Heq2. simpl.
+ generalize ( F x) as T.
+ generalize (plist F Xl) as T2.
+ intros T2 T l fx Heq -> ->.
+ simpl. rewrite (UIP_refl _ _ Heq). done.
+Qed.
+Lemma plist_cons_rew {X Y} {G : Y → Type} {F : X → Type} (x : X) (y : Y) (Xl : list X) (Yl : list Y) (l : plist F (Xl)) (fx : F x)
+ (Heq : plist F (x :: Xl) = plist G (y :: Yl)) (Heq1 : F x = G y) (Heq2 : plist F Xl = plist G Yl) :
+ rew [id] Heq in (fx -:: l) = pcons (F := G) (rew [id] Heq1 in fx) (rew [id] Heq2 in l).
+Proof.
+ rewrite /pcons. rewrite plist_cons_rew1. done.
+Qed.
+
+Lemma plist_cons_rew1' {X Y} {G : Y → Type} {F : X → Type} (x : X) (y : Y) (Xl : list X) (Yl : list Y) (l : plist F (Xl)) (fx : F x)
+ (Heq : plist G (y :: Yl) = plist F (x :: Xl)) Heq1 (Heq2 : plist G Yl = plist F Xl) :
+ rew <- [id] Heq in (cons_pair fx l) = cons_pair (rew <- [id] Heq1 in fx) (rew <-[id] Heq2 in l).
+Proof.
+ move : l fx Heq Heq1 Heq2. simpl.
+ generalize ( F x) as T.
+ generalize (plist F Xl) as T2.
+ intros T2 T l fx Heq <- <-.
+ simpl. rewrite (UIP_refl _ _ Heq). done.
+Qed.
+Lemma plist_cons_rew' {X Y} {G : Y → Type} {F : X → Type} (x : X) (y : Y) (Xl : list X) (Yl : list Y) (l : plist F (Xl)) (fx : F x)
+ (Heq : plist G (y :: Yl) = plist F (x :: Xl)) Heq1 (Heq2 : plist G Yl = plist F Xl) :
+ rew <- [id] Heq in (fx -:: l) = pcons (F := G) (rew <- [id] Heq1 in fx) (rew <-[id] Heq2 in l).
+Proof.
+ rewrite /pcons. rewrite plist_cons_rew1' //.
+Qed.
+
+Lemma phd_rew_commute {X Y} {G : Y → Type} {F : X → Type} (x : X) (y : Y) (Xl : list X) (Yl : list Y) (l : plist F (x :: Xl)) (Heq1 : plist F (x :: Xl) = plist G (y :: Yl)) (Heq2 : F x = G y) (Heq3 : plist F Xl = plist G Yl) :
+ phd (rew [id] Heq1 in l) = rew [id] Heq2 in (phd l).
+Proof.
+ destruct l as [fx l].
+ simpl. unshelve erewrite (plist_cons_rew1 _ _ _ _ _ _ Heq1); done.
+Qed.
+
+Lemma ptl_rew_commute {X Y} {G : Y → Type} {F : X → Type} (x : X) (y : Y) (Xl : list X) (Yl : list Y) (l : plist F (x :: Xl)) (Heq1 : plist F (x :: Xl) = plist G (y :: Yl)) (Heq2 : F x = G y) (Heq3 : plist F Xl = plist G Yl) :
+ ptl (rew [id] Heq1 in l) = rew [id] Heq3 in (ptl l).
+Proof.
+ destruct l as [fx l].
+ simpl. unshelve erewrite (plist_cons_rew1 _ _ _ _ _ _ Heq1); done.
+Qed.
+
+(** * Forall *)
+
+Section fa.
+Context {A} {F: A → Type}.
+
+Inductive HForall (Φ: ∀X, F X → Prop) : ∀{Xl}, hlist F Xl → Prop :=
+| HForall_nil: HForall Φ +[]
+| HForall_cons {X Xl} (x: _ X) (xl: _ Xl) :
+ Φ _ x → HForall Φ xl → HForall Φ (x +:: xl).
+
+Inductive TCHForall (Φ : ∀ X, F X → Prop) : ∀ {Xl}, hlist F Xl → Prop :=
+| TCHForall_nil: TCHForall Φ +[]
+| TCHForall_cons {X Xl} (x : F X) (xl : hlist F Xl) :
+ Φ _ x → TCHForall Φ xl → TCHForall Φ (x +:: xl).
+Existing Class TCHForall.
+Global Existing Instance TCHForall_nil.
+Global Existing Instance TCHForall_cons.
+
+Lemma TCHForall_impl {Xl} (Φ Ψ : ∀ X, F X → Prop) (xl : hlist F Xl) :
+ (∀ X x, Φ X x → Ψ _ x) → TCHForall Φ xl → TCHForall Ψ xl.
+Proof. move=> Imp. elim; constructor; by [apply Imp|]. Qed.
+
+Lemma TCHForall_nth {Xl D} (Φ : ∀ X, F X → Prop) (d : F D) (xl : hlist F Xl) i :
+ Φ _ d → TCHForall Φ xl → Φ _ (hnth d xl i).
+Proof. move=> ? All. move: i. elim All; [done|]=> > ???. by case. Qed.
+
+Context {G: A → Type}.
+
+Inductive HForall_1 (Φ: ∀X, F X → G X → Prop)
+ : ∀{Xl}, hlist F Xl → plist G Xl → Prop :=
+| HForall_1_nil: HForall_1 Φ +[] -[]
+| HForall_1_cons {X Xl} (x: _ X) y (xl: _ Xl) yl :
+ Φ _ x y → HForall_1 Φ xl yl → HForall_1 Φ (x +:: xl) (y -:: yl).
+
+(*
+Inductive HForall_1' {H: A → A → Type} (Φ: ∀X Y, F X → H X Y → Prop)
+ : ∀{Xl Yl}, hlist F Xl → plist2 H Xl Yl → Prop :=
+| HForall_1'_nil: HForall_1' Φ +[] (-[]: plist2 _ [] [])
+| HForall_1'_cons {X Y Xl Yl} x z xl zl :
+ Φ _ _ x z → HForall_1' Φ xl zl →
+ HForall_1' Φ (x +:: xl) (z -:: zl: plist2 _ (X :: Xl) (Y :: Yl)).
+
+Inductive HForall2_1 {H: A → A → Type} (Φ: ∀X Y, F X → G Y → H X Y → Prop)
+ : ∀{Xl Yl}, hlist F Xl → hlist G Yl → plist2 H Xl Yl → Prop :=
+| HForall2_1_nil: HForall2_1 Φ +[] +[] -[]
+| HForall2_1_cons {X Y Xl Yl} (x: _ X) (y: _ Y) z (xl: _ Xl) (yl: _ Yl) zl :
+ Φ _ _ x y z → HForall2_1 Φ xl yl zl → HForall2_1 Φ (x +:: xl) (y +:: yl) (z -:: zl).
+
+Inductive HForall2_2flip {H K: A → A → Type} (Φ: ∀X Y, F X → G Y → H X Y → K Y X → Prop)
+ : ∀{Xl Yl}, hlist F Xl → hlist G Yl → plist2 H Xl Yl → plist2 K Yl Xl → Prop :=
+| HForall2_2flip_nil: HForall2_2flip Φ +[] +[] -[] -[]
+| HForall2_2flip_cons {X Y Xl Yl} (x: _ X) (y: _ Y) z w (xl: _ Xl) (yl: _ Yl) zl wl :
+ Φ _ _ x y z w → HForall2_2flip Φ xl yl zl wl →
+ HForall2_2flip Φ (x +:: xl) (y +:: yl) (z -:: zl) (w -:: wl).
+ *)
+
+Inductive HForallTwo (Φ: ∀X, F X → G X → Prop) : ∀{Xl}, hlist F Xl → hlist G Xl → Prop :=
+| HForallTwo_nil: HForallTwo Φ +[] +[]
+| HForallTwo_cons {X Xl} (x: _ X) y (xl: _ Xl) yl :
+ Φ _ x y → HForallTwo Φ xl yl → HForallTwo Φ (x +:: xl) (y +:: yl).
+
+Inductive HForallThree {H} (Φ: ∀X, F X → G X → H X → Prop) :
+ ∀{Xl}, hlist F Xl → hlist G Xl → hlist H Xl → Prop :=
+| HForallThree_nil: HForallThree Φ +[] +[] +[]
+| HForallThree_cons {X Xl} (x: _ X) y z (xl: _ Xl) yl zl :
+ Φ _ x y z → HForallThree Φ xl yl zl → HForallThree Φ (x +:: xl) (y +:: yl) (z +:: zl).
+
+Lemma HForallTwo_impl {Xl} (Φ Ψ: ∀X, F X → G X → Prop) (xl: hlist F Xl) (yl: hlist G Xl) :
+ (∀X x y, Φ X x y → Ψ X x y) → HForallTwo Φ xl yl → HForallTwo Ψ xl yl.
+Proof. move=> Imp. elim; constructor; by [apply Imp|]. Qed.
+
+Lemma HForall_1_nth {Xl D} (Φ: ∀X, F X → G X → Prop)
+ (d: _ D) d' (xl: _ Xl) yl i :
+ Φ _ d d' → HForall_1 Φ xl yl → Φ _ (hnth d xl i) (pnth d' yl i).
+Proof. move=> ? All. move: i. elim All; [done|]=> > ???. by case. Qed.
+
+(*
+Lemma HForall_1'_nth {H: A → A → Type} {Xl Yl D D'} (Φ: ∀X Y, F X → H X Y → Prop)
+ (d: _ D) (d': _ D') xl (yl: plist2 _ Xl Yl) i :
+ Φ _ _ d d' → HForall_1' Φ xl yl → Φ _ _ (hnth d xl i) (p2nth d' yl i).
+Proof. move=> ? All. move: i. elim All; [done|]=> > ???. by case. Qed.
+ *)
+
+Lemma HForallTwo_nth {Xl D}
+ (Φ: ∀X, F X → G X → Prop) (d: _ D) d' (xl: _ Xl) yl i :
+ Φ _ d d' → HForallTwo Φ xl yl → Φ _ (hnth d xl i) (hnth d' yl i).
+Proof. move=> ? All. move: i. elim All; [done|]=> > ???. by case. Qed.
+
+Lemma HForallTwo_forall `{!Inhabited Y} {Xl}
+ (Φ: ∀X, Y → F X → G X → Prop) (xl yl: _ Xl) :
+ (∀z, HForallTwo (λ X, Φ X z) xl yl) ↔ HForallTwo (λ X x y, ∀z, Φ _ z x y) xl yl.
+Proof.
+ split; [|elim; by constructor]. move=> All. set One := All inhabitant.
+ induction One; [by constructor|]. constructor.
+ { move=> z. move/(.$ z) in All. by dependent destruction All. }
+ have All': ∀z, HForallTwo (λ X, Φ X z) xl yl.
+ { move=> z. move/(.$ z) in All. by dependent destruction All. }
+ auto.
+Qed.
+
+Lemma HForallTwo_cons_inv (Φ : ∀ x, F x → G x → Prop) (Xl : list A) (hl1 : hlist F Xl) (hl2 : hlist G Xl) (x : A) (h1 : F x) (h2 : G x) :
+ HForallTwo Φ (h1 +:: hl1) (h2 +:: hl2) →
+ Φ _ h1 h2 ∧ HForallTwo Φ hl1 hl2.
+Proof.
+ inversion 1; subst.
+ repeat match goal with
+ | H : existT ?x _ = existT ?x _ |- _ => apply existT_inj in H
+ end; subst.
+ eauto.
+Qed.
+
+Lemma HForallThree_nth {H} {Xl D} (Φ: ∀X, F X → G X → H X → Prop)
+ (d: _ D) d' d'' (xl: _ Xl) yl zl i :
+ Φ _ d d' d'' → HForallThree Φ xl yl zl →
+ Φ _ (hnth d xl i) (hnth d' yl i) (hnth d'' zl i).
+Proof. move=> ? All. move: i. elim All; [done|]=> > ???. by case. Qed.
+
+Lemma HForallThree_nth_len {H} {Xl D} (Φ: ∀X, F X → G X → H X → Prop)
+ (d: _ D) d' d'' (xl: _ Xl) yl zl i :
+ (i < length Xl)%nat → HForallThree Φ xl yl zl →
+ Φ _ (hnth d xl i) (hnth d' yl i) (hnth d'' zl i).
+Proof.
+ move=> L All. move: i L. elim All; [simpl; lia|] => > ??? [|?] //=. auto with lia.
+Qed.
+End fa.
+
+Global Hint Mode TCHForall ! ! ! ! ! : typeclass_instances.
+
+Section HForallTwo.
+Context {A} {F: A → Type} {Xl: list A} (R: ∀X, F X → F X → Prop).
+
+Instance HForallTwo_reflexive :
+ (∀X, Reflexive (R X)) → Reflexive (HForallTwo R (Xl:=Xl)).
+Proof. move=> ?. elim; by constructor. Qed.
+Instance HForallTwo_symmetric :
+ (∀X, Symmetric (R X)) → Symmetric (HForallTwo R (Xl:=Xl)).
+Proof. move=> >. elim; by constructor. Qed.
+Instance HForallTwo_transitive :
+ (∀X, Transitive (R X)) → Transitive (HForallTwo R (Xl:=Xl)).
+Proof.
+ move=> ??? zl All. move: zl. elim: All; [done|]=> > ?? IH ? All.
+ dependent destruction All. constructor; by [etrans|apply IH].
+Qed.
+
+Global Instance HForallTwo_equivalence :
+ (∀X, Equivalence (R X)) → Equivalence (HForallTwo R (Xl:=Xl)).
+Proof. split; apply _. Qed.
+End HForallTwo.
+
+(** * Ofe *)
+Section hlist_ofe.
+Context {A} {F: A → ofe} {Xl : list A}.
+
+Instance hlist_equiv : Equiv (hlist F Xl) := HForallTwo (λ _, (≡)).
+Instance hlist_dist : Dist (hlist F Xl) := λ n, HForallTwo (λ _, dist n).
+
+Definition hlist_ofe_mixin : OfeMixin (hlist F Xl).
+Proof.
+ split=> >.
+ - rewrite /equiv /hlist_equiv HForallTwo_forall.
+ split=> H; induction H; constructor=>//; by apply equiv_dist.
+ - apply _.
+ - rewrite /dist /hlist_dist. intros ??.
+ eapply HForallTwo_impl; last done. intros ??? Hd.
+ eapply dist_lt; first apply Hd. done.
+Qed.
+
+Canonical Structure hlistO := Ofe (hlist F Xl) hlist_ofe_mixin.
+End hlist_ofe.
+
+Arguments hlistO {_} _ _.
+
+(* FIXME : this is to improve the corresponding hints defined in Iris,
+ which are not able to find the canonical structure for hlist, probably
+ because this is using eapply and its different unification algorithm. *)
+(*Global Hint Extern 0 (Equiv _) => refine (ofe_equiv _); shelve : typeclass_instances.*)
+(*Global Hint Extern 0 (Dist _) => refine (ofe_dist _); shelve : typeclass_instances.*)
+
+Section hlist_ofe_lemmas.
+Context {A} {F: A → ofe} {Xl : list A}.
+
+Global Instance hcons_ne {X} : NonExpansive2 (@hcons _ F X Xl).
+Proof. by constructor. Qed.
+Global Instance hcons_proper {X} : Proper ((≡) ==> (≡) ==> (≡)) (@hcons _ F X Xl).
+Proof. by constructor. Qed.
+
+Global Instance hnth_ne {D} n :
+ Proper ((=) ==> (dist n) ==> forall_relation (λ i, dist n)) (@hnth _ F Xl D).
+Proof. move=> ??->????. by apply (HForallTwo_nth (λ X, ofe_dist (F X) n)). Qed.
+Global Instance hnth_proper {D} :
+ Proper ((=) ==> (≡) ==> forall_relation (λ _, (≡))) (@hnth _ F Xl D).
+Proof. move=> ??->?? /equiv_dist ??. apply equiv_dist=> ?. by apply hnth_ne. Qed.
+End hlist_ofe_lemmas.
+
+(** Forall2 for plist *)
+Section pforall.
+ Context {A} {F G : A → Type}.
+
+ Fixpoint pforall {Xl} (Φ : ∀ X, F X → Prop) (xl : plist F Xl) : Prop :=
+ match Xl, xl with
+ | [], _ => True
+ | _::_, cons_pair x xl' => Φ _ x ∧ pforall Φ xl'
+ end.
+
+ Fixpoint pforall2 {Xl} (Φ : ∀ X, F X → G X → Prop) (xl : plist F Xl) (yl : plist G Xl) : Prop :=
+ match Xl, xl, yl with
+ | [], _, _ => True
+ | _ :: _, cons_pair x xl', cons_pair y yl' => Φ _ x y ∧ pforall2 Φ xl' yl'
+ end.
+
+ Lemma pforall2_forall {Xl W} (Φ : ∀ X, W → F X → G X → Prop) (xl : plist F Xl) (yl : plist G Xl) :
+ (∀ w, pforall2 (λ X, Φ X w) xl yl) ↔ pforall2 (λ X x y, ∀ w, Φ _ w x y) xl yl.
+ Proof.
+ induction Xl as [ | X Xl IH] in xl, yl |-*.
+ - destruct xl, yl. simpl. naive_solver.
+ - destruct xl as [x xl], yl as [y yl].
+ simpl. split.
+ + intros Hw. split; first apply Hw.
+ apply IH. apply Hw.
+ + intros [Hh Hl]. split; [apply Hh | apply IH, Hl].
+ Qed.
+
+ Lemma pforall2_iff {Xl} (Φ Ψ : ∀ X, F X → G X → Prop) (xl : plist F Xl) (yl : plist G Xl) :
+ (∀ X (x : F X) (y : G X), Φ X x y ↔ Ψ X x y) →
+ pforall2 Φ xl yl ↔ pforall2 Ψ xl yl.
+ Proof.
+ intros Heq. induction Xl as [ | X Xl IH] in xl, yl |-*; simpl; first done.
+ destruct xl as [x xl], yl as [y yl].
+ rewrite Heq IH. done.
+ Qed.
+
+ Lemma pforall2_impl {Xl} (Φ Ψ : ∀ X, F X → G X → Prop) (xl : plist F Xl) (yl : plist G Xl) :
+ (∀ X (x : F X) (y : G X), Φ X x y → Ψ X x y) →
+ pforall2 Φ xl yl → pforall2 Ψ xl yl.
+ Proof.
+ intros Heq. induction Xl as [ | X Xl IH] in xl, yl |-*; simpl; first done.
+ destruct xl as [x xl], yl as [y yl].
+ intros [?%Heq ?%IH]; done.
+ Qed.
+
+ (*Lemma pforall2_length {Xl} (Φ : ∀ X, F X → Prop) (xl : plist F Xl) (yl : plist G Xl) :*)
+ (*pforall2 Φ xl yl →*)
+End pforall.
+
+Section pforall2_rel.
+ Context {A} {F : A → Type}.
+
+ Instance pforall2_reflexive {Xl} (Φ : ∀ X, F X → F X → Prop) :
+ (∀ X, Reflexive (Φ X)) → Reflexive (pforall2 (Xl:=Xl) Φ).
+ Proof.
+ intros Hrefl. induction Xl as [ | X Xl IH]; intros []; done.
+ Qed.
+
+ Instance pforall2_transitive {Xl} (Φ : ∀ X, F X → F X → Prop) :
+ (∀ X, Transitive (Φ X)) → Transitive (pforall2 (Xl:=Xl) Φ).
+ Proof.
+ intros Htrans. induction Xl as [ | X Xl IH]; intros xl yl zl.
+ - destruct xl, yl, zl; done.
+ - destruct xl as [x xl], yl as [y yl], zl as [z zl].
+ intros [? ?] [? ?]. split; last by eapply IH. by etrans.
+ Qed.
+
+ Instance pforall2_symmetric {Xl} (Φ : ∀ X, F X → F X → Prop) :
+ (∀ X, Symmetric (Φ X)) → Symmetric (pforall2 (Xl:=Xl) Φ).
+ Proof.
+ intros Hsymm. induction Xl as [ | X Xl IH]; intros xl yl.
+ - destruct xl, yl; done.
+ - destruct xl as [x xl], yl as [y yl].
+ intros [? ?]. split; last by eapply IH. by symmetry.
+ Qed.
+
+ Global Instance pforall_equivalence {Xl} (Φ : ∀ X, F X → F X → Prop) :
+ (∀ X, Equivalence (Φ X)) → Equivalence (pforall2 (Xl:=Xl) Φ).
+ Proof. intros; split; apply _. Qed.
+End pforall2_rel.
+
+(** * Ofe for plist *)
+Section plist_ofe.
+ Context {A} {F : A → ofe} {Xl : list A}.
+
+ (* equiv and dist are lifted pointwise *)
+
+ Instance plist_equiv : Equiv (plist F Xl) := pforall2 (λ _, (≡)).
+ Instance plist_dist : Dist (plist F Xl) := λ n, pforall2 (λ _, dist n).
+
+ Definition plist_ofe_mixin : OfeMixin (plist F Xl).
+ Proof.
+ split.
+ - intros x y. rewrite pforall2_forall.
+ apply pforall2_iff. intros. apply equiv_dist.
+ - intros. apply _.
+ - intros n m x y Ha ?.
+ eapply pforall2_impl; last done. intros ??? Hd.
+ eapply dist_lt; first apply Hd. done.
+ Qed.
+
+ Canonical Structure plistO := Ofe (plist F Xl) plist_ofe_mixin.
+End plist_ofe.
+
+(** * big_sep *)
+
+Section big_sep.
+Context {PROP: bi} {A : Type}.
+
+Fixpoint big_sepHL' {F: A → Type} {Xl} (Φ: ∀X, nat → F X → PROP) (i : nat) (xl: hlist F Xl) : PROP :=
+ match xl with
+ | +[] => True
+ | x +:: xl' => Φ _ i x ∗ big_sepHL' Φ (S i) xl'
+ end.
+Definition big_sepHL {F: A → Type} {Xl} (Φ: ∀X, nat → F X → PROP) (xl: hlist F Xl) : PROP := big_sepHL' Φ 0%nat xl.
+
+Fixpoint big_sepHL_1' {F G: A → Type} {Xl} (Φ: ∀X, nat → F X → G X → PROP) (i : nat) (xl: hlist F Xl) (yl: plist G Xl) : PROP :=
+ match xl, yl with
+ | +[], _ => True
+ | x +:: xl', cons_pair y yl' => Φ _ i x y ∗ big_sepHL_1' Φ (S i) xl' yl'
+ end.
+Definition big_sepHL_1 {F G: A → Type} {Xl} (Φ: ∀X, nat → F X → G X → PROP) (xl: hlist F Xl) (yl: plist G Xl) : PROP :=
+ big_sepHL_1' Φ 0%nat xl yl.
+
+(* additionally takes in a normal list *)
+Fixpoint big_sepHL_2' {B} {F G: A → Type} {Xl} (Φ: ∀X, nat → B → F X → G X → PROP) (i : nat) (wl : list B) (xl: hlist F Xl) (yl: plist G Xl) : PROP :=
+ match wl, xl, yl with
+ | [], +[], _ => True
+ | w :: wl', x +:: xl', cons_pair y yl' => Φ _ i w x y ∗ big_sepHL_2' Φ (S i) wl' xl' yl'
+ | _, _, _ => False
+ end.
+Definition big_sepHL_2 {B} {F G: A → Type} {Xl} (Φ: ∀X, nat → B → F X → G X → PROP) (wl : list B) (xl: hlist F Xl) (yl: plist G Xl) : PROP :=
+ big_sepHL_2' Φ 0%nat wl xl yl.
+
+(*
+Fixpoint big_sepHL2_1 {F: A → _} {G H Xl Yl} (Φ: ∀X Y, F X → G Y → H X Y → PROP)
+ (xl: hlist F Xl) (yl: hlist G Yl) (zl: plist2 H Xl Yl) : PROP :=
+ match xl, yl, zl with
+ | +[], +[], _ => True
+ | x +:: xl', y +:: yl', z -:: zl' => Φ _ _ x y z ∗ big_sepHL2_1 Φ xl' yl' zl'
+ | _, _, _ => False
+ end%I.
+ *)
+End big_sep.
+
+Notation "[∗ hlist] x ∈ xl , P" := (big_sepHL (λ _ _ x, P%I) xl)
+ (at level 200, xl at level 10, x at level 1, right associativity,
+ format "[∗ hlist] x ∈ xl , P") : bi_scope.
+Notation "[∗ hlist] i ↦ x ∈ xl , P" := (big_sepHL (λ _ i x, P%I) xl)
+ (at level 200, xl at level 10, x at level 1, right associativity,
+ format "[∗ hlist] i ↦ x ∈ xl , P") : bi_scope.
+
+Notation "[∗ hlist] x ;- y ∈ xl ;- yl , P" := (big_sepHL_1 (λ _ _ x y, P%I) xl yl)
+ (at level 200, xl, yl at level 10, x, y at level 1, right associativity,
+ format "[∗ hlist] x ;- y ∈ xl ;- yl , P") : bi_scope.
+Notation "[∗ hlist] i ↦ x ;- y ∈ xl ;- yl , P" := (big_sepHL_1 (λ _ i x y, P%I) xl yl)
+ (at level 200, xl, yl at level 10, x, y at level 1, right associativity,
+ format "[∗ hlist] i ↦ x ;- y ∈ xl ;- yl , P") : bi_scope.
+
+Notation "[∗ hlist] w ; x ;- y ∈ wl ; xl ;- yl , P" := (big_sepHL_2 (λ _ _ w x y, P%I) wl xl yl)
+ (at level 200, wl, xl, yl at level 10, w, x, y at level 1, right associativity,
+ format "[∗ hlist] w ; x ;- y ∈ wl ; xl ;- yl , P") : bi_scope.
+Notation "[∗ hlist] i ↦ w ; x ;- y ∈ wl ; xl ;- yl , P" := (big_sepHL_2 (λ _ i w x y, P%I) wl xl yl)
+ (at level 200, wl, xl, yl at level 10, w, x, y at level 1, right associativity,
+ format "[∗ hlist] i ↦ w ; x ;- y ∈ wl ; xl ;- yl , P") : bi_scope.
+
+(*Notation "[∗ hlist] x ; y ;- z ∈ xl ; yl ;- zl , P" :=*)
+ (*(big_sepHL2_1 (λ _ _ x y z, P%I) xl yl zl)*)
+ (*(at level 200, xl, yl, zl at level 10, x, y, z at level 1, right associativity,*)
+ (*format "[∗ hlist] x ; y ;- z ∈ xl ; yl ;- zl , P") : bi_scope.*)
+
+Section lemmas.
+Context `{!BiAffine PROP}.
+
+(** big_sepHL *)
+
+Local Lemma big_sepHL'_mono `{F : A → Type} {Xl} (xl : hlist F Xl) (Φ Ψ : ∀ C, nat → F C → PROP) i :
+ (∀ C k (x : F C), Φ C k x -∗ Ψ C k x) →
+ big_sepHL' Φ i xl -∗ big_sepHL' Ψ i xl.
+Proof.
+ iIntros (Hw). induction xl as [ | X Xl x xl IH] in i |-*; simpl; first by auto.
+ iIntros "(Hh & Hr)". iSplitL "Hh"; last by iApply IH.
+ by iApply Hw.
+Qed.
+Lemma big_sepHL_mono `{F : A → Type} {Xl} (xl : hlist F Xl) (Φ Ψ : ∀ C, nat → F C → PROP) :
+ (∀ C k (x : F C), Φ C k x -∗ Ψ C k x) →
+ big_sepHL Φ xl -∗ big_sepHL Ψ xl.
+Proof. apply big_sepHL'_mono. Qed.
+
+Local Lemma big_sepHL'_shift `{F : A → Type} {Xl} (xl : hlist F Xl) (Φ : ∀ C, nat → F C → PROP) i :
+ big_sepHL' Φ (S i) xl ⊣⊢ big_sepHL' (λ C k (x : F C), Φ C (S k) x) i xl.
+Proof.
+ induction xl as [ | X Xl x xl IH] in i |-*; simpl; first done. iSplit.
+ - iIntros "($ & Ha)".
+ iPoseProof (IH (S i) with "Ha") as "Ha".
+ iApply (big_sepHL'_mono with "Ha"). eauto.
+ - iIntros "($ & Ha)". by iApply (IH (S i) with "Ha").
+Qed.
+
+Lemma big_sepHL_app `{F: A → Type} {Xl Yl}
+ (xl: hlist F Xl) (xl': hlist F Yl) (Φ: ∀C, nat → F C → PROP) :
+ big_sepHL Φ (xl h++ xl') ⊣⊢ big_sepHL Φ xl ∗ big_sepHL (λ C i x, Φ C (length Xl + i) x) xl'.
+Proof.
+ unfold big_sepHL. generalize 0 as i => i.
+ induction xl as [ | X Xl x xl IH] in i |-*; simpl.
+ - rewrite left_id. iSplit; iApply big_sepHL'_mono; eauto.
+ - rewrite IH. rewrite [big_sepHL' _ (S i) xl']big_sepHL'_shift assoc.
+ iSplit; iIntros "($ & Ha)".
+ all: iApply (big_sepHL'_mono with "Ha"); iIntros (???) "Ha".
+ all: replace (length Xl + S k) with (S (length Xl + k)) by lia; done.
+Qed.
+
+Global Instance into_sep_big_sepHL_app `{F: A → Type} {Xl Yl}
+ (xl: hlist F Xl) (xl': hlist F Yl) (Φ: ∀C, nat → F C → PROP) :
+ IntoSep (big_sepHL Φ (xl h++ xl')) (big_sepHL Φ xl) (big_sepHL (λ C i x, Φ C (length Xl + i) x) xl').
+Proof. by rewrite /IntoSep big_sepHL_app. Qed.
+Global Instance from_sep_big_sepHL_app `{F: A → Type} {Xl Yl}
+ (xl: hlist F Xl) (xl': hlist F Yl) (Φ: ∀C, F C → PROP) :
+ FromSep (big_sepHL (λ C _, Φ C) (xl h++ xl')) (big_sepHL (λ C _, Φ C) xl) (big_sepHL (λ C _, Φ C) xl').
+Proof. by rewrite /FromSep big_sepHL_app. Qed.
+
+Global Instance frame_big_sepHL_app `{F: A → Type} {Xl Yl}
+ p R Q (xl: hlist F Xl) (xl': hlist F Yl) (Φ: ∀C, F C → PROP) :
+ Frame p R (big_sepHL (λ C _, Φ C) xl ∗ big_sepHL (λ C _, Φ C) xl') Q →
+ Frame p R (big_sepHL (λ C _, Φ C) (xl h++ xl')) Q.
+Proof. by rewrite /Frame big_sepHL_app. Qed.
+
+(** big_sepHL_1 *)
+Local Lemma big_sepHL_1'_mono `{F : A → Type} {G Xl} (xl : hlist F Xl) (yl : plist G Xl) (Φ Ψ : ∀ C, nat → F C → G C → PROP) i :
+ (∀ C k (x : F C) (y : G C), Φ C k x y -∗ Ψ C k x y) →
+ big_sepHL_1' Φ i xl yl -∗ big_sepHL_1' Ψ i xl yl.
+Proof.
+ iIntros (Hw). induction xl as [ | X Xl x xl IH] in i, yl |-*; simpl; first by auto.
+ destruct yl as [y yl]. iIntros "(Hh & Hr)". iSplitL "Hh"; last by iApply IH.
+ by iApply Hw.
+Qed.
+Lemma big_sepHL_1_mono `{F : A → Type} {G Xl} (xl : hlist F Xl) (yl : plist G Xl) (Φ Ψ : ∀ C, nat → F C → G C → PROP) :
+ (∀ C k (x : F C) (y : G C), Φ C k x y -∗ Ψ C k x y) →
+ big_sepHL_1 Φ xl yl -∗ big_sepHL_1 Ψ xl yl.
+Proof. apply big_sepHL_1'_mono. Qed.
+
+Local Lemma big_sepHL_1'_shift `{F : A → Type} {G Xl} (xl : hlist F Xl) (yl : plist G Xl) (Φ : ∀ C, nat → F C → G C → PROP) i :
+ big_sepHL_1' Φ (S i) xl yl ⊣⊢ big_sepHL_1' (λ C k (x : F C) (y : G C), Φ C (S k) x y) i xl yl.
+Proof.
+ induction xl as [ | X Xl x xl IH] in i, yl |-*; simpl; first done.
+ destruct yl as [y yl]. iSplit.
+ - iIntros "($ & Ha)".
+ iPoseProof (IH yl (S i) with "Ha") as "Ha".
+ iApply (big_sepHL_1'_mono with "Ha"). eauto.
+ - iIntros "($ & Ha)". by iApply (IH yl (S i) with "Ha").
+Qed.
+
+Lemma big_sepHL_1_app `{F: A → Type} {G Xl Yl}
+ (xl: hlist F Xl) (xl': hlist F Yl)
+ (yl: plist G Xl) (yl': plist G Yl) (Φ: ∀C, nat → F C → G C → PROP) :
+ big_sepHL_1 Φ (xl h++ xl') (yl -++ yl') ⊣⊢ big_sepHL_1 Φ xl yl ∗ big_sepHL_1 (λ C i x y, Φ C (length Xl + i) x y) xl' yl'.
+Proof.
+ unfold big_sepHL_1. generalize 0 as i => i.
+ induction xl as [ | X Xl x xl IH] in i, yl |-*; simpl; [destruct yl | destruct yl as [y yl]].
+ - rewrite left_id. iSplit; iApply big_sepHL_1'_mono; eauto.
+ - simpl. rewrite IH. rewrite [big_sepHL_1' _ (S i) xl' yl']big_sepHL_1'_shift assoc.
+ iSplit; iIntros "($ & Ha)".
+ all: iApply (big_sepHL_1'_mono with "Ha"); iIntros (????) "Ha".
+ all: replace (length Xl + S k) with (S (length Xl + k)) by lia; done.
+Qed.
+
+Global Instance into_sep_big_sepHL_1_app `{F: A → Type} {G Xl Yl}
+ (xl : hlist F Xl) (xl' : hlist F Yl) (yl : plist G Xl) (yl' : plist G Yl)
+ (Φ: ∀C, nat → F C → G C → PROP) :
+ IntoSep (big_sepHL_1 Φ (xl h++ xl') (yl -++ yl'))
+ (big_sepHL_1 Φ xl yl) (big_sepHL_1 (λ C i x y, Φ C (length Xl + i) x y) xl' yl').
+Proof. by rewrite /IntoSep big_sepHL_1_app. Qed.
+Global Instance from_sep_big_sepHL_1_app `{F: A → Type} {G Xl Yl}
+ (xl: hlist F Xl) (xl': hlist F Yl) (yl: plist G Xl) (yl': plist G Yl)
+ (Φ: ∀C, F C → G C → PROP) :
+ FromSep (big_sepHL_1 (λ C _, Φ C) (xl h++ xl') (yl -++ yl'))
+ (big_sepHL_1 (λ C _, Φ C) xl yl) (big_sepHL_1 (λ C _, Φ C) xl' yl').
+Proof. by rewrite /FromSep big_sepHL_1_app. Qed.
+
+Global Instance frame_big_sepHL_1_app `{F: A → Type} {G Xl Yl}
+ p R Q (xl: hlist F Xl) (xl': hlist F Yl) (yl: plist G Xl) (yl': plist G Yl)
+ (Φ: ∀C, F C → G C → PROP) :
+ Frame p R (big_sepHL_1 (λ C _, Φ C) xl yl ∗ big_sepHL_1 (λ C _, Φ C) xl' yl') Q →
+ Frame p R (big_sepHL_1 (λ C _, Φ C) (xl h++ xl') (yl -++ yl')) Q.
+Proof. by rewrite /Frame big_sepHL_1_app. Qed.
+
+End lemmas.
+
+
+Section hzipl.
+ Set Universe Polymorphism.
+ Fixpoint hzipl {X} {F} (l : list X) (hl : hlist F l) : list (sigT F) :=
+ match hl with
+ | hnil _ => []
+ | @hcons _ _ X Xl x xl => (existT X x) :: hzipl Xl xl
+ end.
+ Lemma hzipl_length {X F} (l : list X) (hl : hlist F l) :
+ length (hzipl l hl) = length l.
+ Proof. induction hl; naive_solver. Qed.
+ Lemma hzipl_lookup {X F} (l : list X) (hl : hlist F l) i x :
+ l !! i = Some x →
+ ∃ y, hzipl l hl !! i = Some (existT x y).
+ Proof.
+ intros Hlook. induction hl as [ | x' l y hl IH ] in i, Hlook |-*.
+ - done.
+ - destruct i as [ | i]; simpl in Hlook.
+ + injection Hlook as [= ->]. eauto.
+ + eapply IH in Hlook as (y' & Hlook). eauto.
+ Qed.
+ Lemma hzipl_lookup_inv {X F} (l : list X) (hl : hlist F l) i x y :
+ hzipl l hl !! i = Some (existT x y) →
+ l !! i = Some x.
+ Proof.
+ induction hl as [ | x' l y' hl IH] in i |-*; simpl.
+ - done.
+ - destruct i as [ | i]; simpl.
+ + by intros [= -> Heq].
+ + apply IH.
+ Qed.
+
+ Lemma hzipl_lookup_hnth {X} {F} (Xl : list X) (hl : hlist F Xl) i (d : X) (hd : F d) :
+ (i < length Xl)%nat →
+ hzipl Xl hl !! i = Some (existT _ (hnth hd hl i)).
+ Proof.
+ induction Xl as [ | x Xl IH] in hl, i |-*; simpl; intros Hi; inv_hlist hl; first lia.
+ intros x1 hl. destruct i as [ | i]; simpl; first done.
+ eapply IH. lia.
+ Qed.
+ Lemma hcmap_lookup_hzipl {X Y} {F} (f : ∀ x, F x → Y) (Xl : list X) (hl : hlist F Xl) k (x : X) (a : F x) :
+ hzipl _ hl !! k = Some (existT x a) →
+ hcmap f hl !! k = Some (f _ a).
+ Proof.
+ induction Xl as [ | x0 Xl IH] in hl, k |-*; simpl; inv_hlist hl; first done.
+ intros x1 hl. destruct k as [ | k]; simpl.
+ - intros [= -> Heq2]. apply existT_inj in Heq2 as ->. done.
+ - eapply IH.
+ Qed.
+
+ Lemma TCHForall_nth_hzipl {X F} (Ψ : ∀ x : X, F x → Prop) (Xl : list X) (hl : hlist F Xl) i x y :
+ TCHForall Ψ hl →
+ hzipl _ hl !! i = Some (existT x y) →
+ Ψ x y.
+ Proof.
+ induction Xl as [ | ? Xl IH] in hl, i |-*; inv_hlist hl; first done.
+ intros fx hl.
+ inversion 1 as [ | ????? ? Ha Hb]. subst.
+ repeat match goal with | H : existT ?A _ = existT ?A _ |- _ => apply existT_inj in H end; subst.
+ destruct i as [ | i]; simpl.
+ - intros [= <- ->%existT_inj]; done.
+ - intros Hlook. eapply IH; last apply Hlook. done.
+ Qed.
+
+ Lemma hzipl_hmap_lookup_inv {X} {F} (Xl : list X) (xl : hlist F Xl) (f : ∀ x : X, F x → F x) i (x : X) (fx : F x) :
+ hzipl Xl (f +<$> xl) !! i = Some (existT x fx) →
+ ∃ y, hzipl Xl xl !! i = Some (existT x y) ∧ fx = f _ y.
+ Proof.
+ induction Xl as [ | a Xl IH] in i, xl |-*; inv_hlist xl; simpl; first done.
+ intros fa xl. destruct i as [ | i]; simpl.
+ - intros [= -> Heq]. apply existT_inj in Heq. subst. eauto.
+ - intros Hlook%IH. done.
+ Qed.
+End hzipl.
+
+Section hzipl2.
+ Set Universe Polymorphism.
+
+ Definition hzipl2 {X} {F G} : ∀ (l : list X), hlist F l → hlist G l → list (sigT (λ x, (F x * G x)%type)).
+ Proof.
+ refine (
+ fix rec (l : list X) :=
+ match l as l return hlist F l → hlist G l → list (sigT (λ x, (F x * G x)%type)) with
+ | [] => λ _ _, []
+ | X :: Xl =>
+ λ (hl1 : hlist F (X :: Xl)) (hl2 : hlist G (X :: Xl)), _
+ end).
+ inversion hl1. inversion hl2. subst.
+ eapply cons.
+ - exists X. split; done.
+ - eapply rec; done.
+ Defined.
+
+ Lemma hzipl2_cons {X} {F G} (x : X) (l : list X) (hl1 : hlist F l) (hl2 : hlist G l) (x1 : F x) (x2 : G x) :
+ hzipl2 (x :: l) (x1 +:: hl1) (x2 +:: hl2) = (existT x (x1, x2)) :: hzipl2 l hl1 hl2.
+ Proof. done. Qed.
+ Lemma hzipl2_nil {X} {F G} :
+ hzipl2 ([] : list X) (+[] : hlist F []) (+[] : hlist G []) = [].
+ Proof. done. Qed.
+
+ Lemma hzipl2_cons_inv {X} {F G} (x : X) (l : list X) (hl1 : hlist F (x :: l)) (hl2 : hlist G (x :: l)) (x1 : F x) (x2 : G x) l' :
+ hzipl2 (x :: l) hl1 hl2 = (existT x (x1, x2)) :: l' →
+ ∃ (hl1' : hlist F l) (hl2' : hlist G l),
+ hl1 = x1 +:: hl1' ∧ hl2 = x2 +:: hl2' ∧ l' = hzipl2 l hl1' hl2'.
+ Proof.
+ inversion hl1 as [ | ?? x1' hl1']; inversion hl2 as [ | ?? x2' hl2']; subst.
+ (*eexists _, _; split_and!.*)
+ Abort.
+
+ Lemma hzipl2_fmap {X} {F F2 G G2} (Xs : list X) (l1 : hlist F Xs) (l2 : hlist G Xs) (f : ∀ x : X, F x → F2 x) (g : ∀ x : X, G x → G2 x) :
+ hzipl2 Xs (f +<$> l1) (g +<$> l2) = (λ '(existT x (a, b)), existT x (f _ a, g _ b)) <$> hzipl2 Xs l1 l2.
+ Proof.
+ induction Xs as [ | x Xs IH] in l1, l2 |-*; inv_hlist l1; inv_hlist l2; first done.
+ intros x1 xl1 x2 xl2. cbn. f_equiv. done.
+ Qed.
+ Lemma hzipl2_swap {X} {F G} (Xs : list X) (l1 : hlist F Xs) (l2 : hlist G Xs) :
+ hzipl2 Xs l1 l2 = (λ '(existT x (a, b)), existT x (b, a)) <$> hzipl2 Xs l2 l1.
+ Proof.
+ induction Xs as [ | x Xs IH] in l1, l2 |-*; inv_hlist l1; inv_hlist l2; first done.
+ intros x1 xl1 x2 xl2. cbn. f_equiv. done.
+ Qed.
+
+ Lemma hzipl_hzipl2_lookup {X} {F G} (Xl : list X) (hl1 : hlist F Xl) (hl2 : hlist G Xl) k x a b :
+ hzipl Xl hl1 !! k = Some (existT x a) →
+ hzipl Xl hl2 !! k = Some (existT x b) →
+ hzipl2 Xl hl1 hl2 !! k = Some (existT x (a, b)).
+ Proof.
+ induction Xl as [ | ? Xl IH] in hl1, hl2, k |-*; inv_hlist hl1; inv_hlist hl2; first done.
+ intros y' hl2 x' hl1. destruct k as [ | k].
+ - simpl. intros [= -> ->%existT_inj] [= ->%existT_inj]. done.
+ - rewrite hzipl2_cons. simpl. apply IH.
+ Qed.
+End hzipl2.
+
+Section pzipl.
+ Set Universe Polymorphism.
+ Fixpoint pzipl {X} {F : X → Type} (l : list X) : plist F l → list (sigT F) :=
+ match l with
+ | [] => λ hl, []
+ | X :: Xl =>
+ λ hl, (existT X (phd hl)) :: pzipl Xl (ptl hl)
+ end.
+ Lemma pzipl_length {X} {F : X → Type} (l : list X) (hl : plist F l) :
+ length (pzipl l hl) = length l.
+ Proof. induction l; naive_solver. Qed.
+ Lemma pzipl_lookup {X} {F : X → Type} (l : list X) (hl : plist F l) i x :
+ l !! i = Some x →
+ ∃ y, pzipl l hl !! i = Some (existT x y).
+ Proof.
+ intros Hlook. induction l as [ | x' l IH ] in i, hl, Hlook |-*.
+ - done.
+ - destruct hl as [y hl].
+ destruct i as [ | i]; simpl in Hlook.
+ + injection Hlook as [= ->]. eauto.
+ + eapply IH in Hlook as (y' & Hlook). simpl; eauto.
+ Qed.
+ Lemma pzipl_lookup_inv {X} {F : X → Type} (l : list X) (hl : plist F l) i x y :
+ pzipl l hl !! i = Some (existT x y) →
+ l !! i = Some x.
+ Proof.
+ induction l as [ | x' l IH] in i, hl |-*; simpl.
+ - done.
+ - destruct hl as [y' hl]. destruct i as [ | i]; simpl.
+ + by intros [= -> Heq].
+ + apply IH.
+ Qed.
+ Lemma pzipl_pzip_lookup_inv {X} {F G : X → Type} (l : list X) (hl : plist F l) (gl : plist G l) i x y z :
+ pzipl l (pzip hl gl) !! i = Some (existT x (y, z)) →
+ pzipl l hl !! i = Some (existT x y) ∧ pzipl l gl !! i = Some (existT x z).
+ Proof.
+ induction l as [ | h l IH] in i, hl, gl |-*; simpl.
+ - done.
+ - destruct hl as [y' hl]. destruct gl as [z' gl].
+ destruct i as [ | i]; simpl.
+ + intros [= -> [= Heq1] [= Heq2]]. rewrite Heq1 Heq2. done.
+ + apply IH.
+ Qed.
+
+ Lemma pzipl_fmap_eqcast {X} {F : X → Type} (f : X → X) (g : sigT (λ x : X, F x) → sigT (λ x : X, F x)) (l : list X) (p : plist F (map f l))
+ (Heq : ∀ l : list X, plist F (map f l) = plist F l) :
+ (∀ x, F (f x) = F x) →
+ (∀ x h Heq, existT (f x) h = g (existT x (rew [id] Heq in h))) →
+ pzipl (map f l) p = fmap g (pzipl l (rew [id] (Heq l) in p)).
+ Proof.
+ intros HFf Heq0.
+ induction l as [ | x l IH]; simpl; first done.
+ destruct p as [ph p].
+ f_equiv; first last.
+ - simpl. rewrite IH.
+ f_equiv. rewrite ptl_rew_commute; done.
+ - simpl.
+ rewrite phd_rew_commute; last done.
+ simpl. apply Heq0.
+ Qed.
+
+ Lemma pzipl_lookup_pnth {X} {F} (Xl : list X) (pl : plist F Xl) i (d : X) (hd : F d) :
+ (i < length Xl)%nat →
+ pzipl Xl pl !! i = Some (existT _ (pnth hd pl i)).
+ Proof.
+ induction Xl as [ | x Xl IH] in pl, i |-*; simpl; intros Hi; first lia.
+ destruct pl as [x1 pl]. destruct i as [ | i]; simpl; first done.
+ eapply IH. lia.
+ Qed.
+
+ Lemma pcmap_lookup_pzipl {X Y} {F} (f : ∀ x, F x → Y) (Xl : list X) (pl : plist F Xl) k (x : X) (a : F x) :
+ pzipl _ pl !! k = Some (existT x a) →
+ pcmap f pl !! k = Some (f _ a).
+ Proof.
+ induction Xl as [ | x0 Xl IH] in pl, k |-*; simpl; first done.
+ destruct pl as [x1 pl]. destruct k as [ | k]; simpl.
+ - intros [= -> Heq2]. apply existT_inj in Heq2 as ->. done.
+ - eapply IH.
+ Qed.
+End pzipl.
+
+Section hlist_replace.
+ Set Universe Polymorphism.
+ Definition hlist_insert {X} {F} : ∀ (Xl : list X) (l : hlist F Xl) (i : nat) (x0 : X) (h : F x0), hlist F (<[i := x0]> Xl).
+ Proof.
+ refine (fix rec Xl l i x0 h :=
+ match l with
+ | +[] => +[]
+ | @hcons _ _ x1 Xl h1 l =>
+ match i with
+ | 0%nat => hcons F h l
+ | S i => hcons F h1 (rec Xl l i x0 h)
+ end
+ end).
+ Defined.
+
+ Lemma list_insert_lnth {X} (xs : list X) (d : X) i :
+ <[i := lnth d xs i]> xs = xs.
+ Proof.
+ induction xs as [ | x xs IH] in i |-*; first done.
+ destruct i as [ | i]; simpl; first done.
+ by rewrite IH.
+ (* defined transparently so that [hlist_insert_id] and [plist_insert_id] compute *)
+ Defined.
+
+ Definition hlist_insert_id {X} {F} (d : X) (Xl : list X) (l : hlist F Xl) (i : nat) (h : F (lnth d Xl i)) : hlist F Xl.
+ Proof.
+ exact (let r := hlist_insert Xl l i _ h in
+ rew (list_insert_lnth Xl d i) in r).
+ Defined.
+
+ (* TODO remove? *)
+ Definition hlist_insert_id' {X} {F} (Xl : list X) (l : hlist F Xl) (i : nat) (x0 : X) (h : F x0) (Heq: Xl !! i = Some x0) : hlist F Xl.
+ Proof.
+ exact (let r := hlist_insert Xl l i x0 h in
+ rew (list_insert_id Xl i x0 Heq) in r).
+ Defined.
+
+ Lemma hzipl_hlist_insert {X} {F} (Xl : list X) (l : hlist F Xl) (i : nat) (x0 : X) (h : F x0) :
+ hzipl _ (hlist_insert Xl l i x0 h) = <[i := existT x0 h]> (hzipl _ l).
+ Proof.
+ induction Xl as [ | x1 Xl IH] in i, l |-*; simpl; inv_hlist l; first done.
+ intros x l. destruct i as [ | i]; simpl; first done.
+ f_equiv. by eapply IH.
+ Qed.
+ Lemma hzipl_hlist_insert_id {X} {F} (Xl : list X) (l : hlist F Xl) (i : nat) (d : X) h :
+ hzipl _ (hlist_insert_id d Xl l i h) = <[i := existT _ h]> (hzipl _ l).
+ Proof.
+ rewrite /hlist_insert_id. rewrite -hzipl_hlist_insert.
+ generalize (list_insert_lnth Xl d i). intros <-. done.
+ Qed.
+
+ (** Interaction of mapping and list insertion *)
+ Lemma hcmap_hlist_insert {X Y} {F} (f : ∀ x, F x → Y) (Xl : list X) (hl : hlist F Xl) i x0 (a : F x0) :
+ hcmap f (hlist_insert Xl hl i x0 a) = <[i := f x0 a]> (hcmap f hl).
+ Proof.
+ induction Xl as [ | x Xl IH] in hl, i |-*; simpl; inv_hlist hl; first done.
+ intros x1 hl. destruct i as [ | i]; simpl; first done.
+ f_equiv. eapply IH.
+ Qed.
+ Lemma hcmap_hlist_insert_id {X Y} {F} (f : ∀ x, F x → Y) (Xl : list X) (hl : hlist F Xl) i d (a : F (lnth d Xl i)) :
+ hcmap f (hlist_insert_id d Xl hl i a) = <[i := f _ a]> (hcmap f hl).
+ Proof.
+ rewrite /hlist_insert_id. rewrite -hcmap_hlist_insert.
+ generalize (list_insert_lnth Xl d i). intros <-. done.
+ Qed.
+ Lemma hmap_hlist_insert {X} {F G} (f : ∀ x, F x → G x) (Xl : list X) (hl : hlist F Xl) i x0 (a : F x0) :
+ hmap f (hlist_insert Xl hl i x0 a) = hlist_insert Xl (hmap f hl) i x0 (f x0 a).
+ Proof.
+ induction Xl as [ | x Xl IH] in hl, i |-*; simpl; inv_hlist hl; first done.
+ intros x1 hl. destruct i as [ | i]; simpl; first done.
+ f_equiv. eapply IH.
+ Qed.
+ Lemma hmap_hlist_insert_id {X} {F G} (f : ∀ x, F x → G x) (Xl : list X) (hl : hlist F Xl) i d (a : F (lnth d Xl i)) :
+ hmap f (hlist_insert_id d Xl hl i a) = hlist_insert_id d Xl (hmap f hl) i (f _ a).
+ Proof.
+ rewrite /hlist_insert_id. rewrite -hmap_hlist_insert.
+ generalize (list_insert_lnth Xl d i). intros <-. done.
+ Qed.
+End hlist_replace.
+
+Section plist_replace.
+ Set Universe Polymorphism.
+
+ Definition plist_insert {X} {F} : ∀ (Xl : list X) (l : plist F Xl) (i : nat) (x0 : X) (h : F x0), plist F (<[i := x0]> Xl).
+ Proof.
+ refine (fix rec Xl :=
+ match Xl with
+ | [] => λ l i x0 h, -[]
+ | x1 :: Xl => λ l i x0 h,
+ let '(cons_pair h1 l) := l in
+ match i with
+ | 0%nat => pcons h l
+ | S i => pcons h1 (rec Xl l i x0 h)
+ end
+ end).
+ Defined.
+
+ Definition plist_insert_id {X} {F} (d : X) (Xl : list X) (l : plist F Xl) (i : nat) (h : F (lnth d Xl i)) : plist F Xl.
+ Proof.
+ exact (let r := plist_insert Xl l i _ h in
+ rew (list_insert_lnth Xl d i) in r).
+ Defined.
+
+ (* TODO remove? *)
+ Definition plist_insert_id' {X} {F} (Xl : list X) (l : plist F Xl) (i : nat) (x0 : X) (h : F x0) (Heq : Xl !! i = Some x0) : plist F Xl.
+ Proof.
+ exact (let r := plist_insert Xl l i x0 h in
+ rew (list_insert_id Xl i x0 Heq) in r).
+ Defined.
+
+ Lemma pzipl_plist_insert {X} {F} (Xl : list X) (l : plist F Xl) (i : nat) (x0 : X) (h : F x0) :
+ pzipl _ (plist_insert Xl l i x0 h) = <[i := existT x0 h]> (pzipl _ l).
+ Proof.
+ induction Xl as [ | x1 Xl IH] in i, l |-*; simpl; first done.
+ destruct l as [x l]. destruct i as [ | i]; simpl; first done.
+ f_equiv. by eapply IH.
+ Qed.
+ Lemma pzipl_plist_insert_id {X} {F} (Xl : list X) (l : plist F Xl) (i : nat) (d : X) h :
+ pzipl _ (plist_insert_id d Xl l i h) = <[i := existT _ h]> (pzipl _ l).
+ Proof.
+ rewrite /plist_insert_id. rewrite -pzipl_plist_insert.
+ generalize (list_insert_lnth Xl d i). intros <-. done.
+ Qed.
+
+ Lemma pcmap_plist_insert {X Y} {F} (f : ∀ x, F x → Y) (Xl : list X) (pl : plist F Xl) i x0 (a : F x0) :
+ pcmap f (plist_insert Xl pl i x0 a) = <[i := f x0 a]> (pcmap f pl).
+ Proof.
+ induction Xl as [ | x Xl IH] in pl, i |-*; simpl; first done.
+ destruct pl as [x1 pl]. destruct i as [ | i]; simpl; first done.
+ f_equiv. eapply IH.
+ Qed.
+ Lemma pcmap_plist_insert_id {X Y} {F} (f : ∀ x, F x → Y) (Xl : list X) (pl : plist F Xl) i d (a : F (lnth d Xl i)) :
+ pcmap f (plist_insert_id d Xl pl i a) = <[i := f _ a]> (pcmap f pl).
+ Proof.
+ rewrite /plist_insert_id. rewrite -pcmap_plist_insert.
+ generalize (list_insert_lnth Xl d i). intros <-. done.
+ Qed.
+ Lemma pmap_plist_insert {X} {F G} (f : ∀ x, F x → G x) (Xl : list X) (pl : plist F Xl) i x0 (a : F x0) :
+ pmap f (plist_insert Xl pl i x0 a) = plist_insert Xl (pmap f pl) i x0 (f x0 a).
+ Proof.
+ induction Xl as [ | x Xl IH] in pl, i |-*; simpl; first done.
+ destruct pl as [x1 pl]. destruct i as [ | i]; simpl; first done.
+ rewrite IH. done.
+ Qed.
+ Lemma pmap_plist_insert_id {X} {F G} (f : ∀ x, F x → G x) (Xl : list X) (pl : plist F Xl) i d (a : F (lnth d Xl i)) :
+ pmap f (plist_insert_id d Xl pl i a) = plist_insert_id d Xl (pmap f pl) i (f _ a).
+ Proof.
+ rewrite /plist_insert_id. rewrite -pmap_plist_insert.
+ generalize (list_insert_lnth Xl d i). intros <-. done.
+ Qed.
+End plist_replace.
+
+Section hpzip.
+ Set Universe Polymorphism.
+ Fixpoint hpzipl {X} {F : X → Type} {G : X → Type} (l : list X) (hl : hlist F l) : plist G l → list (sigT (λ X, F X * G X))%type :=
+ match hl with
+ | hnil _ => λ _, []
+ | @hcons _ _ X l x hl => λ pl,
+ (existT X (x, phd pl)) :: hpzipl l hl (ptl pl)
+ end.
+
+ Fixpoint hpziphl {X} {F G : X → Type} (l : list X) (hl : hlist F l) : plist G l → hlist (λ x, F x * G x)%type l :=
+ match hl with
+ | +[] => λ pl, +[]
+ | a +:: hl => λ pl,
+ (a, phd pl) +:: hpziphl _ hl (ptl pl)
+ end.
+
+ Context {X} {F : X → Type} {G : X → Type}.
+ Lemma hpzipl_length (l : list X) (hl : hlist F l) (pl : plist G l) :
+ length (hpzipl l hl pl) = length l.
+ Proof. induction hl; naive_solver. Qed.
+ Lemma hpzipl_lookup (l : list X) (hl : hlist F l) (pl : plist G l) i x :
+ l !! i = Some x →
+ ∃ y z, hpzipl l hl pl !! i = Some (existT x (y, z)).
+ Proof.
+ intros Hlook. induction hl as [ | X' l y hl IH ] in i, pl, Hlook |-*.
+ - done.
+ - destruct pl as [z pl].
+ destruct i as [ | i]; simpl in Hlook.
+ + injection Hlook as [= ->]. eauto.
+ + eapply IH in Hlook as (y' & Hlook). simpl; eauto.
+ Qed.
+ Lemma hpzipl_lookup_inv (l : list X) (hl : hlist F l) (pl : plist G l) i x y z :
+ hpzipl l hl pl !! i = Some (existT x (y, z)) →
+ l !! i = Some x.
+ Proof.
+ induction hl as [ | X' l y' hl IH] in i, pl |-*; simpl.
+ - done.
+ - destruct pl as [z' pl]. destruct i as [ | i]; simpl.
+ + by intros [= -> Heq].
+ + apply IH.
+ Qed.
+ Lemma hpzipl_lookup_inv_hzipl_pzipl (l : list X) (hl : hlist F l) (gl : plist G l) i x y z :
+ hpzipl l hl gl !! i = Some (existT x (y, z)) →
+ hzipl l hl !! i = Some (existT x y) ∧ pzipl l gl !! i = Some (existT x z).
+ Proof.
+ induction hl as [ | X' l y' hl IH] in i, gl |-*; simpl.
+ - done.
+ - destruct gl as [z' gl]. destruct i as [ | i]; simpl.
+ + intros [= -> [= Heq1] [= Heq2]]. rewrite Heq1 Heq2; done.
+ + apply IH.
+ Qed.
+
+ Lemma hpzipl_hzipl2_lookup (Xs : list X) (l1 l2 : hlist F Xs) (pl1 pl2 : plist G Xs) (x : X) y1 y2 i :
+ hpzipl Xs l1 pl1 !! i = Some (existT x y1) →
+ hpzipl Xs l2 pl2 !! i = Some (existT x y2) →
+ hzipl2 Xs l1 l2 !! i = Some (existT x (y1.1, y2.1)).
+ Proof.
+ induction Xs as [ | X0 Xs IH] in i, l1, l2, pl1, pl2 |-*; inv_hlist l1; inv_hlist l2; simpl; first done.
+ intros x1 xl1 x2 xl2. destruct i as [ | i ]; simpl.
+ - intros [= [= ->] Ha] [= Hb]. apply existT_inj in Ha as <-. apply existT_inj in Hb as <-. done.
+ - apply IH.
+ Qed.
+ Lemma hpzipl_hpzipl_lookup_1_eq (Xs : list X) (l : hlist F Xs) (pl1 pl2 : plist G Xs) (x : X) a1 a2 b1 b2 i:
+ hpzipl Xs l pl1 !! i = Some (existT x (a1, b1)) →
+ hpzipl Xs l pl2 !! i = Some (existT x (a2, b2)) →
+ a1 = a2.
+ Proof.
+ induction Xs as [ | X0 Xs IH] in i, l, pl1, pl2 |-*; inv_hlist l; simpl; first done.
+ intros x1 xl1. destruct i as [ | i ]; simpl.
+ - intros [= [= ->] Ha Hb] [= Hc Hd]. apply existT_inj in Ha as <-. apply existT_inj in Hb as <-.
+ apply existT_inj in Hc as <-. apply existT_inj in Hd as <-. done.
+ - apply IH.
+ Qed.
+ Lemma hpzipl_hpzipl_lookup_2_eq (Xs : list X) (l1 l2 : hlist F Xs) (pl : plist G Xs) (x : X) a1 a2 b1 b2 i:
+ hpzipl Xs l1 pl !! i = Some (existT x (a1, b1)) →
+ hpzipl Xs l2 pl !! i = Some (existT x (a2, b2)) →
+ b1 = b2.
+ Proof.
+ induction Xs as [ | X0 Xs IH] in i, l1, l2, pl |-*; inv_hlist l1; inv_hlist l2; simpl; first done.
+ intros x1 xl1 x2 xl2. destruct i as [ | i ]; simpl.
+ - intros [= [= ->] Ha Hb] [= Hc Hd]. apply existT_inj in Ha as <-. apply existT_inj in Hb as <-.
+ apply existT_inj in Hc as <-. apply existT_inj in Hd as <-. done.
+ - apply IH.
+ Qed.
+
+ Lemma hnth_pnth_hpzipl_lookup (Xl : list X) (d : X) (fd : F d) (gd : G d) (hl : hlist F Xl) (pl : plist G Xl) (i : nat) a b :
+ i < length Xl →
+ hnth fd hl i = a →
+ pnth gd pl i = b →
+ hpzipl Xl hl pl !! i = Some (existT (lnth d Xl i) (a, b)).
+ Proof.
+ induction Xl as [ | x0 Xl IH] in i, hl, pl, a, b |-*; inv_hlist hl; simpl; first lia.
+ intros a0 hl Hi.
+ destruct pl as [b0 pl].
+ destruct i as [ | i].
+ - intros -> ->. done.
+ - intros Ha Hb. simpl. eapply IH; [lia | done..].
+ Qed.
+
+ Lemma insert_hpzipl (Xl : list X) (hl : hlist F Xl) (pl : plist G Xl) (x : X) (a : F x) (b : G x) i :
+ <[i := existT x (a, b)]> (hpzipl Xl hl pl) =
+ hpzipl (<[i := x]> Xl) (hlist_insert Xl hl i x a) (plist_insert Xl pl i x b).
+ Proof.
+ induction Xl as [ | x0 Xl IH] in i, hl, pl |-*; inv_hlist hl; simpl; first done.
+ intros a0 hl. destruct pl as [b0 pl].
+ destruct i as [ | i]; simpl.
+ - done.
+ - f_equiv. eapply IH.
+ Qed.
+
+ Lemma hpzipl_hmap {H} (Xl : list X) (hl : hlist F Xl) (pl : plist G Xl) (f : ∀ x : X, F x → H x) :
+ hpzipl Xl (hmap f hl) pl = (λ '(existT x (a, b)), existT x (f _ a, b)) <$> hpzipl Xl hl pl.
+ Proof.
+ induction Xl as [ | x Xl IH]; simpl; inv_hlist hl; first done.
+ intros a hl. destruct pl as [b pl]. simpl. f_equiv. eapply IH.
+ Qed.
+
+ Lemma big_sepL2_hzipl_hzipl_sepL_hzipl2 {PROP : bi} (Xs : list X) (l1 : hlist F Xs) (l2 : hlist G Xs) (Φ : nat → sigT F → sigT G → PROP) (Ψ : nat → sigT (λ x, F x * G x)%type → PROP) m :
+ (∀ i x a b, Φ i (existT x a) (existT x b) ⊣⊢ Ψ i (existT x (a, b))) →
+ ([∗ list] i ↦ a; b ∈ hzipl Xs l1; hzipl Xs l2, Φ (m + i)%nat a b) ⊣⊢
+ [∗ list] i ↦ p ∈ hzipl2 Xs l1 l2, Ψ (m + i)%nat p.
+ Proof.
+ intros Ha.
+ induction Xs as [ | X0 Xs IH] in m, l1, l2 |-*; inv_hlist l1; inv_hlist l2; simpl; first done.
+ intros x1 xl1 x2 xl2. setoid_rewrite Nat.add_succ_r. rewrite (IH _ _ (S m)). rewrite Ha. done.
+ Qed.
+
+ Lemma hpzipl_hpziphl_hzipl2_lookup (Xs : list X) (l1 l2 : hlist F Xs) (pl1 pl2 : plist G Xs) (x : X) y1 y2 i :
+ hpzipl Xs l1 pl1 !! i = Some (existT x y1) →
+ hpzipl Xs l2 pl2 !! i = Some (existT x y2) →
+ hzipl2 Xs (hpziphl _ l1 pl1) (hpziphl _ l2 pl2) !! i = Some (existT x (y1, y2)).
+ Proof.
+ induction Xs as [ | X0 Xs IH] in i, l1, l2, pl1, pl2 |-*; inv_hlist l1; inv_hlist l2; simpl; first done.
+ intros x1 xl1 x2 xl2. destruct i as [ | i ]; simpl.
+ - intros [= [= ->] Ha] [= Hb]. apply existT_inj in Ha as <-. apply existT_inj in Hb as <-. done.
+ - apply IH.
+ Qed.
+
+ Lemma hpziphl_fmap_l {H : X → Type} (Xs : list X) (hl : hlist F Xs) (pl : plist G Xs) (f : ∀ x : X, F x → H x) :
+ hpziphl _ (f +<$> hl) pl = (λ x p, (f _ p.1, p.2)) +<$> (hpziphl _ hl pl).
+ Proof.
+ induction Xs as [ | X0 Xs IH] in hl, pl |-*; inv_hlist hl.
+ - destruct pl. done.
+ - intros x hl. destruct pl as [p pl]. simpl. rewrite IH. done.
+ Qed.
+
+End hpzip.
+
+Global Arguments hnth : simpl nomatch.
+Global Arguments pnth : simpl nomatch.
+Global Arguments lnth : simpl nomatch.
+Global Arguments hlist_insert : simpl nomatch.
+Global Arguments plist_insert : simpl nomatch.
diff --git a/theories/rust_typing/int.v b/theories/rust_typing/int.v
new file mode 100644
index 0000000000000000000000000000000000000000..388903200407541970c7813eff7e0f9d8c08fc90
--- /dev/null
+++ b/theories/rust_typing/int.v
@@ -0,0 +1,103 @@
+From refinedrust Require Export type.
+Set Default Proof Using "Type".
+
+Open Scope Z_scope.
+
+Section int.
+ Context `{!typeGS Σ}.
+
+ (* Separate definition such that we can make it typeclasses opaque later. *)
+ Program Definition int (it : int_type) : type Z := {|
+ st_own tid z v := ⌜val_to_Z v it = Some z⌠∗ ⌜ly_size it ≤ max_int isize_tâŒ;
+ st_has_op_type ot mt := is_int_ot ot it;
+ st_syn_type := IntSynType it;
+ |}%I.
+ Next Obligation.
+ iIntros (it π z v [Hv ?]). iPureIntro.
+ exists (it_layout it). split; last by eapply val_to_Z_length.
+ by apply syn_type_has_layout_int.
+ Qed.
+ Next Obligation.
+ intros it ot mt Hot. simpl. rewrite (is_int_ot_layout _ _ Hot).
+ destruct ot; try done. all: destruct Hot as [ ]; by apply syn_type_has_layout_int.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (it ot mt st π r v Hot).
+ destruct mt.
+ - eauto.
+ - iPureIntro. intros [Hv ?]. destruct ot; simpl in *; try done. subst.
+ unfold mem_cast. erewrite val_to_bytes_id; last done. done.
+ - iApply (mem_cast_compat_int (λ v, _)); first done.
+ iIntros "[% %]". eauto.
+ Qed.
+
+ Lemma ty_own_int_in_range l Ï€ n it : l â—áµ¥{Ï€} n @ int it -∗ ⌜n ∈ itâŒ.
+ Proof. iIntros "[%Hl _]". iPureIntro. by eapply val_to_Z_in_range. Qed.
+
+ (* We only get this under a later for sharing:
+ the refinement predicate needs to sit under a later for the whole sharing business.
+ TODO is that really the case?
+ *)
+ Lemma ty_shr_int_in_range l Ï€ κ n it : l â—â‚—{Ï€, κ} n @ int it -∗ â–· ⌜n ∈ itâŒ.
+ Proof.
+ iIntros "(%v & (%ly & Hv & (Ha & _) & Halg & Hl))" => /=. iNext. iDestruct "Ha" as "%Hn".
+ iPureIntro. by eapply val_to_Z_in_range.
+ Qed.
+
+ Global Instance int_copyable it : Copyable (int it).
+ Proof. apply _. Qed.
+
+ Global Instance int_timeless l z it π:
+ Timeless (l â—áµ¥{Ï€} z @ int it)%I.
+ Proof. apply _. Qed.
+
+End int.
+
+Global Hint Unfold int : ty_unfold.
+Global Typeclasses Opaque int.
+Notation "int< it >" := (int it) (only printing, format "'int<' it '>'") : printing_sugar.
+
+(** This represents the Rust bool type, which just has valid bit patterns 0x01 and 0x00 *)
+Section boolean.
+ Context `{!typeGS Σ}.
+
+ (* Separate definition such that we can make it typeclasses opaque later. *)
+ Program Definition bool_t : type bool := {|
+ st_own tid b v := ⌜val_to_bool v = Some bâŒ;
+ st_syn_type := BoolSynType;
+ st_has_op_type ot mt := is_bool_ot ot;
+ |}%I.
+ Next Obligation.
+ iIntros (Ï€ z v Hv). iExists u8. iPureIntro. split; first done.
+ unfold has_layout_val. erewrite val_to_bool_length; done.
+ Qed.
+ Next Obligation.
+ intros ot mt Hot. simpl in *. rewrite (is_bool_ot_layout _ Hot). done.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (ot mt st π r v Hot).
+ destruct mt.
+ - eauto.
+ - destruct ot; simpl in *; try done.
+ { iPureIntro. intros Hv. unfold mem_cast.
+ rewrite Hv. by erewrite val_to_bytes_id_bool. }
+ subst; eauto.
+ - iApply (mem_cast_compat_bool (λ v, _)); first done. eauto.
+ Qed.
+
+ Lemma bool_own_val_eq v π b :
+ (v â—áµ¥{Ï€} b @ bool_t)%I ≡ ⌜val_to_bool v = Some bâŒ%I.
+ Proof. done. Qed.
+
+ Global Instance bool_timeless π l b:
+ Timeless (l â—áµ¥{Ï€} b @ bool_t)%I.
+ Proof. apply _. Qed.
+
+ Global Instance bool_copy : Copyable bool_t.
+ Proof. apply _. Qed.
+End boolean.
+
+Global Hint Unfold bool_t : ty_unfold.
+Global Typeclasses Opaque bool_t.
+Notation "'bool'" := (bool_t) (only printing, format "'bool'") : printing_sugar.
+
diff --git a/theories/rust_typing/int_rules.v b/theories/rust_typing/int_rules.v
new file mode 100644
index 0000000000000000000000000000000000000000..b55d742d5671663851d444ba721fea900e618720
--- /dev/null
+++ b/theories/rust_typing/int_rules.v
@@ -0,0 +1,383 @@
+From refinedrust Require Export type int.
+From refinedrust Require Import programs.
+Set Default Proof Using "Type".
+
+Open Scope Z_scope.
+
+Section typing.
+ Context `{typeGS Σ}.
+
+ Global Program Instance learn_from_hyp_val_int_unsigned it z `{Hu : TCDone (it.(it_signed) = false)} :
+ LearnFromHypVal (int it) z :=
+ {| learn_from_hyp_val_Q := 0 ≤ z ≤ max_int it |}.
+ Next Obligation.
+ iIntros (? z Hu ????) "Hv".
+ rewrite /ty_own_val/=.
+ iDestruct "Hv" as "(%Hit & %)".
+ specialize (val_to_Z_in_range _ _ _ Hit) as [Hran ?].
+ iModIntro. iPureIntro. split_and!; [done.. | | done].
+ specialize (min_int_unsigned_0 it). lia.
+ Qed.
+ Global Program Instance learn_from_hyp_val_int_signed it z `{Hs : TCDone (it.(it_signed) = true)} :
+ LearnFromHypVal (int it) z :=
+ {| learn_from_hyp_val_Q := min_int it ≤ z ≤ max_int it |}.
+ Next Obligation.
+ iIntros (? z Hs ????) "Hv".
+ rewrite /ty_own_val/=.
+ iDestruct "Hv" as "(%Hit & %)".
+ specialize (val_to_Z_in_range _ _ _ Hit) as [Hran ?].
+ iModIntro. iPureIntro. split_and!; done.
+ Qed.
+
+ Lemma type_val_int z (it : IntType) π (T : ∀ rt, type rt → rt → iProp Σ):
+ ⌜z ∈ (it : int_type)⌠∗ T _ (int it) z ⊢ typed_value (I2v z it) π T.
+ Proof.
+ iIntros "[%Hn HT] #CTX".
+ move: Hn => /(val_of_Z_is_Some None) [v Hv].
+ move: (Hv) => /val_to_of_Z Hn.
+ iExists Z, (int it), z. iFrame "HT". rewrite /ty_own_val/=. iPureIntro.
+ split; first by rewrite /I2v /i2v Hv /=.
+ apply IntType_to_it_size_bounded.
+ Qed.
+ Global Instance type_val_int_inst n (it : IntType) π : TypedValue (I2v n it) π :=
+ λ T, i2p (type_val_int n it π T).
+
+ Lemma type_relop_int_int E L it v1 (n1 : Z) v2 (n2 : Z) (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) b op π :
+ match op with
+ | EqOp rit => Some (bool_decide (n1 = n2)%Z, rit)
+ | NeOp rit => Some (bool_decide (n1 ≠n2)%Z, rit)
+ | LtOp rit => Some (bool_decide (n1 < n2)%Z, rit)
+ | GtOp rit => Some (bool_decide (n1 > n2)%Z, rit)
+ | LeOp rit => Some (bool_decide (n1 <= n2)%Z, rit)
+ | GeOp rit => Some (bool_decide (n1 >= n2)%Z, rit)
+ | _ => None
+ end = Some (b, u8) →
+ (⌜n1 ∈ it⌠-∗ ⌜n2 ∈ it⌠-∗ T L (val_of_bool b) bool bool_t b) ⊢
+ typed_bin_op Ï€ E L v1 (v1 â—áµ¥{Ï€} n1 @ int it) v2 (v2 â—áµ¥{Ï€} n2 @ int it) op (IntOp it) (IntOp it) T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "%Hop HT [%Hv1 %] [%Hv2 _]" (Φ) "#CTX #HE HL HΦ".
+ iDestruct ("HT" with "[] []" ) as "HT".
+ 1-2: iPureIntro; by apply: val_to_Z_in_range.
+ iApply (wp_binop_det_pure (val_of_bool b)).
+ { split.
+ - destruct op => //; inversion 1; simplify_eq; symmetry;
+ by apply val_of_bool_iff_val_of_Z.
+ - move => ->. econstructor; [done.. | ].
+ by apply val_of_bool_iff_val_of_Z. }
+ iIntros "!> Hcred". iApply ("HΦ" with "HL") => //.
+ rewrite /ty_own_val/=. by destruct b.
+ Qed.
+
+ Global Program Instance type_eq_int_int_inst E L it v1 n1 v2 n2 π :
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 (EqOp u8) (IntOp it) (IntOp it) := λ T, i2p (type_relop_int_int E L it v1 n1 v2 n2 T (bool_decide (n1 = n2)) _ π _).
+ Solve Obligations with done.
+ Global Program Instance type_ne_int_int_inst E L it v1 n1 v2 n2 π :
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 (NeOp u8) (IntOp it) (IntOp it) := λ T, i2p (type_relop_int_int E L it v1 n1 v2 n2 T (bool_decide (n1 ≠n2)) _ π _).
+ Solve Obligations with done.
+ Global Program Instance type_lt_int_int_inst E L it v1 n1 v2 n2 π :
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 (LtOp u8) (IntOp it) (IntOp it) := λ T, i2p (type_relop_int_int E L it v1 n1 v2 n2 T (bool_decide (n1 < n2)%Z) _ π _).
+ Solve Obligations with done.
+ Global Program Instance type_gt_int_int_inst E L it v1 n1 v2 n2 π :
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 (GtOp u8) (IntOp it) (IntOp it) := λ T, i2p (type_relop_int_int E L it v1 n1 v2 n2 T (bool_decide (n1 > n2)%Z) _ π _).
+ Solve Obligations with done.
+ Global Program Instance type_le_int_int_inst E L it v1 n1 v2 n2 π :
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 (LeOp u8) (IntOp it) (IntOp it) := λ T, i2p (type_relop_int_int E L it v1 n1 v2 n2 T (bool_decide (n1 <= n2)%Z) _ π _).
+ Solve Obligations with done.
+ Global Program Instance type_ge_int_int_inst E L it v1 n1 v2 n2 π :
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 (GeOp u8) (IntOp it) (IntOp it) := λ T, i2p (type_relop_int_int E L it v1 n1 v2 n2 T (bool_decide (n1 >= n2)%Z) _ π _).
+ Solve Obligations with done.
+
+ Definition arith_op_result (it : int_type) n1 n2 op : option Z :=
+ match op with
+ | AddOp => Some (n1 + n2)
+ | SubOp => Some (n1 - n2)
+ | MulOp => Some (n1 * n2)
+ | AndOp => Some (Z.land n1 n2)
+ | OrOp => Some (Z.lor n1 n2)
+ | XorOp => Some (Z.lxor n1 n2)
+ | ShlOp => Some (n1 ≪ n2)
+ | ShrOp => Some (n1 ≫ n2)
+ | DivOp => Some (n1 `quot` n2)
+ | ModOp => Some (n1 `rem` n2)
+ | CheckedAddOp => Some (n1 + n2)
+ | CheckedSubOp => Some (n1 - n2)
+ | CheckedMulOp => Some (n1 * n2)
+ | _ => None (* Relational operators. *)
+ end.
+
+ Definition arith_op_sidecond (it : int_type) (n1 n2 n : Z) op : Prop :=
+ match op with
+ (* these sideconditions are stronger than necessary and do not support the wrapping for unsigned unchecked ops that is allowed by the opsem *)
+ | AddOp => n ∈ it
+ | SubOp => n ∈ it
+ | MulOp => n ∈ it
+ | AndOp => True
+ | OrOp => True
+ | XorOp => True
+ (* TODO: check accuracy of shifting semantics *)
+ | ShlOp => 0 ≤ n2 < bits_per_int it ∧ 0 ≤ n1 ∧ n ≤ max_int it
+ | ShrOp => 0 ≤ n2 < bits_per_int it ∧ 0 ≤ n1
+ | DivOp => n2 ≠0 ∧ n ∈ it
+ | ModOp => n2 ≠0 ∧ n ∈ it
+ | CheckedAddOp => n ∈ it
+ | CheckedSubOp => n ∈ it
+ | CheckedMulOp => n ∈ it
+ | _ => True (* Relational operators. *)
+ end.
+
+ Lemma type_arithop_int_int E L π it v1 n1 v2 n2 (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) n op:
+ int_arithop_result it n1 n2 op = Some n →
+ (⌜n1 ∈ it⌠-∗ ⌜n2 ∈ it⌠-∗ ⌜arith_op_sidecond it n1 n2 n op⌠∗ T L (i2v n it) Z (int it) n) ⊢
+ typed_bin_op Ï€ E L v1 (v1 â—áµ¥{Ï€} n1 @ int it) v2 (v2 â—áµ¥{Ï€} n2 @ int it) op (IntOp it) (IntOp it) T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "%Hop HT [%Hv1 %] [%Hv2 _] %Φ #CTX #HE HL HΦ".
+ iDestruct ("HT" with "[] []" ) as (Hsc) "HT".
+ 1-2: iPureIntro; by apply: val_to_Z_in_range.
+ iApply wp_int_arithop; [done..|].
+ iIntros (v Hv) "!> Hcred". rewrite /i2v Hv/=. iApply ("HΦ" with "HL [] HT").
+ rewrite /ty_own_val/=.
+ iPureIntro. split; first by apply: val_to_of_Z. done.
+ Qed.
+ Global Program Instance type_add_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 AddOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 + n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_sub_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 SubOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 - n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_mul_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 MulOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 * n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_checked_add_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 CheckedAddOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 + n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_checked_sub_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 CheckedSubOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 - n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_checked_mul_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 CheckedMulOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 * n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_div_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 DivOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 `quot` n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_mod_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 ModOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 `rem` n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_and_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 AndOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (Z.land n1 n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_or_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 OrOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (Z.lor n1 n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_xor_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 XorOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (Z.lxor n1 n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_shl_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 ShlOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 ≪ n2) _ _).
+ Next Obligation. done. Qed.
+ Global Program Instance type_shr_int_int_inst E L π it v1 n1 v2 n2:
+ TypedBinOpVal π E L v1 (int it) n1 v2 (int it) n2 ShrOp (IntOp it) (IntOp it) := λ T, i2p (type_arithop_int_int E L π it v1 n1 v2 n2 T (n1 ≫ n2) _ _).
+ Next Obligation. done. Qed.
+
+ Inductive destruct_hint_switch_int :=
+ | DestructHintSwitchIntCase (n : Z)
+ | DestructHintSwitchIntDefault.
+
+ Lemma type_switch_int Ï€ E L n it m ss def fn R Ï v:
+ ([∧ map] i↦mi ∈ m,
+ li_trace (DestructHintSwitchIntCase i) (
+ ⌜n = i⌠-∗ ∃ s, ⌜ss !! mi = Some s⌠∗ typed_stmt Ï€ E L s fn R Ï)) ∧
+ (li_trace (DestructHintSwitchIntDefault) (
+ ⌜n ∉ (map_to_list m).*1⌠-∗ typed_stmt Ï€ E L def fn R Ï))
+ ⊢ typed_switch Ï€ E L v _ (int it) n it m ss def fn R Ï.
+ Proof.
+ unfold li_trace.
+ iIntros "HT Hit". rewrite /ty_own_val/=. iDestruct "Hit" as "[%Hv %Hit]".
+ iExists n. iSplit; first done.
+ iInduction m as [] "IH" using map_ind; simplify_map_eq => //.
+ { iDestruct "HT" as "[_ HT]". iApply "HT". iPureIntro.
+ rewrite map_to_list_empty. set_solver. }
+ rewrite big_andM_insert //. destruct (decide (n = i)); subst.
+ - rewrite lookup_insert. iDestruct "HT" as "[[HT _] _]". by iApply "HT".
+ - rewrite lookup_insert_ne//. iApply "IH". iSplit; first by iDestruct "HT" as "[[_ HT] _]".
+ iIntros (Hn). iDestruct "HT" as "[_ HT]". iApply "HT". iPureIntro.
+ rewrite map_to_list_insert //. set_solver.
+ Qed.
+ Global Instance type_switch_int_inst π E L n v it : TypedSwitch π E L v _ (int it) n it :=
+ λ m ss def fn R Ï, i2p (type_switch_int Ï€ E L n it m ss def fn R Ï v).
+
+ (* TODO move *)
+ Definition typed_un_op_cont_t := llctx → val → ∀ rt : Type, type rt → rt → iProp Σ.
+ Lemma type_neg_int π E L n it v (T : typed_un_op_cont_t) :
+ (⌜n ∈ it⌠-∗ ⌜it.(it_signed)⌠∗ ⌜n ≠min_int it⌠∗ T L (i2v (-n) it) _ (int it) (-n))
+ ⊢ typed_un_op Ï€ E L v (v â—áµ¥{Ï€} n @ int it)%I (NegOp) (IntOp it) T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "HT [%Hv %Hit] %Φ #CTX #HE HL HΦ". move: (Hv) => /val_to_Z_in_range ?.
+ iDestruct ("HT" with "[//]") as (Hs Hn) "HT".
+ have [|v' Hv']:= val_of_Z_is_Some None it (- n). {
+ unfold elem_of, int_elem_of_it, max_int, min_int in *.
+ destruct it as [?[]] => //; simpl in *; lia.
+ }
+ rewrite /i2v Hv'/=.
+ iApply wp_neg_int => //. iNext. iIntros "Hcred".
+ iApply ("HΦ" with "HL [] HT").
+ rewrite /ty_own_val/=.
+ iPureIntro. split; last done. by apply: val_to_of_Z.
+ Qed.
+ Global Instance type_neg_int_inst π E L n it v:
+ TypedUnOpVal π E L v (int it)%I n NegOp (IntOp it) :=
+ λ T, i2p (type_neg_int π E L n it v T).
+
+ (*(if it_signed it then Z.lnot n else Z_lunot (bits_per_int it) n)*)
+ Lemma type_not_int π E L n it v (T : typed_un_op_cont_t) :
+ (⌜n ∈ it⌠-∗ T L (i2v ((if it_signed it then Z.lnot n else Z_lunot (bits_per_int it) n)) it) _ (int it) ((if it_signed it then Z.lnot n else Z_lunot (bits_per_int it) n)))
+ ⊢ typed_un_op Ï€ E L v (v â—áµ¥{Ï€} n @ int it)%I (NotIntOp) (IntOp it) T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "HT [%Hv %Hit] %Φ #CTX #HE HL HΦ". move: (Hv) => /val_to_Z_in_range ?.
+ iDestruct ("HT" with "[//]") as "HT".
+ set (nz := (if it_signed it then Z.lnot n else Z_lunot (bits_per_int it) n)).
+ have [|v' Hv']:= val_of_Z_is_Some None it nz. {
+ unfold elem_of, int_elem_of_it, max_int, min_int, Z_lunot, Z.lnot, Z.pred in *.
+ destruct it as [?[]] => //; simpl in *; first lia.
+ split.
+ - apply Z.mod_pos. rewrite /bits_per_int/bytes_per_int/bits_per_byte. lia.
+ - rewrite /int_modulus. subst nz.
+ match goal with
+ | |- ?a `mod` ?b ≤ _ => specialize (Z_mod_lt a b); lia
+ end.
+ }
+ rewrite /i2v /=.
+ iApply (wp_unop_det_pure v').
+ { intros. subst nz. split; [inversion 1; simplify_eq/= | move => ->]; simplify_eq/=; first done.
+ econstructor; done. }
+ rewrite Hv' /=.
+ iIntros "!> Hcred". iApply ("HΦ" with "HL"); last done.
+ rewrite /ty_own_val/=. iPureIntro.
+ split; last done. by apply: val_to_of_Z.
+ Qed.
+ Global Instance type_not_int_inst π E L n it v:
+ TypedUnOpVal π E L v (int it)%I n NotIntOp (IntOp it) :=
+ λ T, i2p (type_not_int π E L n it v T).
+
+ Lemma type_cast_int π E L n (it1 it2 : int_type) v (T : typed_un_op_cont_t) :
+ ⌜ly_size it2 ≤ max_int isize_t⌠∗ (⌜n ∈ it1⌠-∗ ∀ v, T L v _ (int it2) (wrap_to_it n it2))
+ ⊢ typed_un_op Ï€ E L v (v â—áµ¥{Ï€} n @ int it1)%I (CastOp (IntOp it2)) (IntOp it1) T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "[%Hit2 HT] [%Hv %Hit] %Φ #CTX #HE HL HΦ".
+ iSpecialize ("HT" with "[]").
+ { iPureIntro. by apply: val_to_Z_in_range. }
+ destruct (val_of_Z_is_Some (val_to_byte_prov v) it2 (wrap_to_it n it2)) as (n' & Hit').
+ { apply wrap_to_it_in_range. }
+ iApply wp_cast_int => //.
+ iNext. iIntros "Hcred". iApply ("HΦ" with "HL [] HT") => //.
+ rewrite /ty_own_val/=.
+ iPureIntro. split; last done. by apply: val_to_of_Z.
+ Qed.
+ Global Instance type_cast_int_inst π E L n it1 it2 v:
+ TypedUnOpVal π E L v (int it1)%I n (CastOp (IntOp it2)) (IntOp it1) :=
+ λ T, i2p (type_cast_int π E L n it1 it2 v T).
+
+ (** Bool *)
+ Lemma type_val_bool' b π :
+ ⊢ (val_of_bool b) â—áµ¥{Ï€} b @ bool_t.
+ Proof. rewrite /ty_own_val/=. iIntros. by destruct b. Qed.
+ Lemma type_val_bool b π (T : ∀ rt, type rt → rt → iProp Σ) :
+ (T bool bool_t b) ⊢ typed_value (val_of_bool b) π T.
+ Proof. iIntros "HT #LFT". iExists bool, bool_t, b. iFrame. iApply type_val_bool'. Qed.
+ Global Instance type_val_bool_inst b π : TypedValue (val_of_bool b) π :=
+ λ T, i2p (type_val_bool b π T).
+
+ Lemma val_to_bool_val_to_Z v b :
+ val_to_bool v = Some b →
+ val_to_Z v u8 = Some (bool_to_Z b).
+ Proof.
+ intros Heq; unfold val_to_bool in Heq.
+ destruct v as [ | m]; first done.
+ destruct m as [ m | |]; [|done..].
+ destruct m as [m ].
+ destruct (decide (m = 0)) as [ -> | ].
+ { destruct v.
+ - injection Heq as <-. done.
+ - congruence. }
+ destruct (decide (m = 1)) as [-> | ].
+ { destruct v.
+ - injection Heq as <-. done.
+ - congruence. }
+ destruct m as [ | [] | []]; congruence.
+ Qed.
+
+ (* TODO: we should maybe also support RelOp with BoolOp in Caesium and use BoolOp here.
+ That would make the semantics maybe more realistic by triggering UB on invalid boolean input patterns.
+ *)
+ Lemma type_relop_bool_bool E L v1 b1 v2 b2 (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) b op π :
+ match op with
+ | EqOp rit => Some (eqb b1 b2, rit)
+ | NeOp rit => Some (negb (eqb b1 b2), rit)
+ | _ => None
+ end = Some (b, u8) →
+ (T L (val_of_bool b) bool bool_t b)
+ ⊢ typed_bin_op Ï€ E L v1 (v1 â—áµ¥{Ï€} b1 @ bool_t) v2 (v2 â—áµ¥{Ï€} b2 @ bool_t) op (BoolOp) (BoolOp) T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "%Hop HT %Hv1 %Hv2" (Φ) "#CTX #HE HL HΦ".
+ iApply (wp_binop_det_pure (val_of_bool b)).
+ { destruct op, b1, b2; simplify_eq.
+ all: split; [ inversion 1; simplify_eq/= | move => -> ]; simplify_eq/=.
+ all: try by (symmetry; eapply val_of_bool_iff_val_of_Z).
+ all: econstructor => //; case_bool_decide; try done.
+ all: by apply val_of_bool_iff_val_of_Z. }
+ iIntros "!> Hcred". iApply ("HΦ" with "HL"); last done.
+ rewrite /ty_own_val/=.
+ iPureIntro. by destruct b.
+ Qed.
+
+ Global Program Instance type_eq_bool_bool_inst E L v1 b1 v2 b2 π :
+ TypedBinOpVal π E L v1 (bool_t) b1 v2 (bool_t) b2 (EqOp u8) (BoolOp) (BoolOp) := λ T, i2p (type_relop_bool_bool E L v1 b1 v2 b2 T (eqb b1 b2) _ π _).
+ Solve Obligations with done.
+ Global Program Instance type_ne_bool_bool_inst E L v1 b1 v2 b2 π :
+ TypedBinOpVal π E L v1 (bool_t) b1 v2 (bool_t) b2 (NeOp u8) (BoolOp) (BoolOp) := λ T, i2p (type_relop_bool_bool E L v1 b1 v2 b2 T (negb (eqb b1 b2)) _ π _).
+ Solve Obligations with done.
+
+ Lemma type_notop_bool π E L v b (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) :
+ T L (val_of_bool (negb b)) bool bool_t (negb b)
+ ⊢ typed_un_op Ï€ E L v (v â—áµ¥{Ï€} b @ bool_t) NotBoolOp BoolOp T.
+ Proof.
+ rewrite /ty_own_val/=.
+ iIntros "HT %Hv" (Φ) "#CTX #HE HL HΦ".
+ iApply (wp_unop_det_pure (val_of_bool (negb b))).
+ { intros. split; [inversion 1; simplify_eq/= | move => ->]; simplify_eq/=; first done.
+ econstructor; done. }
+ iIntros "!> Hcred". iApply ("HΦ" with "HL"); last done.
+ rewrite /ty_own_val/=. iPureIntro. by destruct b.
+ Qed.
+ Global Instance type_notop_bool_inst π E L v b :
+ TypedUnOpVal π E L v bool_t b NotBoolOp BoolOp := λ T, i2p (type_notop_bool π E L v b T).
+
+ Inductive trace_if_bool :=
+ | TraceIfBool (b : bool).
+
+ Lemma type_if_bool E L π b v T1 T2:
+ (case_destruct b (λ b' _,
+ li_trace (TraceIfBool b, b') (
+ if b' then T1 else T2)))
+ ⊢ typed_if E L v (v â—áµ¥{Ï€} b @ bool_t) T1 T2.
+ Proof.
+ unfold li_trace, case_destruct. rewrite /ty_own_val/=. iIntros "(% & Hs) Hv".
+ iExists b. iSplit; first done. done.
+ Qed.
+ Global Instance type_if_bool_inst E L Ï€ b v : TypedIf E L v (v â—áµ¥{Ï€} b @ bool_t)%I :=
+ λ T1 T2, i2p (type_if_bool E L π b v T1 T2).
+
+ Lemma type_assert_bool E L Ï€ b s fn R v Ï :
+ (⌜b = true⌠∗ typed_stmt Ï€ E L s fn R Ï)
+ ⊢ typed_assert Ï€ E L v (bool_t) b s fn R Ï.
+ Proof.
+ iIntros "[-> Hs] #CTX #HE HL Hb". by iFrame.
+ Qed.
+ Global Instance type_assert_bool_inst E L π b v : TypedAssert π E L v (bool_t) b :=
+ λ s fn R Ï, i2p (type_assert_bool E L Ï€ b s fn R v Ï).
+End typing.
diff --git a/theories/rust_typing/lft_contexts.v b/theories/rust_typing/lft_contexts.v
new file mode 100644
index 0000000000000000000000000000000000000000..add8113bead66533756b35e48cd6df58c30ff219
--- /dev/null
+++ b/theories/rust_typing/lft_contexts.v
@@ -0,0 +1,1309 @@
+(** Based on a file from the RustBelt development.
+ https://gitlab.mpi-sws.org/iris/lambda-rust/-/blob/8753a224e99ce646e27729aa078367d64788f447/theories/typing/lft_contexts.v
+*)
+From iris.proofmode Require Import tactics.
+From iris.bi Require Import fractional.
+From iris.base_logic Require Import ghost_map.
+From lrust.lifetime Require Import frac_borrow.
+From refinedrust Require Export base.
+From refinedrust Require Import fraction_counting util.
+From iris.prelude Require Import options.
+Set Default Proof Using "Type".
+
+Class lctxGS Σ := LctxGS {
+ (* maps local lifetime names to their corresponding ghost name *)
+ lctx_name_inG :: ghost_mapG Σ lft gname;
+ (* track the fractions for one lifetime *)
+ lctx_inG :: fraction_mapG Σ;
+ (* track the decomposition of one lifetime into an atomic lifetime and "extra" lifetimes at some fraction *)
+ lctx_decomp_inG :: ghost_mapG Σ lft (positive * lft * frac);
+ (* name for the map *)
+ lctx_name : gname;
+ (* name for the decomposition map *)
+ lctx_decomp_name : gname;
+}.
+Global Hint Mode lctxGS - : typeclass_instances.
+Class lctxGPreS Σ := LctxGPreS {
+ lctx_pre_name_inG :: ghost_mapG Σ lft gname;
+ lctx_pre_inG :: fraction_mapG Σ;
+ lctx_pre_decomp_inG :: ghost_mapG Σ lft (positive * lft * frac);
+}.
+Global Hint Mode lctxGPreS - : typeclass_instances.
+Definition lctxΣ : gFunctors :=
+ #[ ghost_mapΣ (lft) gname; fraction_mapΣ; ghost_mapΣ lft (positive * lft * frac) ].
+Global Instance subG_lctxΣ Σ : subG (lctxΣ) Σ → lctxGPreS Σ.
+Proof. solve_inG. Qed.
+
+Definition elctx_elt : Type := lft * lft.
+Notation elctx := (list elctx_elt).
+
+(* nicer version for the singleton case *)
+Fixpoint lft_intersect_list' (κs : list lft) : lft :=
+ match κs with
+ | [] => static
+ | [κ] => κ
+ | κ :: κs => κ ⊓ lft_intersect_list' κs
+ end.
+Lemma lft_intersect_list'_iff κs :
+ lft_intersect_list' κs = lft_intersect_list κs.
+Proof.
+ induction κs as [ | κ κs IH]; simpl; first done.
+ destruct κs as [ | κ' κs]; simpl.
+ { rewrite right_id //. }
+ simpl in IH. rewrite IH //.
+Qed.
+
+Declare Scope rrust_elctx_scope.
+Delimit Scope rrust_elctx_scope with EL.
+(* We need to define [elctx] and [llctx] as notations to make eauto
+ work. But then, Coq is not able to bind them to their
+ notations, so we have to use [Arguments] everywhere. *)
+Bind Scope rrust_elctx_scope with elctx_elt.
+
+Notation "κ1 ⊑ₑ κ2" := (@pair lft lft κ1 κ2) (at level 70).
+
+Definition llctx_elt : Type := (option nat * lft * list lft).
+Notation llctx := (list llctx_elt).
+
+(* locally-owned lifetimes with a "borrow count" *)
+Notation "κ '⊑ₗ{' c '}' κl" := (@pair (@prod (option nat) lft) (list lft) (Some c%nat, κ) κl) (at level 70).
+(* local aliases with no distinct ownership *)
+Notation "κ '≡ₗ' κl" := (@pair (@prod (option nat) lft) (list lft) (None, κ) κl) (at level 70).
+
+Section lft_contexts.
+ Context `{!invGS Σ, !lftGS Σ lft_userE, !lctxGS Σ}.
+ Implicit Type (κ : lft).
+
+ (* External lifetime contexts. *)
+ Definition elctx_elt_interp (x : elctx_elt) : iProp Σ :=
+ (x.1 ⊑ x.2)%I.
+
+ Definition elctx_interp (E : elctx) : iProp Σ :=
+ ([∗ list] x ∈ E, elctx_elt_interp x)%I.
+ Global Instance elctx_interp_permut :
+ Proper ((≡ₚ) ==> (⊣⊢)) elctx_interp.
+ Proof. intros ???. by apply big_opL_permutation. Qed.
+ Global Instance elctx_interp_persistent E :
+ Persistent (elctx_interp E).
+ Proof. apply _. Qed.
+
+ (* Local lifetime contexts. *)
+ (** The fraction_map for [κ] is stored at [γ]. *)
+ Definition lft_has_gname_def (κ : lft) (γ : gname) : iProp Σ :=
+ ghost_map_elem lctx_name κ DfracDiscarded γ.
+ Definition lft_has_gname_aux : seal (@lft_has_gname_def). Proof. by eexists. Qed.
+ Definition lft_has_gname := lft_has_gname_aux.(unseal).
+ Definition lft_has_gname_eq : @lft_has_gname = @lft_has_gname_def := lft_has_gname_aux.(seal_eq).
+
+ Global Instance lft_has_gname_pers κ γ : Persistent (lft_has_gname κ γ).
+ Proof. rewrite lft_has_gname_eq. apply _. Qed.
+ Global Instance lft_has_gname_timeless κ γ : Timeless (lft_has_gname κ γ).
+ Proof. rewrite lft_has_gname_eq. apply _. Qed.
+
+ Lemma lft_has_gname_agree κ γ1 γ2 :
+ lft_has_gname κ γ1 -∗ lft_has_gname κ γ2 -∗ ⌜γ1 = γ2âŒ.
+ Proof. rewrite lft_has_gname_eq. apply ghost_map_elem_agree. Qed.
+
+ (** The local lifetime [κ] is κ = i ⊓ κextra ⊓ κs.
+ This serves to link up the interpretation of the fraction_map with the fragments, without leaking these details.
+ *)
+ Definition lft_decomp_def (κ : lft) (i : positive) (κextra : lft) (qextra : frac) : iProp Σ :=
+ ghost_map_elem lctx_decomp_name κ DfracDiscarded (i, κextra, qextra).
+ Definition lft_decomp_aux : seal (@lft_decomp_def). Proof. by eexists. Qed.
+ Definition lft_decomp := lft_decomp_aux.(unseal).
+ Definition lft_decomp_eq : @lft_decomp = @lft_decomp_def := lft_decomp_aux.(seal_eq).
+
+ Global Instance lft_decomp_pers κ i κextra qextra: Persistent (lft_decomp κ i κextra qextra).
+ Proof. rewrite lft_decomp_eq. apply _. Qed.
+ Global Instance lft_decomp_timeless κ i κextra qextra : Timeless (lft_decomp κ i κextra qextra).
+ Proof. rewrite lft_decomp_eq. apply _. Qed.
+
+ Lemma lft_decomp_agree κ i1 i2 κextra1 κextra2 qextra1 qextra2 :
+ lft_decomp κ i1 κextra1 qextra1 -∗ lft_decomp κ i2 κextra2 qextra2 -∗ ⌜i1 = i2⌠∧ ⌜κextra1 = κextra2⌠∧ ⌜qextra1 = qextra2âŒ.
+ Proof.
+ iIntros "H1 H2". rewrite lft_decomp_eq.
+ iPoseProof (ghost_map_elem_agree with "H1 H2") as "%Heq".
+ iPureIntro. by injection Heq.
+ Qed.
+
+ Definition llft_own_frac κ (qc : frac) : iProp Σ :=
+ ∃ i κextra qextra, lft_decomp κ i κextra qextra ∗
+ let qeff := Qp.min 1 qextra in
+ qc.[positive_to_lft i] ∗ (qeff * qc).[κextra].
+
+ Global Instance llft_own_frac_fractional κ : Fractional (llft_own_frac κ).
+ Proof.
+ iIntros (q1 q2). iSplit.
+ - iIntros "(%i & %κextra & %qextra & #Hmeta & Hi & Hextra)".
+ rewrite Qp.mul_add_distr_l. rewrite !lft_tok_fractional.
+ iDestruct "Hi" as "(Hi1 & Hi2)". iDestruct "Hextra" as "(Hextra1 & Hextra2)".
+ iSplitL "Hi1 Hextra1"; iExists _, _, _; iFrame "#"; iFrame.
+ - iIntros "((%i & %κextra & %qextra & #Hmeta1 & Hi1 & Hextra1) & (% & % & % & #Hmeta2 & Hi2 & Hextra2))".
+ iPoseProof (lft_decomp_agree with "Hmeta1 Hmeta2") as "(<- & <- & <-)".
+ iExists _, _, _. iFrame "Hmeta1".
+ rewrite Qp.mul_add_distr_l. rewrite !lft_tok_fractional. iFrame.
+ Qed.
+
+ (** Enforces the shape of a local lifetime. *)
+ Definition llft_shape (κ : lft) (κs : list lft) : iProp Σ :=
+ let κ' := lft_intersect_list κs in
+ ∃ i κextra qextra, lft_decomp κ i κextra qextra ∗
+ ⌜κ = κ' ⊓ positive_to_lft i ⊓ κextraâŒ.
+ Instance llft_shape_pers κ κs : Persistent (llft_shape κ κs).
+ Proof. apply _. Qed.
+
+ (* We can kill a local lifetime κ. *)
+ Definition llft_killable (κ : lft) : iProp Σ :=
+ ∃ i κextra qextra, lft_decomp κ i κextra qextra ∗
+ (1.[positive_to_lft i] ={↑lftN ∪ lft_userE}[lft_userE]▷=∗ [†positive_to_lft i]).
+
+
+ (** We currently have a fraction of the "core" of local lifetime [κ].
+ This is handed out to clients as a certificate to decrease the lifetime again. *)
+ Definition llft_elt_tok_def (κ : lft) : iProp Σ :=
+ ∃ γ, lft_has_gname κ γ ∗ fraction_map_elem γ (llft_own_frac κ).
+ Definition llft_elt_tok_aux : seal (@llft_elt_tok_def). Proof. by eexists. Qed.
+ Definition llft_elt_tok := llft_elt_tok_aux.(unseal).
+ Definition llft_elt_tok_eq : @llft_elt_tok = @llft_elt_tok_def := llft_elt_tok_aux.(seal_eq).
+
+
+ (** Rough workflow:
+ - we get llft_elt_tok in the right multiplicity for all lifetimes
+ - from that, we inductively get a token of the full intersected thing by lower-bounding fractions, + a viewshift to get all the tokens back.
+ *)
+ Definition llft_elt_toks (κs : list lft) : iProp Σ :=
+ [∗ list] κ ∈ κs, llft_elt_tok κ.
+ Lemma llft_elt_toks_app κs1 κs2 :
+ llft_elt_toks (κs1 ++ κs2) ⊣⊢ llft_elt_toks κs1 ∗ llft_elt_toks κs2.
+ Proof. apply big_sepL_app. Qed.
+
+ (* To support calling functions with lifetime parameters, the local lifetime [κ] may be an
+ intersection of not just the atomic lifetime [id] but also of some extra
+ lifetimes [κextra], of which a smaller fraction [qextra] is owned.
+
+ For [Ï], since [κs] is empty, the caller can just keep the persistent [lft_decomp] to know that it will get the full fraction back afterwards, which is sufficient to extract the lifetime tokens for [κextra] again. *)
+ Definition llctx_owned_elt_interp (c : nat) (κ : lft) (κs : list lft) : iProp Σ :=
+ ∃ γ, lft_has_gname κ γ ∗
+ (* authorative management of the lifetime *)
+ fraction_map_auth γ (llft_own_frac κ) 1 c ∗
+ (* decomposition of the lifetime *)
+ llft_shape κ κs ∗
+ (* when we have the full thing, we can kill it *)
+ llft_killable κ.
+
+ (* Local lifetime contexts without the "ending a lifetime" viewshifts -- these are fractional. *)
+ Definition llctx_owned_elt_interp_noend (c : nat) (κ : lft) (κs : list lft) (q : Qp) : iProp Σ :=
+ ∃ γ, lft_has_gname κ γ ∗
+ (* [qc] is the fraction still available here *)
+ fraction_map_auth γ (llft_own_frac κ) q c ∗
+ (* decomposition of the lifetime *)
+ llft_shape κ κs.
+
+ Global Instance llctx_owned_elt_interp_noend_fractional c κ κs :
+ Fractional (llctx_owned_elt_interp_noend c κ κs).
+ Proof.
+ iIntros (q q'). iSplit; iIntros "H".
+ - iDestruct "H" as (γ) "(#? & Hfrac & #Hshape)".
+ rewrite fraction_map_auth_fractional. iDestruct "Hfrac" as "[Hfrac1 Hfrac2]".
+ iSplitL "Hfrac1"; iExists _; by iFrame "∗%#".
+ - iDestruct "H" as "[Hq Hq']".
+ iDestruct "Hq" as (γ1) "(#Hm1 & Hfrac1 & Hshape1)".
+ iDestruct "Hq'" as (γ2) "(#Hm2 & Hfrac2 & _)".
+ iPoseProof (lft_has_gname_agree with "Hm1 Hm2") as "<-".
+ iExists γ1. iFrame "Hm1 Hshape1". rewrite fraction_map_auth_fractional. iFrame.
+ Qed.
+
+ Lemma llctx_owned_elt_interp_acc_noend c κ κs :
+ llctx_owned_elt_interp c κ κs ⊢
+ llctx_owned_elt_interp_noend c κ κs 1 ∗ (llctx_owned_elt_interp_noend c κ κs 1 -∗ llctx_owned_elt_interp c κ κs).
+ Proof.
+ iIntros "H". iDestruct "H" as (γ) "(#Hm & Hauth & #Hshape & Hkill)".
+ iSplitL "Hauth". { iExists γ. iFrame "#∗". }
+ iIntros "(%γ' & Hm' & Hauth & _)".
+ iPoseProof (lft_has_gname_agree with "Hm Hm'") as "<-".
+ iExists γ. iFrame "#∗".
+ Qed.
+
+ (** κ is an alias for the intersection of κs, expressed through a mutual dynamic inclusion. *)
+ Definition llctx_alias_elt_interp (κ : lft) (κs : list lft) : iProp Σ :=
+ κ ⊑ lft_intersect_list κs ∗ lft_intersect_list κs ⊑ κ.
+ Global Instance llctx_alias_elt_interp_pers κ κs : Persistent (llctx_alias_elt_interp κ κs).
+ Proof. apply _. Qed.
+
+ Definition llctx_elt_interp (x : llctx_elt) : iProp Σ :=
+ match x with
+ | (Some c, κ, κs) => llctx_owned_elt_interp c κ κs
+ | (None, κ, κs) => llctx_alias_elt_interp κ κs
+ end.
+ Definition llctx_elt_interp_noend (x : llctx_elt) (q : Qp) : iProp Σ :=
+ match x with
+ | (Some c, κ, κs) => llctx_owned_elt_interp_noend c κ κs q
+ | (None, κ, κs) => llctx_alias_elt_interp κ κs
+ end.
+
+ Global Instance llctx_elt_interp_noend_fractional x :
+ Fractional (llctx_elt_interp_noend x).
+ Proof.
+ destruct x as [[[c | ] κ] κs]; apply _.
+ Qed.
+
+ Lemma llctx_elt_interp_acc_noend x :
+ llctx_elt_interp x ⊢
+ llctx_elt_interp_noend x 1 ∗ (llctx_elt_interp_noend x 1 -∗ llctx_elt_interp x).
+ Proof.
+ iIntros "H". destruct x as [[[c | ] κ] κs].
+ - by iApply llctx_owned_elt_interp_acc_noend.
+ - iFrame. iIntros "$".
+ Qed.
+
+ (** noend contexts *)
+ Definition llctx_interp_noend (L : llctx) (q : Qp) : iProp Σ :=
+ [∗ list] x ∈ L, llctx_elt_interp_noend x q.
+ Global Instance llctx_interp_fractional L :
+ Fractional (llctx_interp_noend L).
+ Proof.
+ intros ??. rewrite -big_sepL_sep. by setoid_rewrite <-fractional.
+ Qed.
+ Global Instance llctx_interp_as_fractional L q :
+ AsFractional (llctx_interp_noend L q) (llctx_interp_noend L) q.
+ Proof. split; first done. apply _. Qed.
+
+ Global Instance llctx_interp_combine_sep L q1 q2 : CombineSepAs (llctx_interp_noend L q1) (llctx_interp_noend L q2) (llctx_interp_noend L (q1 + q2)).
+ Proof.
+ rewrite /CombineSepAs. iIntros "Ha".
+ iPoseProof (fractional_split with "Ha") as "Ha"; last by iApply "Ha".
+ apply _.
+ Qed.
+
+ Global Instance frame_llctx_interp p L q1 q2 q3 :
+ FrameFractionalQp q1 q2 q3 →
+ Frame p (llctx_interp_noend L q1) (llctx_interp_noend L q2) (llctx_interp_noend L q3) | 5.
+ Proof. apply: frame_fractional. Qed.
+
+
+ (** This is a global invariant to be compatible with concurrency (we can't just put it in [llctx_interp]). *)
+ Definition llctxN := rrustN .@ "llctx".
+ Definition llctx_inv :=
+ ((∃ (M : gmap lft gname) (M' : gmap lft (positive * lft * frac)),
+ ghost_map_auth lctx_name 1 M ∗ ghost_map_auth lctx_decomp_name 1 M' ∗
+ ⌜dom M = dom M'âŒ))%I.
+ Definition llctx_ctx_def : iProp Σ :=
+ inv llctxN llctx_inv.
+ Definition llctx_ctx_aux : seal (llctx_ctx_def). Proof. by eexists. Qed.
+ Definition llctx_ctx := llctx_ctx_aux.(unseal).
+ Definition llctx_ctx_eq : llctx_ctx = llctx_ctx_def := llctx_ctx_aux.(seal_eq).
+
+ Global Instance llctx_ctx_pers : Persistent llctx_ctx.
+ Proof. rewrite llctx_ctx_eq. apply _. Qed.
+
+ Definition llctx_interp (L : llctx) : iProp Σ :=
+ [∗ list] x ∈ L, llctx_elt_interp x.
+ Global Instance llctx_interp_permut :
+ Proper ((≡ₚ) ==> (⊣⊢)) (llctx_interp).
+ Proof.
+ intros ???. iSplit; iIntros "HL"; unfold llctx_interp.
+ all: rewrite big_opL_permutation; done.
+ Qed.
+End lft_contexts.
+
+Lemma lctx_init `{!lctxGPreS Σ, !invGS Σ, !lftGS Σ lft_userE} F :
+ ↑llctxN ⊆ F →
+ ⊢ |={F}=> ∃ H : lctxGS Σ, llctx_ctx ∗ llctx_interp [].
+Proof.
+ iIntros (?).
+ iMod (ghost_map_alloc_empty (K:=lft) (V:=gname)) as "(%γname & Hname)".
+ iMod (ghost_map_alloc_empty (K:=lft) (V:=positive*lft*frac)) as "(%γdecomp & Hdecomp)".
+ set (LLCTXGS := LctxGS _ _ _ _ γname γdecomp).
+ iMod (inv_alloc llctxN _ llctx_inv with "[Hname Hdecomp]") as "Hctx".
+ { iNext. iExists ∅, ∅. iFrame. iPureIntro. set_solver. }
+ iModIntro. iExists LLCTXGS. iSplitL.
+ { rewrite llctx_ctx_eq. iApply "Hctx". }
+ by iApply big_sepL_nil.
+Qed.
+
+Section lft_contexts.
+ Context `{!invGS Σ, !lftGS Σ lft_userE, !lctxGS Σ}.
+
+ Lemma llctx_elt_interp_acc_noend_big (L : llctx) :
+ ([∗ list] κ ∈ L, llctx_elt_interp κ) ⊢
+ llctx_interp_noend L 1 ∗ (llctx_interp_noend L 1 -∗ ([∗ list] κ ∈ L, llctx_elt_interp κ)).
+ Proof.
+ iIntros "HL". setoid_rewrite llctx_elt_interp_acc_noend at 1. rewrite big_sepL_sep.
+ iDestruct "HL" as "($ & Hclose)".
+ iIntros "Hnoend". iCombine "Hclose Hnoend" as "H".
+ rewrite /llctx_interp_noend -big_sepL_sep.
+ setoid_rewrite bi.wand_elim_l. eauto with iFrame.
+ Qed.
+ Lemma llctx_interp_acc_noend L :
+ llctx_interp L -∗
+ llctx_interp_noend L 1 ∗ (llctx_interp_noend L 1 -∗ llctx_interp L).
+ Proof. iIntros "HL". by iApply llctx_elt_interp_acc_noend_big. Qed.
+
+
+ (** Lifetime inclusion without id/count tracking *)
+ Section fix_EL.
+ Context (E : elctx) (L : llctx).
+
+ Definition lctx_lft_incl κ κ' : Prop :=
+ (* the proof must not use any information about the counts *)
+ ∀ qL, llctx_interp_noend L qL -∗ □ (elctx_interp E -∗ κ ⊑ κ')%I.
+
+ Definition lctx_lft_eq κ κ' : Prop :=
+ lctx_lft_incl κ κ' ∧ lctx_lft_incl κ' κ.
+
+ Lemma lctx_lft_incl_incl κ κ' :
+ lctx_lft_incl κ κ' → llctx_interp L -∗ □ (elctx_interp E -∗ κ ⊑ κ')%I.
+ Proof.
+ iIntros (Hincl) "HL".
+ iDestruct (llctx_interp_acc_noend with "HL") as "[HL _]".
+ iApply Hincl. done.
+ Qed.
+
+ Lemma lctx_lft_incl_refl κ : lctx_lft_incl κ κ.
+ Proof.
+ iIntros (qL) "_ !> _".
+ iApply lft_incl_refl.
+ Qed.
+
+ Global Instance lctx_lft_incl_preorder : PreOrder lctx_lft_incl.
+ Proof.
+ split; first by intros ?; apply lctx_lft_incl_refl.
+ iIntros (??? H1 H2 ?) "HL".
+ iDestruct (H1 with "HL") as "#H1".
+ iDestruct (H2 with "HL") as "#H2".
+ iClear "∗". iIntros "!> #HE".
+ iDestruct ("H1" with "HE") as "#?". iDestruct ("H2" with "HE") as "#?".
+ by iApply lft_incl_trans.
+ Qed.
+
+ Global Instance lctx_lft_incl_proper :
+ Proper (lctx_lft_eq ==> lctx_lft_eq ==> iff) lctx_lft_incl.
+ Proof. intros ??[] ??[]. split; intros; by etrans; [|etrans]. Qed.
+
+ Global Instance lctx_lft_eq_equivalence : Equivalence lctx_lft_eq.
+ Proof.
+ split.
+ - by split.
+ - intros ?? Heq; split; apply Heq.
+ - intros ??? H1 H2. split; etrans; (apply H1 || apply H2).
+ Qed.
+
+ Lemma lctx_lft_incl_static κ : lctx_lft_incl κ static.
+ Proof. iIntros (qL) "_ !> _". iApply lft_incl_static. Qed.
+
+ Lemma lctx_lft_incl_elem κ κs :
+ κ ∈ κs → lctx_lft_incl (lft_intersect_list κs) κ.
+ Proof.
+ iIntros (??) "HL !> _".
+ by iApply lft_intersect_list_elem_of_incl.
+ Qed.
+
+ Lemma lctx_lft_incl_local_owned_full κ κ' κ'' c κs :
+ κ ⊑ₗ{c} κs ∈ L → lctx_lft_incl (lft_intersect_list κs ⊓ κ') κ'' → lctx_lft_incl (κ ⊓ κ') κ''.
+ Proof.
+ intros Hin Hincl. etrans; last done.
+ iIntros (?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iDestruct (big_sepL_elem_of with "HL") as "HL"; first done.
+ iDestruct "HL" as (γ) "(Hname & Hauth & Hshape)".
+ iDestruct "Hshape" as (i κextra ?) "(_ & ->)".
+ iIntros "!>#HE". iDestruct ("Hincl" with "HE") as "#?".
+ iClear "Hincl HE".
+ rewrite -!lft_intersect_assoc.
+ rewrite [κextra ⊓ _]lft_intersect_comm [positive_to_lft _ ⊓ _] lft_intersect_assoc [positive_to_lft _ ⊓ _]lft_intersect_comm.
+ rewrite -!lft_intersect_assoc. rewrite lft_intersect_assoc.
+ iApply lft_intersect_incl_l.
+ Qed.
+
+ Lemma lctx_lft_incl_local_owned κ κ' c κs :
+ κ ⊑ₗ{c} κs ∈ L → κ' ∈ κs → lctx_lft_incl κ κ'.
+ Proof.
+ intros HL Hin. rewrite -(lft_intersect_right_id κ).
+ eapply lctx_lft_incl_local_owned_full; first done.
+ rewrite lft_intersect_right_id.
+ by apply lctx_lft_incl_elem.
+ Qed.
+
+ Lemma lctx_lft_incl_local_owned' κ κ' κ'' c κs :
+ κ ⊑ₗ{c} κs ∈ L → κ' ∈ κs → lctx_lft_incl κ' κ'' → lctx_lft_incl κ κ''.
+ Proof. intros. etrans; last done. by eapply lctx_lft_incl_local_owned. Qed.
+
+ Lemma lctx_lft_incl_local_alias_full κ κ' κ'' κs :
+ κ ≡ₗ κs ∈ L → lctx_lft_incl (lft_intersect_list κs ⊓ κ') κ'' → lctx_lft_incl (κ ⊓ κ') κ''.
+ Proof.
+ intros Hin Hincl. etrans; last done.
+ iIntros (?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iDestruct (big_sepL_elem_of with "HL") as "HL"; first done.
+ iDestruct "HL" as "(#Hincl1 & #Hincl2)".
+ iIntros "!>#HE".
+ iApply lft_intersect_mono; first done. iApply lft_incl_refl.
+ Qed.
+
+ Lemma lctx_lft_incl_local_alias_reverse κ κ' κ'' κs :
+ κ ≡ₗ κs ∈ L → lctx_lft_incl κ κ'' → lctx_lft_incl κ' (lft_intersect_list κs) → lctx_lft_incl κ' κ''.
+ Proof.
+ intros Hin Hincl1 Hincl2. etrans; first done.
+ iIntros (?) "HL". iPoseProof (Hincl1 with "HL") as "#Hincl".
+ iDestruct (big_sepL_elem_of with "HL") as "HL"; first done.
+ iDestruct "HL" as "(#Hincl1 & #Hincl2)".
+ iIntros "!>#HE".
+ iApply lft_incl_trans; first done. by iApply "Hincl".
+ Qed.
+
+ Lemma lctx_lft_incl_local_alias κ κ' κs :
+ κ ≡ₗ κs ∈ L → κ' ∈ κs → lctx_lft_incl κ κ'.
+ Proof.
+ intros HL Hin. rewrite -(lft_intersect_right_id κ).
+ eapply lctx_lft_incl_local_alias_full; first done.
+ rewrite lft_intersect_right_id.
+ by apply lctx_lft_incl_elem.
+ Qed.
+
+ Lemma lctx_lft_incl_local_alias' κ κ' κ'' κs :
+ κ ≡ₗ κs ∈ L → κ' ∈ κs → lctx_lft_incl κ' κ'' → lctx_lft_incl κ κ''.
+ Proof. intros. etrans; last done. by eapply lctx_lft_incl_local_alias. Qed.
+
+ Lemma lctx_lft_incl_external_full κ1 κ2 κ κ' :
+ κ1 ⊑ₑ κ2 ∈ E → lctx_lft_incl (κ2 ⊓ κ) κ' → lctx_lft_incl (κ1 ⊓ κ) κ'.
+ Proof.
+ intros Hin Hincl. etrans; last done.
+ iIntros (?) "HL". iPoseProof (Hincl with "HL") as "#Hincl".
+ iIntros "!>#HE". iDestruct ("Hincl" with "HE") as "#?".
+ iDestruct (big_sepL_elem_of with "HE") as "#Hincl'"; first done.
+ iApply lft_intersect_mono; first done.
+ iApply lft_incl_refl.
+ Qed.
+
+ Lemma lctx_lft_incl_external κ κ' : κ ⊑ₑ κ' ∈ E → lctx_lft_incl κ κ'.
+ Proof.
+ iIntros (??) "_ !> #HE".
+ rewrite /elctx_interp /elctx_elt_interp big_sepL_elem_of //. done.
+ Qed.
+
+ Lemma lctx_lft_incl_external' κ κ' κ'' :
+ κ ⊑ₑ κ' ∈ E → lctx_lft_incl κ' κ'' → lctx_lft_incl κ κ''.
+ Proof. intros. etrans; last done. by eapply lctx_lft_incl_external. Qed.
+
+ Lemma lctx_lft_incl_intersect κ1 κ2 κ' κ'' :
+ lctx_lft_incl κ1 κ' → lctx_lft_incl κ2 κ'' →
+ lctx_lft_incl (κ1 ⊓ κ2) (κ' ⊓ κ'').
+ Proof.
+ iIntros (Hκ' Hκ'' ?) "HL".
+ iDestruct (Hκ' with "HL") as "#Hκ'".
+ iDestruct (Hκ'' with "HL") as "#Hκ''".
+ iIntros "!> #HE".
+ iDestruct ("Hκ'" with "HE") as "#?".
+ iDestruct ("Hκ''" with "HE") as "#?".
+ by iApply lft_intersect_mono.
+ Qed.
+
+ Lemma lctx_lft_incl_intersect_l κ κ' κ'' :
+ lctx_lft_incl κ κ' →
+ lctx_lft_incl (κ ⊓ κ'') κ'.
+ Proof.
+ iIntros (Hκ' ?) "HL".
+ iDestruct (Hκ' with "HL") as "#Hκ'".
+ iIntros "!> #HE". iDestruct ("Hκ'" with "HE") as "#?".
+ iApply lft_incl_trans; last done.
+ by iApply lft_intersect_incl_l.
+ Qed.
+
+ Lemma lctx_lft_incl_intersect_r κ κ' κ'' :
+ lctx_lft_incl κ κ' →
+ lctx_lft_incl (κ'' ⊓ κ) κ'.
+ Proof.
+ iIntros (Hκ' ?) "HL".
+ iDestruct (Hκ' with "HL") as "#Hκ'".
+ iIntros "!> #HE". iDestruct ("Hκ'" with "HE") as "#?".
+ iApply lft_incl_trans; last done.
+ by iApply lft_intersect_incl_r.
+ Qed.
+
+ Lemma lctx_lft_incl_incl_noend qL κ κ' :
+ lctx_lft_incl κ κ' →
+ llctx_interp_noend L qL -∗
+ elctx_interp E -∗
+ κ ⊑ κ'.
+ Proof.
+ iIntros (Hincl) "HL HE".
+ iPoseProof (Hincl with "HL") as "#Hincl".
+ by iApply "Hincl".
+ Qed.
+
+ (* Lifetime aliveness *)
+ Definition lctx_lft_alive (κ : lft) : Prop :=
+ (* the proof must not use any information about the counts *)
+ (* TODO: why do we have masks here? can I also just make this a bupd?*)
+ ∀ F qL, ↑lftN ⊆ F → elctx_interp E -∗ llctx_interp_noend L qL ={F}=∗
+ ∃ q', q'.[κ] ∗ (q'.[κ] ={F}=∗ llctx_interp_noend L qL).
+
+ Lemma lctx_lft_alive_tok_noend κ F q :
+ ↑lftN ⊆ F →
+ lctx_lft_alive κ → elctx_interp E -∗ llctx_interp_noend L q ={F}=∗
+ ∃ q', q'.[κ] ∗ llctx_interp_noend L q' ∗
+ (q'.[κ] -∗ llctx_interp_noend L q' ={F}=∗ llctx_interp_noend L q).
+ Proof.
+ iIntros (? Hal) "#HE [HL1 HL2]".
+ iMod (Hal with "HE HL1") as (q') "[Htok Hclose]"; [done | ].
+ destruct (Qp.lower_bound (q/2) q') as (qq & q0 & q'0 & Hq & ->). rewrite Hq.
+ iExists qq. iDestruct "HL2" as "[$ HL]". iDestruct "Htok" as "[$ Htok]".
+ iIntros "!> Htok' HL'". iCombine "HL'" "HL" as "HL". rewrite -Hq. iFrame.
+
+ iApply "Hclose". iFrame.
+ Qed.
+
+ Lemma lctx_lft_alive_tok_noend_list κs F q :
+ ↑lftN ⊆ F → Forall lctx_lft_alive κs →
+ elctx_interp E -∗ llctx_interp_noend L q ={F}=∗
+ ∃ q', q'.[lft_intersect_list κs] ∗ llctx_interp_noend L q' ∗
+ (q'.[lft_intersect_list κs] -∗ llctx_interp_noend L q' ={F}=∗ llctx_interp_noend L q).
+ Proof.
+ iIntros (? Hκs) "#HE". iInduction κs as [|κ κs] "IH" forall (q Hκs).
+ { iIntros "HL !>". iExists _. iFrame "HL". iSplitL; first iApply lft_tok_static.
+ iIntros "_ $". done. }
+ inversion_clear Hκs.
+ iIntros "HL". iMod (lctx_lft_alive_tok_noend κ with "HE HL")as (q') "(Hκ & HL & Hclose1)"; [solve_typing..|].
+ iMod ("IH" with "[//] HL") as (q'') "(Hκs & HL & Hclose2)".
+ destruct (Qp.lower_bound q' q'') as (qq & q0 & q'0 & -> & ->).
+ iExists qq. iDestruct "HL" as "[$ HL2]". iDestruct "Hκ" as "[Hκ1 Hκ2]".
+ iDestruct "Hκs" as "[Hκs1 Hκs2]". iModIntro. simpl. rewrite -lft_tok_sep. iSplitL "Hκ1 Hκs1".
+ { by iFrame. }
+ iIntros "[Hκ1 Hκs1] HL1". iMod ("Hclose2" with "[$Hκs1 $Hκs2] [$HL1 $HL2]") as "HL".
+ iMod ("Hclose1" with "[$Hκ1 $Hκ2] HL") as "HL". done.
+ Qed.
+
+ Lemma lctx_lft_alive_static : lctx_lft_alive static.
+ Proof.
+ iIntros (F qL ?) "_ $". iExists 1%Qp. iSplitL; last by auto.
+ by iApply lft_tok_static.
+ Qed.
+
+ Lemma lctx_lft_alive_local_owned κ c κs:
+ κ ⊑ₗ{c} κs ∈ L → Forall lctx_lft_alive κs → lctx_lft_alive κ.
+ Proof.
+ iIntros ([i HL]%elem_of_list_lookup_1 Hκs F qL ? ) "#HE HL".
+ iDestruct "HL" as "[HL1 HL2]". rewrite {2}/llctx_interp_noend /llctx_elt_interp.
+ iDestruct (big_sepL_lookup_acc with "HL2") as "[Hκ Hclose]"; first done.
+ iDestruct "Hκ" as (γ) "(#Hname & Hauth & #Hshape)".
+ iDestruct "Hshape" as (ic κextra qextra) "(#Hd & %Hde)".
+ iAssert (∃ q', q'.[lft_intersect_list κs] ∗
+ (q'.[lft_intersect_list κs] ={F}=∗ llctx_interp_noend L (qL / 2)))%I
+ with "[> HE HL1]" as "H".
+ { move:(qL/2)%Qp=>qL'. clear HL. iClear "Hd Hname". subst κ.
+ iInduction Hκs as [|κ κs Hκ ?] "IH" forall (qL').
+ - iExists 1%Qp. iFrame. iSplitR; last by auto. iApply lft_tok_static.
+ - iDestruct "HL1" as "[HL1 HL2]".
+ iMod (Hκ with "HE HL1") as (q') "[Htok' Hclose]"; [done | ].
+ iMod ("IH" with "HL2") as (q'') "[Htok'' Hclose']".
+ destruct (Qp.lower_bound q' q'') as (q0 & q'2 & q''2 & -> & ->).
+ iExists q0. rewrite -lft_tok_sep. iDestruct "Htok'" as "[$ Hr']".
+ iDestruct "Htok''" as "[$ Hr'']". iIntros "!>[Hκ Hfold]".
+ iMod ("Hclose" with "[$Hκ $Hr']") as "$". iApply "Hclose'". iFrame. }
+ iDestruct "H" as (q1) "[Htok' Hclose']". rewrite -{5}(Qp.div_2 qL).
+ set (qeff := (1 `min` qextra)%Qp).
+ (* basic proof structure:
+ - get a fraction from the fraction_map_auth,
+ - take the lower bound from the recursive q'
+ - done
+ *)
+ iPoseProof (fraction_map_auth_access with "Hauth") as "(%q2 & Hfrac & Hauth & Hcl_auth)".
+ iDestruct "Hfrac" as (???) "(Hd' & Hi & Hex)".
+ iPoseProof (lft_decomp_agree with "Hd Hd'")as "(<- & <- & <-)".
+ (* take the min of q1, q2, (q `min` qextra) * q2 *)
+ destruct (Qp.lower_bound q1 (qeff * q2)%Qp) as (q0 & q'1 & q'2 & -> & Hmax). rewrite Hmax.
+ destruct (Qp.lower_bound q0 q2) as (q0' & q'3 & q'4 & -> & ->).
+ rewrite -!Qp.add_assoc.
+ rewrite !(lft_tok_fractional _ q0').
+ iDestruct "Htok'" as "(Hκs1 & Hκs2)".
+ iDestruct "Hi" as "(Hi1 & Hi2)".
+ iDestruct "Hex" as "(Hex1 & Hex2)".
+ iModIntro. iExists q0'.
+ iSplitL "Hi1 Hex1 Hκs1".
+ { rewrite Hde. rewrite -!lft_tok_sep. iFrame. }
+ (* close everything *)
+ rewrite {9}Hde. rewrite -!lft_tok_sep. iIntros "((? & Hi1) & Hex1)".
+ iMod ("Hclose'" with "[$]") as "$".
+ iPoseProof ("Hcl_auth" with "[Hi1 Hex1 Hi2 Hex2] Hauth") as "Hauth".
+ { iExists _, _, _. iFrame "Hd". rewrite Hmax !lft_tok_fractional. by iFrame. }
+ iApply "Hclose". iModIntro. iExists γ. iFrame "#∗".
+ iExists _, _, _. eauto with iFrame.
+ Qed.
+
+ Lemma lctx_lft_alive_intersect κ1 κ2 :
+ lctx_lft_alive κ1 → lctx_lft_alive κ2 → lctx_lft_alive (κ1 ⊓ κ2).
+ Proof.
+ iIntros (Hal1 Hal2 F qL ? ) "#HE [HL1 HL2]".
+ iMod (Hal1 F with "HE HL1") as (q1) "(Hκ1 & Hcl1)"; [done | ].
+ iMod (Hal2 F with "HE HL2") as (q2) "(Hκ2 & Hcl2)"; [done | ].
+ iModIntro.
+ set (q' := (Qp.min q1 q2)%Qp).
+ iExists q'.
+ rewrite -lft_tok_sep.
+ iPoseProof (Fractional_fractional_le (λ q, q.[κ1])%I q1 q' with "Hκ1") as "[$ Hvs1]".
+ { apply Qp.le_min_l. }
+ iPoseProof (Fractional_fractional_le (λ q, q.[κ2])%I q2 q' with "Hκ2") as "[$ Hvs2]".
+ { apply Qp.le_min_r. }
+ iIntros "[Hκ1 Hκ2]".
+ iMod ("Hcl1" with "(Hvs1 Hκ1)") as "$".
+ iMod ("Hcl2" with "(Hvs2 Hκ2)") as "$".
+ done.
+ Qed.
+ End fix_EL.
+
+ Lemma lctx_lft_alive_incl {E L} κ κ':
+ lctx_lft_alive E L κ → lctx_lft_incl E L κ κ' → lctx_lft_alive E L κ'.
+ Proof.
+ iIntros (Hal Hinc F qL ? ) "#HE HL".
+ iAssert (κ ⊑ κ')%I with "[#]" as "#Hincl".
+ { iApply (Hinc with "HL HE"). }
+ iMod (Hal with "HE HL") as (q') "[Htok Hclose]"; [done | ].
+ iMod (lft_incl_acc with "Hincl Htok") as (q'') "[Htok Hclose']"; first done.
+ iExists q''. iIntros "{$Htok}!>Htok". iApply ("Hclose" with "[> -]").
+ by iApply "Hclose'".
+ Qed.
+
+ Lemma lctx_lft_alive_intersect_list {E L} κs :
+ Forall (lctx_lft_alive E L) κs → lctx_lft_alive E L (lft_intersect_list κs).
+ Proof.
+ intros Hal.
+ induction κs as [ | κ κs IH].
+ { simpl. apply lctx_lft_alive_static. }
+ inversion Hal; subst.
+ eapply lctx_lft_alive_intersect; first done.
+ by eapply IH.
+ Qed.
+
+ Lemma lctx_lft_alive_local_alias E L κ κs:
+ κ ≡ₗ κs ∈ L → Forall (lctx_lft_alive E L) κs → (lctx_lft_alive E L) κ.
+ Proof.
+ iIntros ([i HL]%elem_of_list_lookup_1 Hκs).
+ eapply (lctx_lft_alive_incl (lft_intersect_list κs)); first by apply lctx_lft_alive_intersect_list.
+ iIntros (?) "HL".
+ iDestruct (big_sepL_lookup_acc with "HL") as "[Hκ Hclose]"; first done.
+ rewrite {1}/llctx_elt_interp_noend /=. iDestruct "Hκ" as "#[Hincl1 Hincl2]".
+ eauto.
+ Qed.
+
+ Lemma lctx_lft_alive_external E L κ κ':
+ κ ⊑ₑ κ' ∈ E → lctx_lft_alive E L κ → lctx_lft_alive E L κ'.
+ Proof.
+ intros. by eapply lctx_lft_alive_incl, lctx_lft_incl_external.
+ Qed.
+
+ (* External lifetime context satisfiability *)
+ Definition elctx_sat E L E' : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ □ (elctx_interp E -∗ elctx_interp E').
+
+ Lemma elctx_sat_nil E L : elctx_sat E L [].
+ Proof. iIntros (?) "_ !> _". by rewrite /elctx_interp /=. Qed.
+
+ Lemma elctx_sat_lft_incl E L E' κ κ' :
+ lctx_lft_incl E L κ κ' → elctx_sat E L E' → elctx_sat E L ((κ ⊑ₑ κ') :: E').
+ Proof.
+ iIntros (Hκκ' HE' qL) "HL".
+ iDestruct (Hκκ' with "HL") as "#Hincl".
+ iDestruct (HE' with "HL") as "#HE'".
+ iClear "∗". iIntros "!> #HE". iSplit.
+ - by iApply "Hincl".
+ - by iApply "HE'".
+ Qed.
+
+ Lemma elctx_sat_app E L E1 E2 :
+ elctx_sat E L E1 → elctx_sat E L E2 → elctx_sat E L (E1 ++ E2).
+ Proof.
+ iIntros (HE1 HE2 ?) "HL".
+ iDestruct (HE1 with "HL") as "#HE1".
+ iDestruct (HE2 with "HL") as "#HE2".
+ iClear "∗". iIntros "!> #HE".
+ iDestruct ("HE1" with "HE") as "#$".
+ iApply ("HE2" with "HE").
+ Qed.
+
+ Lemma elctx_sat_refl E L : elctx_sat E L E.
+ Proof. iIntros (?) "_ !> ?". done. Qed.
+
+
+ (* [κs] and [L'] are "outputs", as getting a token for κ has side-effects *)
+ Definition lctx_lft_alive_count E L (κ : lft) κs L' : Prop :=
+ (∀ F, lftE ⊆ F →
+ elctx_interp E -∗
+ llctx_interp L ={F}=∗
+ llft_elt_toks κs ∗
+ (llft_elt_toks κs ={F}=∗ ∃ q, q.[κ] ∗ (q.[κ] ={F}=∗ llft_elt_toks κs)) ∗
+ llctx_interp L').
+ Lemma lctx_lft_alive_count_tok F E L κ κs L' :
+ lftE ⊆ F →
+ lctx_lft_alive_count E L κ κs L' →
+ elctx_interp E -∗
+ llctx_interp L ={F}=∗ ∃ q,
+ q.[κ] ∗ (q.[κ] ={F}=∗ llft_elt_toks κs) ∗ llctx_interp L'.
+ Proof.
+ iIntros (? Hal) "HE HL".
+ iMod (Hal with "HE HL") as "(Htoks & Hvs & $)"; first done.
+ iMod ("Hvs" with "Htoks") as (q) "(Htok & Hvs)".
+ eauto with iFrame.
+ Qed.
+
+ Lemma lctx_lft_alive_count_static E L : lctx_lft_alive_count E L static [] L.
+ Proof.
+ iIntros (F ?) "_ $".
+ iModIntro. iSplitR; first by iApply big_sepL_nil.
+ iIntros "_". iExists 1%Qp. iSplitL.
+ - iApply lft_tok_static.
+ - iIntros "!>_". by iApply big_sepL_nil.
+ Qed.
+
+ Fixpoint lctx_lft_alive_count_iter E L κs κs' L' : Prop :=
+ match κs with
+ | [] => κs' = [] ∧ L' = L
+ | κ :: κs =>
+ ∃ κs1 κs2 L1,
+ lctx_lft_alive_count E L κ κs1 L1 ∧
+ lctx_lft_alive_count_iter E L1 κs κs2 L' ∧
+ κs' = κs1 ++ κs2
+ end.
+ Lemma lctx_lft_alive_count_iter_elim E L κs κs' L' :
+ lctx_lft_alive_count_iter E L κs κs' L' →
+ (∀ F, lftE ⊆ F →
+ elctx_interp E -∗
+ llctx_interp L ={F}=∗
+ llft_elt_toks κs' ∗
+ (llft_elt_toks κs' ={F}=∗ ∃ q, q.[lft_intersect_list κs] ∗ (q.[lft_intersect_list κs] ={F}=∗ llft_elt_toks κs')) ∗
+ llctx_interp L').
+ Proof.
+ induction κs as [ | κ κs IH] in κs', L', L |-*.
+ - simpl. intros [-> ->]. by apply lctx_lft_alive_count_static.
+ - simpl. intros (κs1 & κs2 & L1 & Hal & Hi & ->).
+ iIntros (? ?) "#HE HL". iMod (Hal with "HE HL") as "(Hκs1 & Hcl1 & HL1)"; first done.
+ iMod (IH with "HE HL1") as "(Hκs2 & Hcl2 & HL2)"; [done.. | ].
+ iModIntro. rewrite {1 2}llft_elt_toks_app. iFrame.
+ iIntros "(Hκs1 & Hκs2)".
+ iMod ("Hcl1" with "Hκs1") as "(%q1 & Htok1 & Hcl1)".
+ iMod ("Hcl2" with "Hκs2") as "(%q2 & Htok2 & Hcl2)".
+ set (q' := (Qp.min q1 q2)%Qp).
+ iExists q'.
+ rewrite -lft_tok_sep.
+ iPoseProof (Fractional_fractional_le (λ q, q.[κ])%I q1 q' with "Htok1") as "[$ Hvs1]".
+ { apply Qp.le_min_l. }
+ iPoseProof (Fractional_fractional_le (λ q, q.[lft_intersect_list κs])%I q2 q' with "Htok2") as "[$ Hvs2]".
+ { apply Qp.le_min_r. }
+ iIntros "!>[Hκ1 Hκ2]".
+ rewrite llft_elt_toks_app.
+ iMod ("Hcl1" with "(Hvs1 Hκ1)") as "$".
+ iMod ("Hcl2" with "(Hvs2 Hκ2)") as "$".
+ done.
+ Qed.
+ Lemma lctx_lft_alive_count_local_owned E L κ i c κs κs' L' :
+ lctx_lft_alive_count_iter E L κs κs' L' →
+ (L' !! i = Some (κ ⊑ₗ{c} κs)) →
+ lctx_lft_alive_count E L κ (κ :: κs') (<[i := κ ⊑ₗ{S c} κs]> L').
+ Proof.
+ iIntros (Hal Hlook).
+ iIntros (F ?) "#HE HL".
+ iMod (lctx_lft_alive_count_iter_elim with "HE HL") as "(Hκs & Hcl & HL)"; [done | done | ].
+ (* now get the token for the local lifetime *)
+ iDestruct "HL" as "HL".
+ iPoseProof (big_sepL_insert_acc with "HL") as "(Hκ & HLcl)"; first done.
+ iDestruct "Hκ" as (γ) "(#Hname & Hauth & #Hshape & Hkill)".
+ iMod (fraction_map_auth_increase with "Hauth") as "(Hauth & Hel)".
+ iSplitL "Hel Hκs".
+ { iModIntro. rewrite /llft_elt_toks. iFrame.
+ rewrite llft_elt_tok_eq. iExists γ. iFrame "#∗".
+ }
+ iSplitL "Hcl"; first last.
+ { iModIntro. iApply "HLcl". iExists γ. eauto with iFrame. }
+ iModIntro. rewrite {3 4}/llft_elt_toks. rewrite {1}big_sepL_cons.
+ iIntros "(Hκ & Hκs)". iMod ("Hcl" with "Hκs") as (q1) "(Hκs & Hclκs)".
+ rewrite {1}llft_elt_tok_eq. iClear "Hname". clear γ.
+ iDestruct "Hκ" as (γ) "(#Hname & Hel)".
+ iPoseProof (fraction_map_elem_acc with "Hel") as (q2) "(Hκ & Hclκ)".
+ (* destruct the shape thing *)
+ iDestruct "Hshape" as (ic κextra qextra) "(#Hd & %Heq)".
+ iDestruct "Hκ" as (???) "(Hd' & Hi & Hex)".
+ iPoseProof (lft_decomp_agree with "Hd Hd'")as "(<- & <- & <-)".
+ (* take the min of q1, q2, (q `min` qextra) * q2 *)
+ set (qeff := (1 `min` qextra)%Qp).
+ destruct (Qp.lower_bound q1 (qeff * q2)%Qp) as (q0 & q'1 & q'2 & -> & Hmax). rewrite Hmax.
+ destruct (Qp.lower_bound q0 q2) as (q0' & q'3 & q'4 & -> & ->).
+ rewrite -!Qp.add_assoc.
+ rewrite !(lft_tok_fractional _ q0').
+ iDestruct "Hκs" as "(Hκs1 & Hκs2)".
+ iDestruct "Hi" as "(Hi1 & Hi2)".
+ iDestruct "Hex" as "(Hex1 & Hex2)".
+ iModIntro. iExists q0'.
+ iSplitL "Hi1 Hex1 Hκs1".
+ { rewrite Heq. rewrite -!lft_tok_sep. iFrame. }
+ (* close everything *)
+ rewrite {6}Heq. rewrite -!lft_tok_sep. iIntros "((? & ?) & ?)".
+ iMod ("Hclκs" with "[$]") as "$".
+ rewrite llft_elt_tok_eq.
+ iModIntro. iExists γ. iFrame "Hname". iApply "Hclκ".
+ iExists _, _, _. iFrame "Hd".
+ rewrite Hmax !lft_tok_fractional. iFrame.
+ Qed.
+
+ Lemma lctx_lft_alive_count_local_alias E L L' κ κs κs' :
+ κ ≡ₗ κs ∈ L → lctx_lft_alive_count_iter E L κs κs' L' → lctx_lft_alive_count E L κ κs' L'.
+ Proof.
+ iIntros ([i HL]%elem_of_list_lookup_1 Hκs).
+ iIntros (F ?) "#HE HL".
+ iDestruct (big_sepL_lookup_acc with "HL") as "[Hκ Hclose]"; first done.
+ rewrite {1}/llctx_elt_interp /=. iDestruct "Hκ" as "#Hκ".
+ iPoseProof ("Hclose" with "Hκ") as "HL". iDestruct "Hκ" as "[Hincl1 Hincl2]".
+ iMod (lctx_lft_alive_count_iter_elim with "HE HL") as "($ & Hcl & $)"; [done | done | ].
+ iModIntro. iIntros "Htoks". iMod ("Hcl" with "Htoks") as (q) "(Htok & Hcl)".
+ iMod (lft_incl_acc with "Hincl2 Htok") as (q') "(Htok & Hcl2)"; first done.
+ iModIntro. iExists q'. iFrame "Htok".
+ iIntros "Htok". iMod ("Hcl2" with "Htok") as "Htok". by iApply "Hcl".
+ Qed.
+
+ Lemma lctx_lft_alive_count_intersect E L κ1 κ2 L1 L2 κs1 κs2 :
+ lctx_lft_alive_count E L κ1 κs1 L1 → lctx_lft_alive_count E L1 κ2 κs2 L2 → lctx_lft_alive_count E L (κ1 ⊓ κ2) (κs1 ++ κs2) L2.
+ Proof.
+ iIntros (Hal1 Hal2).
+ iIntros (F qL) "#HE HL".
+ iMod (Hal1 F with "HE HL") as "(Hκs1 & Hcl1 & HL1)"; first done.
+ iMod (Hal2 F with "HE HL1") as "(Hκs2 & Hcl2 & $)"; first done.
+ iModIntro.
+ rewrite {1 2}llft_elt_toks_app. iFrame. iIntros "(Hκs1 & Hκs2)".
+ iMod ("Hcl1" with "Hκs1") as (q1) "(Hκ1 & Hcl1)".
+ iMod ("Hcl2" with "Hκs2") as (q2) "(Hκ2 & Hcl2)".
+ set (q' := (Qp.min q1 q2)%Qp).
+ iExists q'.
+ rewrite -lft_tok_sep.
+ iPoseProof (Fractional_fractional_le (λ q, q.[κ1])%I q1 q' with "Hκ1") as "[$ Hvs1]".
+ { apply Qp.le_min_l. }
+ iPoseProof (Fractional_fractional_le (λ q, q.[κ2])%I q2 q' with "Hκ2") as "[$ Hvs2]".
+ { apply Qp.le_min_r. }
+ iIntros "!>[Hκ1 Hκ2]".
+ rewrite llft_elt_toks_app.
+ iMod ("Hcl1" with "(Hvs1 Hκ1)") as "$".
+ iMod ("Hcl2" with "(Hvs2 Hκ2)") as "$".
+ done.
+ Qed.
+
+ Lemma lctx_lft_alive_count_incl E L κ κ' κs L' :
+ lctx_lft_alive_count E L κ κs L' → lctx_lft_incl E L κ κ' → lctx_lft_alive_count E L κ' κs L'.
+ Proof.
+ iIntros (Hal Hinc).
+ iIntros (F qL) "#HE HL".
+ iAssert (κ ⊑ κ')%I with "[#]" as "#Hincl".
+ { iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & _)".
+ iApply (Hinc with "HL HE"). }
+ iMod (Hal with "HE HL") as "($ & Hcl & $)"; first done. iIntros "!> Hκs".
+ iMod ("Hcl" with "Hκs") as (q) "(Htok & Hcl)".
+ iMod (lft_incl_acc with "Hincl Htok") as (q'') "[Htok Hclose']"; first done.
+ iExists q''. iIntros "{$Htok}!>Htok". iApply ("Hcl" with "[> -]").
+ by iApply "Hclose'".
+ Qed.
+
+ Lemma lctx_lft_alive_count_external E L κ κ' κs L' :
+ κ ⊑ₑ κ' ∈ E → lctx_lft_alive_count E L κ κs L' → lctx_lft_alive_count E L κ' κs L'.
+ Proof.
+ intros. by eapply lctx_lft_alive_count_incl, lctx_lft_incl_external.
+ Qed.
+
+ (* Once we are done, we can decrease the count again. *)
+ Lemma llctx_return_elt_tok L i κ c κs :
+ (L !! i = Some (κ ⊑ₗ{c} κs)) →
+ llctx_interp L -∗
+ llft_elt_tok κ ==∗
+ llctx_interp (<[i := κ ⊑ₗ{pred c} κs]> L).
+ Proof.
+ iIntros (Hlook) "HL Htok".
+ iDestruct "HL" as "HL".
+ iPoseProof (big_sepL_insert_acc with "HL") as "(Hκ & HLclose)"; first done.
+ iDestruct "Hκ" as (γ) "(#Hname & Hauth & Hshape & Hkill)".
+ rewrite llft_elt_tok_eq. iDestruct "Htok" as (γ') "(Hname' & Htok)".
+ iPoseProof (lft_has_gname_agree with "Hname Hname'") as "<-".
+ iMod (fraction_map_auth_decrease with "Hauth Htok") as "Hauth".
+ iApply "HLclose".
+ iModIntro. iExists γ. iFrame "∗#".
+ replace (pred c) with (c -1) by lia. done.
+ Qed.
+
+ Fixpoint llctx_release_toks (L : llctx) (κs : list lft) (L' : llctx) :=
+ match κs with
+ | [] => L = L'
+ | κ :: κs =>
+ (* we an choose to only release a subset, e.g. if κ is not in the context *)
+ (∃ i c κs', L !! i = Some (κ ⊑ₗ{c} κs') ∧
+ llctx_release_toks (<[i := κ ⊑ₗ{pred c} κs']> L) κs L')
+ ∨ llctx_release_toks L κs L'
+ end.
+ Lemma llctx_return_elt_toks L κs L' :
+ llctx_release_toks L κs L' →
+ llctx_interp L -∗
+ llft_elt_toks κs ==∗
+ llctx_interp L'.
+ Proof.
+ induction κs as [ | κ κs IH] in L, L' |-*; simpl.
+ - intros ->. eauto.
+ - intros [(i & c & κs' & Hlook & Hi%IH) | Hi%IH].
+ + iIntros "HL (Hκ & Hκs)".
+ iMod (llctx_return_elt_tok with "HL Hκ") as "HL"; first done.
+ iApply (Hi with "HL Hκs").
+ + iIntros "HL (Hκ & Hκs)". iApply (Hi with "HL Hκs").
+ Qed.
+
+ (** a bit of machinery for choosing an atomic lifetime that doesn't conflict with our ghost state *)
+ Lemma lft_set_fresh (M : gset lft) κ' :
+ ∃ i : positive, ∀ m : positive, (i < m)%positive → (positive_to_lft m) ⊓ κ' ∉ M.
+ Proof.
+ setoid_rewrite <-elem_of_elements.
+ generalize (elements M) as l.
+ induction l as [ | κ l IH].
+ - exists 1%positive. intros m ? []%elem_of_nil.
+ - destruct IH as (i & IH). destruct (lft_fresh_strong κ κ') as (i' & Hi).
+ exists (Pos.max i i'). intros m Hlt [ | ]%elem_of_cons.
+ + eapply Hi; last done. lia.
+ + eapply IH; last done. lia.
+ Qed.
+ Lemma pred_infinite_upclosed_pos (P : positive → Prop) :
+ (∃ n, ∀ m, (n < m)%positive → P m) →
+ pred_infinite P.
+ Proof.
+ intros (n & Hn).
+ intros xs. exists (Pos.succ (foldr Pos.max (n)%positive xs))%positive.
+ split.
+ - apply Hn. induction xs as [ | k xs IH]; simpl; lia.
+ - enough (∀ x, x ∈ xs → x < Pos.succ (foldr Pos.max n xs))%positive as H.
+ { intros Hin%H. lia. }
+ induction xs as [ | k xs IH]; simpl.
+ + intros ? []%elem_of_nil.
+ + intros ? [ | H ]%elem_of_cons; first lia.
+ apply IH in H. lia.
+ Qed.
+ Definition startlft_choose_pred (M : gset lft) (κ' : lft) := (λ i : positive, positive_to_lft i ⊓ κ' ∉ M).
+ Lemma startlft_choose_pred_infinite M κ' : pred_infinite (startlft_choose_pred M κ').
+ Proof.
+ eapply pred_infinite_upclosed_pos. apply lft_set_fresh.
+ Qed.
+
+ Lemma llctx_elt_reclaim F qex κex κs κ κi :
+ lftE ⊆ F →
+ lft_userE ⊆ F →
+ llctx_elt_interp (κ ⊑ₗ{0} κs) -∗
+ lft_decomp κ κi κex qex -∗
+ (1 `min` qex).[κex] ∗ (|={F}[lft_userE]▷=> [†κ]).
+ Proof.
+ iIntros (??) "Hel #Hde".
+ iDestruct "Hel" as "(%γfrac' & Hname' & Hauth & Hshape & Hkill)".
+ iDestruct "Hshape" as "(%i' & %κex' & %qex'' & Hde' & %Heq)".
+ iPoseProof (lft_decomp_agree with "Hde Hde'") as "(<- & <- & <-)".
+ iPoseProof (fraction_map_auth_acc_0 with "Hauth") as "(Hκ & _)".
+ iDestruct "Hκ" as "(% & % & % & Hde'' & Hi & Hex)".
+ iPoseProof (lft_decomp_agree with "Hde Hde''") as "(<- & <- & <-)".
+ iDestruct "Hkill" as "(% & % & % & Hde''' & Hkill)".
+ iPoseProof (lft_decomp_agree with "Hde Hde'''") as "(<- & <- & <-)".
+ rewrite Qp.mul_1_r. iFrame. iApply step_fupd_fupd.
+ iPoseProof (step_fupd_mask_mono with "(Hkill Hi)") as "Ha";
+ last iApply (step_fupd_wand with "Ha"); [set_solver .. | ].
+ iIntros "Hdead". iClear "Hname' Hde". rewrite Heq.
+ iApply (lft_incl_dead with "[] Hdead"); first done.
+ iApply lft_incl_trans; first iApply lft_intersect_incl_l.
+ iApply lft_intersect_incl_r.
+ Qed.
+
+ (** find an item in the local lifetime context that matches a certain property *)
+ Inductive llctx_find_llft_key : Type :=
+ | LlctxFindLftFull
+ | LlctxFindLftOwned
+ | LlctxFindLftAlias.
+ Definition llctx_find_lft_key_interp key (κ : lft) oc :=
+ match key with
+ | LlctxFindLftFull => oc = Some 0%nat
+ | LlctxFindLftOwned => is_Some oc
+ | LlctxFindLftAlias => oc = None
+ end.
+ Definition llctx_find_llft (L : llctx) (κ : lft) (key : llctx_find_llft_key) (κs : list lft) (L' : llctx) :=
+ ∃ A B oc, L = A ++ ((oc, κ, κs)) :: B ∧ L' = A ++ B ∧ llctx_find_lft_key_interp key κ oc.
+
+ Lemma llctx_end_llft F L L' κ κs :
+ lftE ⊆ F →
+ lft_userE ⊆ F →
+ llctx_find_llft L κ LlctxFindLftFull κs L' →
+ llctx_interp L ={F}[lft_userE]▷=∗
+ [†κ] ∗ llctx_interp L'.
+ Proof.
+ iIntros (? ? Hfind) "HL".
+ destruct Hfind as (A & B & oc & -> & -> & Hoc).
+ simpl in Hoc. rewrite Hoc.
+ iDestruct "HL" as "(? & Helt & ?)".
+ iAssert (∃ κi κex qex, lft_decomp κ κi κex qex ∗ llctx_elt_interp (κ ⊑ₗ{ 0} κs))%I with "[Helt]" as "Ha".
+ { iDestruct "Helt" as "(%γ & Hname & Hauth & #Hshape & Hkill)".
+ iDestruct "Hshape" as "(% & % & % & Hde & ?)".
+ iExists _, _, _. iFrame "Hde". iExists _. iFrame. iExists _, _, _. eauto with iFrame. }
+ iDestruct "Ha" as "(% & % & % & Hde & Helt)".
+ iFrame. iPoseProof (llctx_elt_reclaim with "Helt Hde") as "(_ & $)"; done.
+ Qed.
+
+ (** Start a lifetime with some [κex] that the lifetime is intersected with.
+ We can keep track of this, and later on reclaim the fraction [qex] of [κex].
+ This is primarily used for calling functions. *)
+ Lemma llctx_startlft_extra F qex κex κs :
+ lftE ⊆ F →
+ ↑llctxN ⊆ F →
+ lft_userE ⊆ F →
+ lft_ctx -∗
+ llctx_ctx -∗
+ qex.[κex] ={F}=∗
+ ∃ κ, llctx_elt_interp (κ ⊑ₗ{0} κs) ∗ ⌜κ ⊑ˢʸ⿠κex⌠∗
+ (∀ κs', llctx_elt_interp (κ ⊑ₗ{0} κs') -∗ qex.[κex] ∗ |={F}[lft_userE]▷=> [†κ]).
+ Proof.
+ iIntros (???) "#LFT #LCTX Hex". rewrite llctx_ctx_eq.
+ iInv "LCTX" as "(%M & %M' & >Hauth_name & >Hauth_decomp & >%Hdom)" "Hcl".
+ set (κ' := lft_intersect_list κs ⊓ κex).
+ set (P := startlft_choose_pred (dom M) κ').
+ iMod (lft_create_strong P with "LFT") as "(%i & %Hfresh & Htok & Hkill)";
+ [apply startlft_choose_pred_infinite | solve_ndisj | ].
+ set (κ := positive_to_lft i ⊓ κ').
+ assert (M !! κ = None) as Hfresh'.
+ { apply not_elem_of_dom. apply Hfresh. }
+ (* allocate ghost state *)
+ destruct (Qp.lower_bound qex (1 `min` qex)) as (qex' & q1 & q2 & -> & Heq).
+ assert (1 `min` qex' = qex')%Qp as Hle.
+ { rewrite (proj2 (Qp.min_r_iff _ _)); first done.
+ trans (qex' + q2)%Qp.
+ - apply Qp.le_add_l.
+ - rewrite -Heq. apply Qp.le_min_l.
+ }
+ iDestruct "Hex" as "(Hex1 & Hex2)".
+ iMod (ghost_map_insert_persist κ (i, κex, qex') with "Hauth_decomp") as "(Hauth_decomp & #Hde)".
+ { apply not_elem_of_dom. rewrite -Hdom. apply not_elem_of_dom. done. }
+ iMod (fraction_map_auth_alloc (llft_own_frac κ) with "[Htok Hex1]") as "(%γfrac & Hfrac)".
+ { iExists _, _, _. rewrite lft_decomp_eq. iFrame "#∗".
+ rewrite Qp.mul_1_r. rewrite Hle. done. }
+ fold (lft_decomp_def κ i κex qex'). rewrite -lft_decomp_eq.
+ iMod (ghost_map_insert_persist κ γfrac with "Hauth_name") as "(Hauth_name & #Hname)".
+ { done. }
+ fold (lft_has_gname_def κ γfrac). rewrite -lft_has_gname_eq.
+ iMod ("Hcl" with "[Hauth_name Hauth_decomp]") as "_".
+ { iExists _, _. iFrame. rewrite !dom_insert_L Hdom. done. }
+ iModIntro. iExists κ.
+ iSplitL "Hkill Hfrac".
+ { iExists γfrac. iFrame "# Hfrac".
+ iSplitR.
+ - iExists _, _, _. iFrame "Hde".
+ rewrite [_ ⊓ positive_to_lft _]lft_intersect_comm -lft_intersect_assoc. done.
+ - iExists _, _, _. iFrame "Hde". done.
+ }
+ iSplitR.
+ { iPureIntro. subst κ κ'.
+ eapply lft_incl_syn_trans; eapply lft_intersect_incl_syn_r.
+ }
+ iFrame. iIntros (κs') "Helt".
+ iPoseProof (llctx_elt_reclaim F with "Helt Hde") as "(Htok & $)"; [set_solver.. | ].
+ rewrite Hle. done.
+ Qed.
+
+ Lemma llctx_startlft L F κs :
+ lftE ⊆ F →
+ ↑llctxN ⊆ F →
+ lft_userE ⊆ F →
+ lft_ctx -∗
+ llctx_ctx -∗
+ llctx_interp L ={F}=∗
+ ∃ κ : lft,
+ llctx_interp ((κ ⊑ₗ{0} κs) :: L).
+ Proof.
+ iIntros (???) "LFT #LCTX HL".
+ iMod (llctx_startlft_extra F 1 static κs with "LFT LCTX []") as "(%κ & Helt & _)"; [set_solver.. | | ].
+ - iApply lft_tok_static.
+ - iModIntro. iExists κ. iFrame.
+ Qed.
+
+ (* Equalize lifetimes (by giving up tokens) *)
+ Lemma llctx_owned_elem_equalize_lft_sem c κ κs F `{!frac_borG Σ} :
+ lftE ⊆ F →
+ lft_ctx -∗
+ llctx_elt_interp (κ ⊑ₗ{c} κs) ={F}=∗
+ κ ⊑ (lft_intersect_list κs) ∗ (lft_intersect_list κs) ⊑ κ.
+ Proof.
+ iIntros (?) "#LFT". iDestruct 1 as (γ) "(Hname & Hfrac & Hshape & _)"; simplify_eq/=.
+ iPoseProof (fraction_map_auth_access with "Hfrac") as "(%q' & Ha & _ & _)".
+ iDestruct "Ha" as (i κextra qextra) "(Hd1 & Hi & Hex)".
+ iDestruct "Hshape" as (? ? ?) "(Hd2 & ->)".
+ iPoseProof (lft_decomp_agree with "Hd1 Hd2") as "(<- & <- & <-)".
+ iMod (lft_eternalize with "Hi") as "#Hincl".
+ iMod (lft_eternalize with "Hex") as "#Hincl'".
+ iModIntro. iSplit.
+ - iApply lft_incl_trans; first iApply lft_intersect_incl_l.
+ iApply lft_incl_trans; first iApply lft_intersect_incl_l.
+ iApply lft_incl_refl.
+ - iApply (lft_incl_glb with "[]"); first iApply (lft_incl_glb with "[]").
+ + iApply lft_incl_refl.
+ + iApply lft_incl_trans; last done. iApply lft_incl_static.
+ + iApply lft_incl_trans; last done. iApply lft_incl_static.
+ Qed.
+
+ (* Eternalize a lifetime (by giving up tokens) *)
+ Lemma llctx_owned_elem_equalize_lft_sem_static c κ F `{!frac_borG Σ} :
+ lftE ⊆ F →
+ lft_ctx -∗
+ llctx_elt_interp (κ ⊑ₗ{c} []%list) ={F}=∗
+ static ⊑ κ.
+ Proof.
+ iIntros (?) "#LFT". iDestruct 1 as (γ) "(Hname & Hfrac & Hshape & _)"; simplify_eq/=.
+ iPoseProof (fraction_map_auth_access with "Hfrac") as "(%q' & Ha & _)".
+ iDestruct "Ha" as (i κextra qextra) "(Hd1 & Hi & Hex)".
+ iDestruct "Hshape" as (? ? ?) "(Hd2 & ->)".
+ iPoseProof (lft_decomp_agree with "Hd1 Hd2") as "(<- & <- & <-)".
+ iMod (lft_eternalize with "Hi") as "#Hincl".
+ iMod (lft_eternalize with "Hex") as "#Hincl'".
+ iModIntro.
+ iApply (lft_incl_glb with "[]"); simpl; last done.
+ iApply (lft_incl_glb with "[]"); simpl; last done.
+ iApply lft_incl_refl.
+ Qed.
+
+ (** Extend a local lifetime by making its atomic part static, but in turn taking the ability to directly kill it. *)
+ Lemma llctx_extendlft_local_owned `{!frac_borG Σ} F L L' κ κs :
+ lftE ⊆ F →
+ llctx_find_llft L κ LlctxFindLftOwned κs L' →
+ lft_ctx -∗
+ llctx_interp L ={F}=∗
+ llctx_interp ((κ ≡ₗ κs) :: L').
+ Proof.
+ iIntros (? Hfind) "#CTX HL".
+ destruct Hfind as (L1 & L2 & oc & -> & -> & (c & ->)).
+ iDestruct "HL" as "($ & Hel & $)".
+ iMod (llctx_owned_elem_equalize_lft_sem with "CTX Hel") as "(#Hincl1 & #Hincl2)"; first done.
+ iModIntro. iSplit; done.
+ Qed.
+
+ (** Inheritance of timeless propositions *)
+ (* The [key : K] helps automation *)
+ Definition Inherit {K} (κ : lft) (key : K) (P : iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ [†κ] ={F}=∗ P.
+ Global Arguments Inherit : simpl never.
+ Global Typeclasses Opaque Inherit.
+
+ Lemma Inherit_update Q P κ {K} (k : K) :
+ (∀ F, P ={F}=∗ Q) -∗
+ Inherit κ k P -∗
+ Inherit κ k Q.
+ Proof.
+ iIntros "HP Hinh".
+ rewrite /Inherit. iIntros (??) "Hdead". iMod ("Hinh" with "[//] Hdead") as "Ha".
+ by iApply "HP".
+ Qed.
+
+ Definition MaybeInherit {K} (κm : option lft) (k : K) (P : iProp Σ) : iProp Σ :=
+ if κm is Some κ
+ then Inherit κ k P
+ else (∀ F, ⌜lftE ⊆ F⌠-∗ |={F}=> P).
+ (* basically, should now use introduce_with_hooks to simplify it to one of the options *)
+ Global Typeclasses Opaque MaybeInherit.
+ Global Arguments MaybeInherit : simpl never.
+
+ Lemma MaybeInherit_update Q P κm {K} (k : K) :
+ (∀ F, P ={F}=∗ Q) -∗
+ MaybeInherit κm k P -∗
+ MaybeInherit κm k Q.
+ Proof.
+ iIntros "HP Hinh".
+ rewrite /MaybeInherit.
+ destruct κm as [κ | ].
+ - rewrite /Inherit. iIntros (??) "Hdead". iMod ("Hinh" with "[//] Hdead") as "Ha". by iApply "HP".
+ - iIntros (??). iMod ("Hinh" with "[//]") as "HP'". by iApply "HP".
+ Qed.
+
+ Lemma Inherit_mono {K} (k : K) κ κ' P :
+ κ ⊑ κ' -∗
+ Inherit κ k P -∗
+ Inherit κ' k P.
+ Proof.
+ iIntros "Hincl Hinh".
+ rewrite /Inherit. iIntros (??) "Hdead".
+ iMod (lft_incl_dead with "Hincl Hdead") as "Hdead"; first done.
+ iApply ("Hinh" with "[//] Hdead").
+ Qed.
+
+
+ (** Establishing dynamic inclusion of lifetimes *)
+ Inductive inherit_dyn_incl := InheritDynIncl.
+ Lemma lctx_include_lft_sem E L L' F κs κ1 κ2 `{!frac_borG Σ} :
+ lftE ⊆ F →
+ lctx_lft_alive_count E L κ2 κs L' →
+ lft_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L ={F}=∗
+ llctx_interp L' ∗ κ1 ⊑ κ2 ∗ Inherit κ1 InheritDynIncl (llft_elt_toks κs).
+ Proof.
+ iIntros (? Hal) "#LFT #HE HL".
+ iMod (fupd_mask_subseteq lftE) as "HclF"; first done.
+ iMod (lctx_lft_alive_count_tok lftE with "HE HL") as (q) "(Htok & Hcl & HL')"; [done.. | ].
+ iMod (bor_create lftE κ1 with "LFT Htok") as "(Hb & Hinh)"; first done.
+ iMod "HclF" as "_".
+ set (Φ := (λ q', (q * q').[κ2])%I).
+ iMod (bor_fracture Φ with "LFT [Hb]") as "#Hfrac"; first done.
+ { subst Φ. simpl. rewrite Qp.mul_1_r. iFrame. }
+ iPoseProof (frac_bor_lft_incl with "LFT Hfrac") as "Hincl". iFrame "#∗".
+ iModIntro. rewrite /Inherit. iIntros (F' ?) "Hdead".
+ iMod (fupd_mask_subseteq lftE) as "HclF"; first done.
+ iMod ("Hinh" with "Hdead") as ">Htok".
+ iMod ("Hcl" with "Htok") as "?".
+ by iMod "HclF" as "_".
+ Qed.
+
+ Definition lft_dead_list (κs : list lft) : iProp Σ := [∗ list] κ ∈ κs, [†κ].
+ Global Instance lft_dead_list_pers κs : Persistent (lft_dead_list κs).
+ Proof. apply _. Qed.
+ Lemma lft_dead_list_elem κ κs :
+ κ ∈ κs → lft_dead_list κs -∗ [†κ].
+ Proof.
+ iIntros (Hel) "Hall". iApply (big_sepL_elem_of with "Hall"). done.
+ Qed.
+End lft_contexts.
+
+Arguments lft_dead_list : simpl never.
+Arguments llctx_elt_interp : simpl never.
+Arguments lctx_lft_incl {_ _ _ _} _ _ _ _.
+Arguments lctx_lft_eq {_ _ _ _} _ _ _ _.
+Arguments lctx_lft_alive {_ _ _ _} _ _ _.
+Arguments elctx_sat {_ _ _ _} _ _ _.
+Arguments lctx_lft_incl_incl {_ _ _ _ _} _ _ _.
+(*Arguments lctx_lft_incl_incl_noend {_ _ _ _} _ _.*)
+(*Arguments lctx_lft_alive_tok {_ _ _ _ _} _ _ _.*)
+Arguments lctx_lft_alive_tok_noend {_ _ _ _ _ _} _ _ _.
+
+Lemma elctx_sat_submseteq `{!invGS Σ, !lctxGS Σ, !lftGS Σ lft_userE} E E' L :
+ E' ⊆+ E → elctx_sat E L E'.
+Proof. iIntros (HE' ?) "_ !> H". by iApply big_sepL_submseteq. Qed.
+
+Global Hint Opaque elctx_sat lctx_lft_alive lctx_lft_alive_count lctx_lft_incl llft_elt_tok llft_elt_toks : refinedc_typing.
+Global Arguments llft_elt_toks : simpl never.
+Global Typeclasses Opaque llft_elt_toks.
+
+Lemma lft_intersect_list_app κs κs' :
+ lft_intersect_list (κs ++ κs') = (lft_intersect_list κs) ⊓ (lft_intersect_list κs').
+Proof.
+ induction κs as [ | κ κs IH]; simpl.
+ { rewrite left_id. done. }
+ rewrite -assoc IH //.
+Qed.
+
+Lemma list_incl_lft_incl_list `{!invGS Σ, !lctxGS Σ, !lftGS Σ lft_userE} κs1 κs2 :
+ κs1 ⊆ κs2 →
+ ⊢ lft_intersect_list κs2 ⊑ lft_intersect_list κs1.
+Proof.
+ induction κs1 as [ | κ κs1 IH]; simpl.
+ { intros. iApply lft_incl_static. }
+ intros Hincl.
+ efeed pose proof (Hincl κ) as Helem.
+ { apply elem_of_cons; by left. }
+ iApply (lft_incl_trans _ (κ ⊓ lft_intersect_list κs2)); first last.
+ { iApply lft_intersect_mono; first iApply lft_incl_refl.
+ iApply IH. intros κ0 Hel. apply Hincl.
+ apply elem_of_cons; by right. }
+ clear -Helem.
+ iInduction κs2 as [ | κ' κs2] "IH"; simpl.
+ { apply elem_of_nil in Helem. done. }
+ apply elem_of_cons in Helem as [ <- | Helem].
+ - rewrite lft_intersect_assoc.
+ iApply lft_intersect_mono; last iApply lft_incl_refl.
+ iApply lft_incl_glb; iApply lft_incl_refl.
+ - rewrite lft_intersect_assoc [κ ⊓ κ']lft_intersect_comm -lft_intersect_assoc.
+ iApply lft_intersect_mono; first iApply lft_incl_refl.
+ by iApply "IH".
+Qed.
diff --git a/theories/rust_typing/ltype_rules.v b/theories/rust_typing/ltype_rules.v
new file mode 100644
index 0000000000000000000000000000000000000000..fe57784454c35ec410b4d0ab26706b660ac7b3fa
--- /dev/null
+++ b/theories/rust_typing/ltype_rules.v
@@ -0,0 +1,1109 @@
+From caesium Require Export proofmode notation.
+From caesium Require Import derived.
+From refinedrust Require Export ltypes.
+From refinedrust Require Import programs.
+From iris Require Import options.
+
+
+(** * Ltype rules *)
+
+(** Every ltype should fulfill this direct subsumption property. *)
+Local Lemma lty_of_ty_mono `{!typeGS Σ} {rt} (ty : type rt) b1 b2 π r l :
+ bor_kind_direct_incl b2 b1 -∗
+ lty_of_ty_own ty b1 π r l -∗
+ lty_of_ty_own ty b2 π r l.
+Proof.
+ iIntros "#Hincl". destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->". eauto.
+ + rewrite /lty_of_ty_own.
+ iIntros "(%ly & Hst & Hly & Hsc & Hlb & % & ? & #Hb)". iExists ly. iFrame.
+ iExists r'. iFrame. iModIntro. iMod "Hb". iModIntro.
+ by iApply ty_shr_mono.
+ + rewrite /lty_of_ty_own.
+ iDestruct "Hincl" as "(Hincl & ->)".
+ iIntros "(%ly & Hst & Hly & Hsc & Hlb & Hcred & Hat & Hrfn & Hb)". iExists ly. iFrame.
+ iMod "Hb". iModIntro. iApply pinned_bor_shorten; done.
+Qed.
+Local Lemma alias_mono `{!typeGS Σ} rt st p b1 b2 π r l :
+ bor_kind_direct_incl b2 b1 -∗
+ alias_lty_own rt st p b1 π r l -∗
+ alias_lty_own rt st p b2 π r l.
+Proof.
+ iIntros "#Hincl". destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ iDestruct "Hincl" as "->"; eauto.
+Qed.
+Local Lemma mutltype_mono `{!typeGS Σ} {rt} (lt : ltype rt) π κ :
+ (∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗ l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt) →
+ ∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗
+ l â—â‚—[Ï€, b1] r @ MutLtype lt κ -∗ l â—â‚—[Ï€, b2] r @ MutLtype lt κ.
+Proof.
+ iIntros (IH b1 b2 r l) "#Hincl".
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->". eauto.
+ + rewrite !ltype_own_mut_ref_unfold /mut_ltype_own.
+ iIntros "(%ly & ? & ? & ? & %r' & %γ & ? & #Hb)".
+ iExists ly. iFrame. iExists r', γ. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & Hf & Hb)". iModIntro. iExists li.
+ iSplitL "Hf". { by iApply frac_bor_shorten. }
+ iNext. iApply IH; last done.
+ unfold bor_kind_direct_incl.
+ iApply lft_intersect_mono; last done. iApply lft_incl_refl.
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_mut_ref_unfold /mut_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame. iMod "Hb". by iApply pinned_bor_shorten.
+Qed.
+Local Lemma shrltype_mono `{!typeGS Σ} {rt} (lt : ltype rt) π κ :
+ (∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗ l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt) →
+ ∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗
+ l â—â‚—[Ï€, b1] r @ ShrLtype lt κ -∗ l â—â‚—[Ï€, b2] r @ ShrLtype lt κ.
+Proof.
+ iIntros (IH b1 b2 r l) "#Hincl".
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->". eauto.
+ + rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & %r' & ? & #Hb)".
+ iExists ly. iFrame. iExists r'. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & Hf & Hb)". iModIntro. iExists li.
+ iSplitL "Hf". { by iApply frac_bor_shorten. }
+ done.
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame. iMod "Hb". by iApply pinned_bor_shorten.
+Qed.
+Local Lemma box_ltype_mono `{!typeGS Σ} {rt} (lt : ltype rt) π :
+ (∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗ l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt) →
+ ∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗
+ l â—â‚—[Ï€, b1] r @ BoxLtype lt -∗ l â—â‚—[Ï€, b2] r @ BoxLtype lt.
+Proof.
+ iIntros (IH b1 b2 r l) "#Hincl".
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->". eauto.
+ + rewrite !ltype_own_box_unfold /box_ltype_own.
+ iIntros "(%ly & ? & ? & ? & %r' & ? & #Hb)".
+ iExists ly. iFrame. iExists r'. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & Hf & Hb)". iModIntro. iExists li.
+ iSplitL "Hf". { by iApply frac_bor_shorten. }
+ iNext. iApply IH; last done. done.
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_box_unfold /box_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame. iMod "Hb". by iApply pinned_bor_shorten.
+Qed.
+Local Lemma owned_ptr_ltype_mono `{!typeGS Σ} {rt} (lt : ltype rt) (ls : bool) π :
+ (∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗ l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt) →
+ ∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗
+ l â—â‚—[Ï€, b1] r @ OwnedPtrLtype lt ls -∗ l â—â‚—[Ï€, b2] r @ OwnedPtrLtype lt ls.
+Proof.
+ iIntros (IH b1 b2 r l) "#Hincl".
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->". eauto.
+ + rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & %r' & %li & ? & #Hb)".
+ iExists ly. iFrame. iExists r', li. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(Hf & Hb)". iModIntro.
+ iSplitL "Hf". { by iApply frac_bor_shorten. }
+ iNext. iApply IH; last done. done.
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame. iMod "Hb". by iApply pinned_bor_shorten.
+Qed.
+Local Lemma struct_ltype_mono `{!typeGS Σ} {rts} (lts : hlist ltype rts) sls π :
+ (∀ lt b1 b2 r l, lt ∈ hzipl rts lts → bor_kind_direct_incl b2 b1 -∗ l â—â‚—[Ï€, b1] r @ (projT2 lt) -∗ l â—â‚—[Ï€, b2] r @ (projT2 lt)) →
+ ∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗
+ l â—â‚—[Ï€, b1] r @ StructLtype lts sls -∗ l â—â‚—[Ï€, b2] r @ StructLtype lts sls.
+Proof.
+ iIntros (IH b1 b2 r l) "#Hincl".
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->". eauto.
+ + rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & ? & ? & ? & ? & %r' & ? & #Hb)".
+ iExists sl. iFrame. iExists r'. iFrame. iModIntro. iMod "Hb".
+ iApply (big_sepL_wand with "Hb").
+ iModIntro. iApply big_sepL_intro. iIntros "!>" (k [rt [lt r0]] Hlook).
+ apply pad_struct_lookup_Some_1 in Hlook as (n & ly & ? & [[? Hlook] | [? Heq]]).
+ * simpl. specialize (IH (existT rt lt)).
+ iIntros "(%ly0 & ? & ? & Hb)".
+ iExists ly0. iFrame. iApply (IH with "[] Hb"); last done.
+ eapply hpzipl_lookup_inv_hzipl_pzipl in Hlook as (Hlook & _).
+ by eapply elem_of_list_lookup_2.
+ * injection Heq as -> Heq1 Heq2. simpl.
+ apply existT_inj in Heq1 as ->. apply existT_inj in Heq2 as ->.
+ iIntros "(%ly0 & ? & ? & Hb)". iExists ly0. iFrame.
+ rewrite /UninitLtype !ltype_own_ofty_unfold. by iApply (lty_of_ty_mono with "[] Hb").
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & ? & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists sl. iFrame. iMod "Hb".
+ by iApply pinned_bor_shorten.
+Qed.
+Local Lemma array_ltype_mono `{!typeGS Σ} {rt} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) π :
+ (∀ lt b1 b2 r l, lt ∈ (interpret_iml (â— def)%I len lts) → bor_kind_direct_incl b2 b1 -∗ l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt) →
+ ∀ b1 b2 r l, bor_kind_direct_incl b2 b1 -∗
+ l â—â‚—[Ï€, b1] r @ ArrayLtype def len lts -∗ l â—â‚—[Ï€, b2] r @ ArrayLtype def len lts.
+Proof.
+ iIntros (IH b1 b2 r l) "#Hincl".
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->"; eauto.
+ + rewrite !ltype_own_array_unfold /array_ltype_own.
+ iIntros "(%ly & Hst & Hly & Hlb & Ha & %r' & Hrfn & %Hlen2 & #Hb)".
+ iExists ly. iFrame. iExists r'. iFrame. iSplitR; first done. iModIntro.
+ iMod "Hb". iModIntro. iApply (big_sepL2_wand with "Hb").
+ iApply big_sepL2_intro. { rewrite interpret_iml_length //. }
+ iIntros "!>" (?????) "($ & Hb)". iApply IH; last done; [ | done].
+ by eapply elem_of_list_lookup_2.
+ + rewrite !ltype_own_array_unfold /array_ltype_own.
+ iDestruct "Hincl" as "(Hincl & ->)".
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame.
+ iMod "Hb". iModIntro. iApply pinned_bor_shorten; done.
+Qed.
+
+Lemma ltype_bor_kind_direct_incl' `{!typeGS Σ} {rt} (lt : ltype rt) b1 b2 π r l :
+ bor_kind_direct_incl b2 b1 -∗
+ ((l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt) ∗ (l â—â‚—[Ï€, b1] r @ ltype_core lt -∗ l â—â‚—[Ï€, b2] r @ ltype_core lt)).
+Proof.
+ move: rt lt r l b1 b2.
+ apply (ltype_induction (λ rt lt, ∀ r l b1 b2, (⊢ b2 ⊑ₛₖ b1 -∗ (l â—â‚—[ Ï€, b1] r @ lt -∗ l â—â‚—[ Ï€, b2] r @ lt) ∗ (l â—â‚—[Ï€, b1] r @ ltype_core lt -∗ l â—â‚—[Ï€, b2] r @ ltype_core lt))%I)).
+ - iIntros (rt ty κ r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; first last. { rewrite !ltype_own_ofty_unfold. iApply lty_of_ty_mono. done. }
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->"; eauto.
+ + rewrite !ltype_own_blocked_unfold /blocked_lty_own.
+ iIntros "(%ly & ? & ? & ? & ? & [])".
+ + rewrite !ltype_own_blocked_unfold /blocked_lty_own.
+ iDestruct "Hincl" as "(Hincl & ->)".
+ iIntros "(%ly & ? & ? & ? & ? & Hb & ?)". iExists ly. iFrame.
+ iIntros "Hdead". iMod ("Hb" with "Hdead") as "($ & Hb)". by iApply pinned_bor_shorten.
+ - iIntros (rt ty κ r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; first last. { rewrite !ltype_own_ofty_unfold. by iApply lty_of_ty_mono. }
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->"; eauto.
+ + rewrite !ltype_own_shrblocked_unfold /shr_blocked_lty_own.
+ iIntros "(%ly & ? & ? & ? & ? & %r' & -> & Hb)".
+ done.
+ (*iExists ly. iFrame. iExists r'. iSplitR; first done.*)
+ (*by iApply ty_shr_mono.*)
+ + rewrite !ltype_own_shrblocked_unfold /shr_blocked_lty_own.
+ iDestruct "Hincl" as "(Hincl & ->)".
+ iIntros "(%ly & ? & ? & ? & ? & %r' & ? & ? & Hb & Hs & $ & $)".
+ iExists ly. iFrame. iExists r'. iFrame.
+ iIntros "Hdead". iMod ("Hs" with "Hdead") as "Hdead". by iApply pinned_bor_shorten.
+ - iIntros (rt ty r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; rewrite !ltype_own_ofty_unfold; iApply lty_of_ty_mono; done.
+ - iIntros (rt st p r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; rewrite !ltype_own_alias_unfold; iApply alias_mono; done.
+ - iIntros (rt lt IH κ r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; (iApply mutltype_mono; [ | done]).
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "($ & _)".
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "(_ & $)".
+ - iIntros (rt lt IH κ r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; (iApply shrltype_mono; [ | done]).
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "($ & _)".
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "(_ & $)".
+ - iIntros (rt lt IH r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; (iApply box_ltype_mono; [ | done]).
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "($ & _)".
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "(_ & $)".
+ - iIntros (rt lt ls IH r l b1 b2) "#Hincl". simp_ltypes.
+ iSplitL; (iApply owned_ptr_ltype_mono; [ | done]).
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "($ & _)".
+ + iIntros (????) "Hincl". iDestruct (IH with "Hincl") as "(_ & $)".
+ - iIntros (rts lts IH sls r l b1 b2) "#Hincl".
+ simp_ltypes.
+ iSplitL.
+ + iApply (struct_ltype_mono lts); last done.
+ iIntros (????? Hel) "Hincl". by iDestruct (IH with "Hincl") as "($ & _)".
+ + iApply (struct_ltype_mono (@ltype_core _ _ +<$> lts)); last done.
+ iIntros (????? Hel) "Hincl".
+ apply elem_of_list_lookup_1 in Hel as (i & Hel).
+ destruct lt as [rt lt].
+ eapply hzipl_hmap_lookup_inv in Hel as (y & Hlook & ->).
+ apply elem_of_list_lookup_2 in Hlook.
+ eapply IH in Hlook.
+ iDestruct (Hlook with "Hincl") as "(_ & Ha)".
+ iApply "Ha".
+ - iIntros (rt def len lts IH r l b1 b2) "#Hincl".
+ simp_ltypes. iSplitL; (iApply array_ltype_mono; [ | done]).
+ + iIntros (????? Hel) "Hincl".
+ apply elem_of_interpret_iml_inv in Hel as [ -> | []].
+ { rewrite !ltype_own_ofty_unfold. by iApply lty_of_ty_mono. }
+ by iDestruct (IH with "Hincl") as "($ & _)".
+ + iIntros (????? Hel) "Hincl".
+ rewrite -ltype_core_ofty in Hel.
+ rewrite interpret_iml_fmap in Hel.
+ apply elem_of_list_fmap in Hel as (lt' & -> & Hel).
+ apply elem_of_interpret_iml_inv in Hel as [ -> | []].
+ { simp_ltypes. rewrite !ltype_own_ofty_unfold. by iApply lty_of_ty_mono. }
+ by iDestruct (IH with "Hincl") as "(_ & $)".
+ - iIntros (rt_cur rt_inner rt_full lt_cur lt_inner lt_full Cpre Cpost IH1 IH2 IH3 r l b1 b2) "#Hincl".
+ simp_ltypes.
+ iAssert (â–¡ (l â—â‚—[ Ï€, b1] r @ OpenedLtype lt_cur lt_inner lt_full Cpre Cpost -∗ l â—â‚—[ Ï€, b2] r @ OpenedLtype lt_cur lt_inner lt_full Cpre Cpost))%I as "#Ha"; first last.
+ { iSplitL; eauto with iFrame. }
+ iModIntro. destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->"; eauto.
+ + rewrite !ltype_own_opened_unfold /opened_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & Ha)".
+ done.
+ (*iExists ly. iFrame.*)
+ (*iDestruct (IH1 with "[]") as "(Hb & _)"; last by iApply "Hb". done.*)
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_opened_unfold /opened_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & Hb & Hstep)".
+ iExists ly. iFrame.
+ iApply (logical_step_wand with "Hstep"). iIntros "Hstep".
+ iIntros (P κs r0 r') "Hpre #Hincl' Hown Hvs".
+ iMod ("Hstep" with "Hpre [] Hown Hvs") as "(Ha & Hobs & Hpost)".
+ { iApply (big_sepL_wand with "Hincl'"). iApply big_sepL_intro.
+ iIntros "!>" (? κ' _) "#Hincl0". iApply lft_incl_trans; done. }
+ iModIntro. iFrame.
+ iIntros "Hdead Hobs".
+ rewrite !ltype_own_core_equiv.
+ iDestruct (IH3 with "[]") as "(_ & Hb)"; first last.
+ { iApply "Hb". iApply ("Hpost" with "Hdead Hobs"). }
+ iSplit; done.
+ - iIntros (rt_full κs lt_full IH r l b1 b2) "#Hincl".
+ simp_ltypes.
+ iSplitL; first last.
+ { iDestruct (IH with "Hincl") as "(_ & $)". }
+ destruct b1, b2; try done; unfold bor_kind_direct_incl.
+ + iDestruct "Hincl" as "->"; eauto.
+ + rewrite !ltype_own_coreable_unfold /coreable_ltype_own.
+ iIntros "(%ly & ? & ? & ? & Ha)".
+ iExists ly. iFrame. rewrite !ltype_own_core_equiv.
+ iDestruct (IH with "[]") as "(_ & Hb)"; last by iApply "Hb".
+ done.
+ + iDestruct "Hincl" as "(Hincl & ->)".
+ rewrite !ltype_own_coreable_unfold /coreable_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & Ha)".
+ iExists ly. iFrame.
+ iIntros "Hdead Hrfn". iMod ("Ha" with "Hdead Hrfn") as "Ha".
+ rewrite !ltype_own_core_equiv.
+ iDestruct (IH with "[]") as "(_ & Hb)"; last by iApply "Hb".
+ iSplit; done.
+ - iIntros (rt_cur rt_full lt_cur r_cur lt_full IH1 IH2 r l b1 b2) "#Hincl".
+ simp_ltypes. iSplitL; first last.
+ { iPoseProof (IH2 with "Hincl") as "(_ & Ha)". iApply "Ha". }
+ rewrite !ltype_own_shadowed_unfold /shadowed_ltype_own.
+ iIntros "(%Hst & Ha & Hb)". iSplitR; first done.
+ iSplitL "Ha". { iPoseProof (IH1 with "Hincl") as "(Ha1 & _)". by iApply "Ha1". }
+ iPoseProof (IH2 with "Hincl") as "(Ha1 & _)". by iApply "Ha1".
+Qed.
+Lemma ltype_bor_kind_direct_incl `{!typeGS Σ} {rt} (lt : ltype rt) b1 b2 π r l :
+ bor_kind_direct_incl b2 b1 -∗
+ (l â—â‚—[Ï€, b1] r @ lt -∗ l â—â‚—[Ï€, b2] r @ lt).
+Proof.
+ iIntros "Hincl". iDestruct (ltype_bor_kind_direct_incl' with "Hincl") as "($ & _)".
+Qed.
+Lemma ltype_own_shr_mono `{!typeGS Σ} {rt} (lt : ltype rt) l π r κ1 κ2 :
+ κ2 ⊑ κ1 -∗
+ l â—â‚—[Ï€, Shared κ1] r @ lt -∗
+ l â—â‚—[Ï€, Shared κ2] r @ lt.
+Proof.
+ iIntros "Hincl". iApply ltype_bor_kind_direct_incl. done.
+Qed.
+Lemma ltype_own_uniq_mono `{!typeGS Σ} {rt} (lt : ltype rt) l π r γ κ1 κ2 :
+ κ2 ⊑ κ1 -∗
+ l â—â‚—[Ï€, Uniq κ1 γ] r @ lt -∗
+ l â—â‚—[Ï€, Uniq κ2 γ] r @ lt.
+Proof.
+ iIntros "Hincl". iApply ltype_bor_kind_direct_incl. iSplitL; done.
+Qed.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ Lemma ltype_incl_syn_type {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ ltype_incl b r1 r2 lt1 lt2 -∗ ⌜ltype_st lt1 = ltype_st lt2âŒ.
+ Proof.
+ iIntros "(#$ & _)".
+ Qed.
+ Lemma ltype_incl_core {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ ltype_incl b r1 r2 lt1 lt2 -∗ ltype_incl b r1 r2 (ltype_core lt1) (ltype_core lt2).
+ Proof.
+ iIntros "(%Hst & _ & #Hi)".
+ iSplitR. { rewrite !ltype_core_syn_type_eq. done. }
+ iSplitR; iModIntro.
+ - done.
+ - rewrite !ltype_core_idemp. done.
+ Qed.
+
+
+
+ (** Owned Ptr *)
+ (* TODO subtyping rule for changing the b parameter? *)
+ Local Lemma owned_ptr_ltype_incl'_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) b κ' r1 r2 l1 l2 :
+ ltype_incl (Shared (κ')) r1 r2 lt1 lt2 -∗
+ ⌜l1 = l2⌠-∗
+ ltype_incl' (Shared κ') #(r1, l1) #(r2, l2) (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq ->".
+ iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & %r' & %l' & Hrfn & #Hb)".
+ iExists ly. iFrame.
+ iDestruct "Hrfn" as "%Heq". injection Heq as <- <-.
+ iExists r2, l2. iSplitR; first done.
+ iModIntro. iMod "Hb". iDestruct "Hb" as "(Hs & Hb)".
+ iDestruct "Heq" as "(_ & Heq & _)".
+ iModIntro. iFrame "Hs". iApply ("Heq" with "Hb").
+ Qed.
+ Lemma owned_ptr_ltype_incl_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) b κ' r1 r2 l1 l2 :
+ ltype_incl (Shared (κ')) r1 r2 lt1 lt2 -∗
+ ⌜l1 = l2⌠-∗
+ ltype_incl (Shared κ') #(r1, l1) #(r2, l2) (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply owned_ptr_ltype_incl'_shared_in; [ | done ]).
+ - done.
+ - iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma owned_ptr_ltype_incl'_shared {rt} (lt1 lt2 : ltype rt) b κ' r :
+ (∀ r, ltype_incl (Shared (κ')) r r lt1 lt2) -∗
+ ltype_incl' (Shared κ') r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq".
+ iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & %r' & %l' & Hrfn & #Hb)".
+ iExists ly. iFrame.
+ iExists _, _. iFrame.
+ iModIntro. iMod "Hb". iDestruct "Hb" as "(Hs & Hb)".
+ iDestruct ("Heq" $! _) as "(_ & Heq' & _)".
+ iModIntro. iFrame "Hs". iApply ("Heq'" with "Hb").
+ Qed.
+ Lemma owned_ptr_ltype_incl_shared {rt} (lt1 : ltype rt) (lt2 : ltype rt) b κ' r :
+ (∀ r, ltype_incl (Shared (κ')) r r lt1 lt2) -∗
+ ltype_incl (Shared κ') r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq".
+ iPoseProof (ltype_incl_syn_type _ inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply owned_ptr_ltype_incl'_shared).
+ - done.
+ - iIntros (?). iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma owned_ptr_ltype_incl'_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) b wl r1 r2 l1 l2 :
+ ltype_incl (Owned b) r1 r2 lt1 lt2 -∗
+ ⌜l1 = l2⌠-∗
+ ltype_incl' (Owned wl) #(r1, l1) #(r2, l2) (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq ->". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & ? & Hb)".
+ iModIntro.
+ iExists _. iFrame.
+ iDestruct "Hb" as "(%r' & %l' & Hrfn & Hb)".
+ iDestruct "Hrfn" as "%Heq". injection Heq as <- <-.
+ iExists _, _. iSplitR; first done. iNext.
+ iMod "Hb" as "(%ly' & Hl & ? & ? & Hb)".
+ iDestruct "Heq" as "(%Hly_eq & Heq & _)".
+ iExists ly'. rewrite Hly_eq. iFrame.
+ iMod ("Heq" with "Hb") as "Hb". eauto with iFrame.
+ Qed.
+ Lemma owned_ptr_ltype_incl_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) b l1 l2 wl r1 r2 :
+ ltype_incl (Owned b) r1 r2 lt1 lt2 -∗
+ ⌜l1 = l2⌠-∗
+ ltype_incl (Owned wl) #(r1, l1) #(r2, l2) (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply owned_ptr_ltype_incl'_owned_in; [ | done ]).
+ - done.
+ - iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma owned_ptr_ltype_incl'_owned {rt} (lt1 lt2 : ltype rt) b wl r :
+ (∀ r, ltype_incl (Owned b) r r lt1 lt2) -∗
+ ltype_incl' (Owned wl) r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & ? & Hb)".
+ iModIntro.
+ iExists _. iFrame.
+ iDestruct "Hb" as "(%r' & %l' & Hrfn & Hb)".
+ iExists _, _. iFrame "Hrfn". iNext.
+ iMod "Hb" as "(%ly' & Hl & ? & ? & Hb)".
+ iDestruct ("Heq" $! _) as "(%Hly_eq & Heq' & _)".
+ iExists ly'. rewrite Hly_eq. iFrame.
+ iMod ("Heq'" with "Hb") as "Hb". eauto with iFrame.
+ Qed.
+ Lemma owned_ptr_ltype_incl_owned {rt} (lt1 : ltype rt) (lt2 : ltype rt) b wl r :
+ (∀ r, ltype_incl (Owned b) r r lt1 lt2) -∗
+ ltype_incl (Owned wl) r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq".
+ iPoseProof (ltype_incl_syn_type _ inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply owned_ptr_ltype_incl'_owned).
+ - done.
+ - iIntros (?). iApply ltype_incl_core. done.
+ Qed.
+
+ (* Refinement subtyping under mutable references is restricted: we need to make sure that, no matter the future updates,
+ we can always get back to what the lender expects. Thus we loose all refinement information when descending below mutable references. *)
+ Local Lemma owned_ptr_ltype_incl'_uniq {rt} (lt1 lt2 : ltype rt) b κ r γ :
+ (∀ r, ltype_eq (Owned b) r r lt1 lt2) -∗
+ ltype_incl' (Uniq κ γ) r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_owned_ptr_unfold /owned_ptr_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & Hobs & Hb)".
+ iExists ly. iFrame.
+ iMod "Hb". iModIntro.
+ iApply (pinned_bor_iff with "[] [] Hb").
+ + iNext. iModIntro. iSplit; iIntros "(%r' & %l' & Hauth & Hb)";
+ iDestruct ("Heq" $! _) as "((%Hly_eq & Heq1 & _) & (_ & Heq2 & _))";
+ iExists _, _; rewrite Hly_eq; iFrame "Hauth".
+ all: iMod "Hb"; iDestruct "Hb" as "(%ly' & Hl & ? & ? & Hb)".
+ * iMod ("Heq1" with "Hb") as "Hb".
+ iModIntro. iExists _. iFrame.
+ * iMod ("Heq2" with "Hb") as "Hb".
+ iModIntro. iExists _. iFrame.
+ + iNext. iModIntro. iSplit; iIntros "(%r' & %l' & Hauth & Hb)";
+ iDestruct ("Heq" $! _) as "((%Hly_eq & _ & Heq1) & (_ & _ & Heq2))";
+ iExists _, _; rewrite Hly_eq; iFrame "Hauth".
+ all: iMod "Hb"; iDestruct "Hb" as "(%ly' & Hl & ? & ? & Hb)".
+ * rewrite !ltype_own_core_equiv. iMod ("Heq1" with "Hb") as "Hb".
+ iModIntro. iExists _. iFrame. rewrite ltype_own_core_equiv. done.
+ * rewrite !ltype_own_core_equiv. iMod ("Heq2" with "Hb") as "Hb".
+ iModIntro. iExists _. iFrame. rewrite ltype_own_core_equiv. done.
+ Qed.
+ Lemma owned_ptr_ltype_incl_uniq {rt} (lt1 lt2 : ltype rt) b κ r γ :
+ (∀ r, ltype_eq (Owned b) r r lt1 lt2) -∗
+ ltype_incl (Uniq κ γ) r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq".
+ iPoseProof (ltype_eq_syn_type _ inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply owned_ptr_ltype_incl'_uniq).
+ - done.
+ - iIntros (?). iApply ltype_eq_core. done.
+ Qed.
+
+ Lemma owned_ptr_ltype_incl {rt} (lt1 lt2 : ltype rt) b k r :
+ (∀ k r, ltype_eq k r r lt1 lt2) -∗
+ ltype_incl k r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq".
+ destruct k.
+ - iApply owned_ptr_ltype_incl_owned. iIntros (?). iDestruct ("Heq" $! _ _) as "[$ _]".
+ - iApply owned_ptr_ltype_incl_shared. iIntros (?). iDestruct ("Heq" $! _ _) as "[$ _]".
+ - iApply owned_ptr_ltype_incl_uniq. iIntros (?). done.
+ Qed.
+ Lemma owned_ptr_ltype_eq {rt} (lt1 lt2 : ltype rt) k b r :
+ (∀ k r, ltype_eq k r r lt1 lt2) -∗
+ ltype_eq k r r (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ iIntros "#Heq".
+ iSplit.
+ - iApply owned_ptr_ltype_incl; done.
+ - iApply owned_ptr_ltype_incl. iIntros (??). iApply ltype_eq_sym. done.
+ Qed.
+
+ Lemma owned_ptr_full_subltype E L {rt} (lt1 lt2 : ltype rt) b :
+ full_eqltype E L lt1 lt2 →
+ full_subltype E L (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ intros Hsub.
+ iIntros (qL) "HL #CTX #HE". iIntros (??).
+ iPoseProof (Hsub with "HL CTX HE") as "Hsub".
+ iApply (owned_ptr_ltype_incl with "Hsub").
+ Qed.
+ Lemma owned_ptr_full_eqltype E L {rt} (lt1 lt2 : ltype rt) b :
+ full_eqltype E L lt1 lt2 →
+ full_eqltype E L (OwnedPtrLtype lt1 b) (OwnedPtrLtype lt2 b).
+ Proof.
+ intros Hsub.
+ apply full_subltype_eqltype; eapply owned_ptr_full_subltype; naive_solver.
+ Qed.
+
+ (** Box *)
+ (* Admitted because the proofs are very similar to OwnedPtr and they are going to be removed soon when Box is no longer a primitive but defined in terms of OwnedPtr. *)
+ Local Lemma box_ltype_incl'_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ' r1 r2 :
+ ltype_incl (Shared (κ')) r1 r2 lt1 lt2 -∗
+ ltype_incl' (Shared κ') #(r1) #(r2) (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+ Lemma box_ltype_incl_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ' r1 r2 :
+ ltype_incl (Shared (κ')) r1 r2 lt1 lt2 -∗
+ ltype_incl (Shared κ') #(r1) #(r2) (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+
+ Local Lemma box_ltype_incl'_shared {rt} (lt1 lt2 : ltype rt) κ' r :
+ (∀ r, ltype_incl (Shared (κ')) r r lt1 lt2) -∗
+ ltype_incl' (Shared κ') r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+ Lemma box_ltype_incl_shared {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ' r :
+ (∀ r, ltype_incl (Shared (κ')) r r lt1 lt2) -∗
+ ltype_incl (Shared κ') r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+
+ Local Lemma box_ltype_incl'_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl r1 r2 :
+ ltype_incl (Owned true) r1 r2 lt1 lt2 -∗
+ ltype_incl' (Owned wl) #(r1) #(r2) (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+ Lemma box_ltype_incl_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl r1 r2 :
+ ltype_incl (Owned true) r1 r2 lt1 lt2 -∗
+ ltype_incl (Owned wl) #(r1) #(r2) (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+
+ Local Lemma box_ltype_incl'_owned {rt} (lt1 lt2 : ltype rt) wl r :
+ (∀ r, ltype_incl (Owned true) r r lt1 lt2) -∗
+ ltype_incl' (Owned wl) r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+ Lemma box_ltype_incl_owned {rt} (lt1 : ltype rt) (lt2 : ltype rt) wl r :
+ (∀ r, ltype_incl (Owned true) r r lt1 lt2) -∗
+ ltype_incl (Owned wl) r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+
+
+ (* Refinement subtyping under mutable references is restricted: we need to make sure that, no matter the future updates,
+ we can always get back to what the lender expects. Thus we loose all refinement information when descending below mutable references. *)
+ Local Lemma box_ltype_incl'_uniq {rt} (lt1 lt2 : ltype rt) κ r γ :
+ (∀ r, ltype_eq (Owned true) r r lt1 lt2) -∗
+ ltype_incl' (Uniq κ γ) r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+ Lemma box_ltype_incl_uniq {rt} (lt1 lt2 : ltype rt) κ r γ :
+ (∀ r, ltype_eq (Owned true) r r lt1 lt2) -∗
+ ltype_incl (Uniq κ γ) r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+
+ Lemma box_ltype_incl {rt} (lt1 lt2 : ltype rt) k r :
+ (∀ k r, ltype_eq k r r lt1 lt2) -∗
+ ltype_incl k r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+ Lemma box_ltype_eq {rt} (lt1 lt2 : ltype rt) k r :
+ (∀ k r, ltype_eq k r r lt1 lt2) -∗
+ ltype_eq k r r (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ Admitted.
+
+ Lemma box_full_subltype E L {rt} (lt1 lt2 : ltype rt) :
+ full_eqltype E L lt1 lt2 →
+ full_subltype E L (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ intros Hsub.
+ iIntros (qL) "HL #CTX #HE". iIntros (??).
+ iPoseProof (Hsub with "HL CTX HE") as "Hsub".
+ iApply (box_ltype_incl with "Hsub").
+ Qed.
+ Lemma box_full_eqltype E L {rt} (lt1 lt2 : ltype rt) :
+ full_eqltype E L lt1 lt2 →
+ full_eqltype E L (BoxLtype lt1) (BoxLtype lt2).
+ Proof.
+ intros Hsub.
+ apply full_subltype_eqltype; eapply box_full_subltype; naive_solver.
+ Qed.
+ (* TODO subtyping for OpenedLtype and CoreableLtype? *)
+End subtype.
+
+Section accessors.
+ Context `{typeGS Σ}.
+
+ Lemma shadowed_ltype_acc_cur {rt_cur rt_full} (lt_cur : ltype rt_cur) (lt_full : ltype rt_full) (r_cur : place_rfn rt_cur) l π b r :
+ l â—â‚—[Ï€, b] r @ ShadowedLtype lt_cur r_cur lt_full -∗
+ l â—â‚—[Ï€, b] r_cur @ lt_cur ∗
+ (∀ (rt_cur' : Type) (lt_cur' : ltype rt_cur') (r_cur' : place_rfn rt_cur'),
+ ⌜ltype_st lt_cur = ltype_st lt_cur'⌠-∗
+ l â—â‚—[Ï€, b] r_cur' @ lt_cur' -∗
+ l â—â‚—[Ï€, b] r @ ShadowedLtype lt_cur' (r_cur') lt_full).
+ Proof.
+ rewrite ltype_own_shadowed_unfold /shadowed_ltype_own.
+ iIntros "(%Hst & Hcur & Hfull)". iFrame.
+ iIntros (rt_cur' lt_cur' r_cur' Hst') "Hb".
+ rewrite ltype_own_shadowed_unfold /shadowed_ltype_own.
+ iFrame. rewrite -Hst. done.
+ Qed.
+
+ Lemma opened_ltype_create_uniq_simple π {rt_cur rt_full} (lt_cur : ltype rt_cur) (lt_full : ltype rt_full) r l κ κ' γ (r1 r2 : rt_full) q C n R :
+ ltype_st lt_cur = ltype_st lt_full →
+ gvar_obs γ r1 -∗
+ gvar_auth γ r2 -∗
+ £ 1 -∗
+ atime n -∗
+ κ ⊑ κ' -∗
+ (q.[κ] ={lftE}=∗ R) -∗
+ (∀ K', ▷ (K' -∗ [†κ'] ={lft_userE}=∗ ▷ C) -∗ £ 1 -∗ ▷ K' ={lftE}=∗ &pin{ κ' }[C] K' ∗ q.[κ]) -∗
+ (â–¡ ∀ r, gvar_auth γ r -∗ (|={lftE}=> l â—â‚—[Ï€, Owned false] #r @ ltype_core lt_full) -∗ C) -∗
+ (∀ r, gvar_obs γ r -∗ atime n -∗ £ (num_laters_per_step n) -∗ &pin{κ} [C] C ={lftE}=∗ l â—â‚—[ Ï€, Uniq κ γ] # r @ ltype_core lt_full) -∗
+ l â—â‚—[Ï€, Owned false] r @ lt_cur -∗
+ l â—â‚—[Ï€, Uniq κ γ] r @ (OpenedLtype lt_cur lt_full lt_full (λ r1 r2, ⌜r1 = r2âŒ) (λ r1 r2, R)).
+ Proof.
+ (* TODO this is to a large degree duplicated with the existential unfolding lemma.
+ Can we deduplicate this somewhow?
+ Main obstacle: we have different pre/postconditions.
+ Option 1: allow updating the pre/postcondition of an OpenedLtype
+ challenge: update lt_inner. need lt_inner' ==∗ lt_inner, but that does not hold in our case.
+ can we change the definition of opened_ltype a bit to allow that?
+ Option 2: make the unfolding lemma more flexible directly
+ *)
+ iIntros (Hst_eq) "Hobs Hauth Hcred Hat #? HR Hcl #HC Ha Hcur".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iPoseProof (ltype_own_has_layout with "Hcur") as "(%ly & %Hst & %Hly)".
+ iPoseProof (ltype_own_loc_in_bounds with "Hcur") as "#Hlb"; first done.
+ iExists ly. do 5 iR. iFrame.
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "Hcred' Hat". iModIntro.
+ iIntros (Hown κs r0 r0') "Hpre #Hincl' Hown #Hub".
+ iMod (gvar_update with "Hauth Hobs") as "(Hauth & $)".
+
+ iAssert (□ ([†κ'] ={lftE}=∗ lft_dead_list κs))%I as "#Hkill".
+ { iModIntro. iIntros "#Hdead".
+ iApply big_sepL_fupd. iApply (big_sepL_wand with "Hincl'"). iApply big_sepL_intro.
+ iIntros "!>" (? κ0 _) "#Hincl0".
+ iApply (lft_incl_dead with "[] Hdead"); first done.
+ iApply lft_incl_trans; done. }
+
+ (* close the borrow *)
+ set (V := (gvar_auth γ r0' ∗ Hown Ï€ r0 l ∗ (lft_dead_list κs ={lftE}=∗ ⌜r0 = r0'âŒ))%I).
+ iMod ("Hcl" $! V with "[HC] Hcred [Hauth Hown Hpre]") as "(Hb & Htok)".
+ { iNext. iIntros "(Hauth & Hown &Heq) #Hdead".
+ iModIntro. iNext. iApply ("HC" with "Hauth").
+ iMod ("Hkill" with "Hdead") as "#Hdead'".
+ iMod ("Heq" with "Hdead'") as "<-".
+ iMod ("Hub" with "Hdead' Hown") as "Hown".
+ rewrite ltype_own_core_equiv. done. }
+ { iNext. rewrite /V. iFrame. }
+ iMod ("HR" with "Htok") as "$".
+ iModIntro. iIntros "#Hdead Hobs".
+ iApply (ltype_own_core_equiv).
+ iSpecialize ("Hub" with "Hdead").
+ iPoseProof (pinned_bor_shorten κ κ' with "[//] Hb") as "Hb".
+ iApply ("Ha" with "Hobs Hat Hcred' [Hb]").
+ (* bring the pinned bor in the right shape *)
+ iApply (pinned_bor_impl with "[] Hb").
+ iNext. iModIntro. iSplit; first last. { eauto. }
+ iIntros "(Hauth & Hown & Hk)".
+ iApply ("HC" with "Hauth").
+ iMod ("Hk" with "Hdead") as "<-".
+ rewrite ltype_own_core_equiv. by iApply "Hub".
+ Qed.
+
+ Lemma ofty_ltype_acc_owned {rt} F π (ty : type rt) (r : rt) wl l :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned wl] PlaceIn r @ (â— ty) -∗
+ ∃ ly, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗ ty_sidecond ty ∗ loc_in_bounds l 0 (ly_size ly) ∗ |={F}=>
+ ∃ v : val, l ↦ v ∗ v â—áµ¥{Ï€} r @ ty ∗
+ logical_step F
+ (∀ v2 rt2 (ty2 : type rt2) (r2 : rt2),
+ l ↦ v2 -∗
+ ⌜ty.(ty_syn_type) = ty2.(ty_syn_type)⌠-∗
+ ty_sidecond ty2 -∗
+ (â–·?wl v2 â—áµ¥{Ï€} r2 @ ty2) ={F}=∗
+ l â—â‚—[Ï€, Owned wl] PlaceIn r2 @ (â— ty2)).
+ Proof.
+ iIntros (?) "Hb". rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcred & %r' & Hrfn & Hv)".
+ iExists ly. iFrame "% #".
+ iMod (maybe_use_credit with "Hcred Hv") as "(Hcred & Hat & Hv)"; first done.
+ iDestruct "Hv" as "(%v & Hl & Hv)".
+ iDestruct "Hrfn" as "<-".
+ iModIntro. iExists v. iFrame.
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred' !>". iIntros (v2 rt2 ty2 r2) "Hl %Hst_eq Hsc' Hv".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iModIntro. rewrite -Hst_eq. iExists ly. iFrame "#∗%".
+ iExists _. iSplitR; first done.
+ iNext. eauto with iFrame.
+ Qed.
+
+ Lemma ofty_ltype_acc_uniq {rt} F π (ty : type rt) (r : rt) κ γ l R q :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ (q.[κ] ={lftE}=∗ R) -∗
+ l â—â‚—[Ï€, Uniq κ γ] #r @ (â— ty) -∗
+ ∃ ly, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗ loc_in_bounds l 0 (ly_size ly) ∗ |={F}=>
+ ∃ v : val, l ↦ v ∗ v â—áµ¥{Ï€} r @ ty ∗
+ logical_step F
+ ((* weak update *)
+ (∀ v2 (r2 : rt),
+ l ↦ v2 -∗
+ (â–· v2 â—áµ¥{Ï€} r2 @ ty) ={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] #r2 @ (â— ty) ∗ R) ∧
+ (* strong update *)
+ (∀ v2 rt2 (ty2 : type rt2) (r2 : rt2),
+ l ↦ v2 -∗
+ ty_sidecond ty2 -∗
+ (v2 â—áµ¥{Ï€} r2 @ ty2) -∗
+ ⌜ty_syn_type ty = ty_syn_type ty2⌠={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] #(r2) @ OpenedLtype (â—ty2) (â—ty) (â—ty) (λ r1 r1', ⌜r1 = r1'âŒ) (λ _ _, R))).
+ Proof.
+ iIntros (?) "#(LFT & TIME & LLCTX) Htok HclR Hb". rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcred & Hat & Hobs & Hb)".
+ iExists ly. iFrame "%#".
+ iMod (fupd_mask_subseteq lftE) as "HF_cl"; first done.
+ iMod "Hb" as "Hb".
+ iMod (pinned_bor_acc_strong lftE with "LFT Hb Htok") as "(%κ' & #Hinclκ & Hb & Hvcl & Hcl)"; first done.
+ iMod "HF_cl" as "_".
+ iDestruct "Hcred" as "[Hcred1 Hcred]".
+ iApply (lc_fupd_add_later with "Hcred1"); iNext.
+ iDestruct "Hb" as "(%r' & Hauth & Hb)".
+ iMod (fupd_mask_mono lftE with "Hb") as "(%v & Hl & Hv)"; first done.
+ iPoseProof (gvar_agree with "Hauth Hobs") as "#->".
+ iModIntro. iExists _. iFrame.
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "Hcred' Hat !>". iSplit.
+ - iIntros (v2 r2) "Hl Hv".
+ iMod (gvar_update r2 with "Hauth Hobs") as "(Hauth & Hobs)".
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iMod (fupd_mask_mono with "(Hcl Hvcl Hcred1 [Hauth Hv Hl])") as "(Hb & Htok)"; first done.
+ { iNext. eauto with iFrame. }
+ iMod (fupd_mask_mono with "(HclR Htok)") as "$"; first done.
+ iModIntro. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iFrame "#∗%". iApply pinned_bor_shorten; done.
+ (* TODO maybe provide excess credits *)
+ - iIntros (v2 rt2 ty2 r2) "Hl #Hsc2 Hv %Hst". iModIntro.
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iApply (opened_ltype_create_uniq_simple with "Hobs Hauth Hcred1 Hat Hinclκ HclR Hcl [] [Hcred']"); first done.
+ { iModIntro. iIntros (?) "Hauth Hc". iExists _. iFrame. simp_ltypes.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hc" as ">(%ly' & % & % & _ & _ & _ & %r' & -> & >Hb)". eauto. }
+ { iIntros (?) "Hobs Hat Hcred Hp". simp_ltypes.
+ iModIntro. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ eauto 8 with iFrame. }
+ { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ rewrite -Hst. iExists _. do 5 iR. iExists _. iR.
+ iNext. eauto 8 with iFrame. }
+ Qed.
+
+ Lemma ofty_ltype_acc_shared {rt} F π (ty : type rt) (r : rt) κ l :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Shared κ] PlaceIn r @ (â— ty) -∗
+ ∃ ly, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗ loc_in_bounds l 0 (ly_size ly) ∗ |={F}=>
+ l â—â‚—{Ï€, κ} r @ ty.
+ Proof.
+ iIntros (?) "Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & %r' & <- & #Hb)".
+ iExists ly. iFrame "%#". iApply (fupd_mask_mono with "Hb"). done.
+ Qed.
+
+ (* TODO: accessors for shared refs *)
+
+ Lemma opened_ltype_acc_owned π {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost l wl r :
+ l â—â‚—[Ï€, Owned wl] r @ OpenedLtype lt_cur lt_inner lt_full Cpre Cpost -∗
+ l â—â‚—[Ï€, Owned false] r @ lt_cur ∗
+ (∀ rt_cur' (lt_cur' : ltype rt_cur') r',
+ l â—â‚—[Ï€, Owned false] r' @ lt_cur' -∗
+ ⌜ltype_st lt_cur' = ltype_st lt_cur⌠-∗
+ l â—â‚—[Ï€, Owned wl] r' @ OpenedLtype lt_cur' lt_inner lt_full Cpre Cpost).
+ Proof.
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & $ & Hcl)".
+ iIntros (rt_cur' lt_cur' r') "Hown %Hst".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iExists ly. rewrite Hst. eauto with iFrame.
+ Qed.
+ Lemma opened_ltype_acc_uniq π {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost l κ γ r :
+ l â—â‚—[Ï€, Uniq κ γ] r @ OpenedLtype lt_cur lt_inner lt_full Cpre Cpost -∗
+ l â—â‚—[Ï€, Owned false] r @ lt_cur ∗
+ (∀ rt_cur' (lt_cur' : ltype rt_cur') r',
+ l â—â‚—[Ï€, Owned false] r' @ lt_cur' -∗
+ ⌜ltype_st lt_cur' = ltype_st lt_cur⌠-∗
+ l â—â‚—[Ï€, Uniq κ γ] r' @ OpenedLtype lt_cur' lt_inner lt_full Cpre Cpost).
+ Proof.
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & $ & Hcl)".
+ iIntros (rt_cur' lt_cur' r') "Hown %Hst".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iExists ly. rewrite Hst. eauto with iFrame.
+ Qed.
+
+End accessors.
+
+
+Section open.
+ Context `{!typeGS Σ}.
+
+ Lemma ltype_own_make_alias wl' {rt rt2} (lt : ltype rt) r r2 π wl l :
+ l â—â‚—[Ï€, Owned wl] r @ lt -∗
+ maybe_creds wl' -∗
+ l â—â‚—[Ï€, Owned wl] r @ lt ∗ l â—â‚—[Ï€, Owned wl'] r2 @ AliasLtype rt2 (ltype_st lt) l.
+ Proof.
+ iIntros "Hl Hcreds".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Halg & %Hly)".
+ iPoseProof (ltype_own_loc_in_bounds with "Hl") as "#Hlb"; first done.
+ iFrame. rewrite ltype_own_alias_unfold /alias_lty_own.
+ eauto 8 with iFrame.
+ Qed.
+
+
+ (* TODO move /generalize. We can also use this for the stratify-unfold things. *)
+ (* TODO can we design it so that we can also use it for the place instances? *)
+ Definition ltype_owned_openable {rt} (lt : ltype rt) : Prop :=
+ ∀ π r l wl,
+ l â—â‚—[Ï€, Owned wl] r @ lt -∗
+ (* TODO can we just have a later instead of the logstep? *)
+ maybe_creds wl ∗ (â–·?wl (l â—â‚—[Ï€, Owned false] r @ lt)).
+ Definition ltype_uniq_openable {rt} (lt : ltype rt) : Prop :=
+ ∀ F κ γ π r l q κs,
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ (q.[κ] ={lftE}=∗ llft_elt_toks κs) -∗
+ l â—â‚—[Ï€, Uniq κ γ] r @ lt -∗ |={F}=>
+ (l â—â‚—[Ï€, Uniq κ γ] r @ OpenedLtype lt lt lt (λ ri ri', ⌜ri = ri'âŒ) (λ ri ri', llft_elt_toks κs)).
+ Lemma ltype_owned_openable_elim_logstep {rt} (lt : ltype rt) F π r l wl :
+ ltype_owned_openable lt →
+ l â—â‚—[Ï€, Owned wl] r @ lt -∗
+ |={F}=> l â—â‚—[Ï€, Owned false] r @ lt ∗ logical_step F (maybe_creds wl).
+ Proof.
+ iIntros (Hopen) "Hb". iPoseProof (Hopen with "Hb") as "(Hcred & Hb)".
+ destruct wl.
+ - iDestruct "Hcred" as "([Hcred1 Hcred] & Hat)".
+ iMod (lc_fupd_elim_later with "Hcred1 Hb") as "$".
+ iApply (logical_step_intro_atime with "Hat").
+ iModIntro. by iIntros "$ $".
+ - iFrame. iApply logical_step_intro. done.
+ Qed.
+
+ (** Lemmas for ofty *)
+ Lemma ltype_owned_openable_ofty {rt} (ty : type rt) :
+ ltype_owned_openable (â— ty)%I.
+ Proof.
+ iIntros (Ï€ r l wl) "Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & Hcred & %r' & ? & Hb)".
+ iFrame. iNext. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ eauto 8 with iFrame.
+ Qed.
+ Lemma ltype_uniq_openable_ofty {rt} (ty : type rt) :
+ ltype_uniq_openable (â— ty)%I.
+ Proof.
+ iIntros (? κ γ π r l q κs ?) "#(LFT & TIME & LLCTX) Htok Hcl_tok Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & % & % & #? & #? & (Hcred1 & Hcred) & Hat & Hrfn & Hb)".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod "Hb".
+ iMod (pinned_bor_acc_strong lftE with "LFT Hb Htok") as "(%κ' & #Hincl & Hb & ? & Hcl_b)"; first done.
+ iMod "Hcl_F" as "_".
+ iApply (lc_fupd_add_later with "Hcred1"). iNext.
+ iDestruct "Hb" as "(%r' & Hauth & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ iDestruct "Hb" as "(%v & Hl & Hv)".
+ iModIntro.
+
+ iPoseProof (place_rfn_interp_mut_owned with "Hrfn Hauth") as "(Hrfn & Hobs & Hauth)".
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iApply (opened_ltype_create_uniq_simple with "Hobs Hauth Hcred1 Hat Hincl Hcl_tok Hcl_b [] []").
+ - done.
+ - iModIntro. iIntros (r0) "Hauth Hb". iExists r0. iFrame.
+ iMod "Hb" as "Hb". simp_ltypes.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & ? & ? & ? & ? & ? & %r0' & <- & $)".
+ - iIntros (r0) "Hobs Hat Hcred Hb".
+ iModIntro. simp_ltypes.
+ rewrite (ltype_own_ofty_unfold _ (Uniq _ _)) /lty_of_ty_own.
+ iExists ly. do 4 iR. by iFrame.
+ - rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iR. iR. iR. iR. iR. iExists _. iFrame.
+ iModIntro. eauto with iFrame.
+ Qed.
+
+End open.
+
+Section deinit.
+ Context `{!typeGS Σ}.
+
+ (* TODO seem to be redundant. Rather use the stronger extractable stuff *)
+ Lemma ltype_uniq_deinitializable_deinit_mut F π l st {rt} (lt : ltype rt) r κ γ wl :
+ lftE ⊆ F →
+ ltype_uniq_deinitializable lt →
+ syn_type_compat PtrSynType st →
+ (l â—â‚—[Ï€, Owned wl] #(r, γ) @ (MutLtype lt κ)) ={F}=∗
+ l â—â‚—[Ï€, Owned false] #() @ (â— uninit st) ∗ place_rfn_interp_mut r γ.
+ Proof.
+ iIntros (? Hdeinit Hcompat).
+ iIntros "Hl".
+ rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hlb & Hcred & %γ' & %r' & %Heq & Hb)".
+ injection Heq as <- <-.
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hc)"; first done.
+ iDestruct "Hc" as "(%l' & Hl & Hb)".
+ iMod (ltype_own_deinit_ghost_drop_uniq with "Hb") as "Hrfn"; [done.. | ].
+ iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. iExists ly.
+ iSplitR. { destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ simpl. iPureIntro. eapply syn_type_has_layout_make_untyped; last done.
+ by eapply syn_type_has_layout_inj. }
+ iR. iSplitR. { rewrite /ty_own_val/=//. }
+ iFrame. iR. iExists tt. iR. iModIntro. iExists _. iFrame.
+ rewrite uninit_own_spec. iExists ly.
+ apply syn_type_has_layout_ptr_inv in Halg as ->. iSplitR; last done.
+ iPureIntro. destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ specialize (syn_type_has_layout_ptr_inv _ Hst') as ->.
+ eapply syn_type_has_layout_make_untyped; done.
+ Qed.
+
+ (* TODO try to find a good way to unify with previous lemma *)
+ Lemma ltype_uniq_deinitializable_deinit_mut' F π l st {rt} (lt : ltype rt) r κ γ wl :
+ lftE ⊆ F →
+ ltype_uniq_deinitializable lt →
+ syn_type_compat PtrSynType st →
+ £ (Nat.b2n wl) -∗
+ (l â—â‚—[Ï€, Owned wl] #(r, γ) @ (MutLtype lt κ)) ={F}=∗
+ l â—â‚—[Ï€, Owned wl] #() @ (â— uninit st) ∗ place_rfn_interp_mut r γ.
+ Proof.
+ iIntros (? Hdeinit Hcompat).
+ iIntros "Hcred' Hl".
+ rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hlb & Hcred & %γ' & %r' & %Heq & Hb)".
+ injection Heq as <- <-.
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hc)"; first done.
+ iDestruct "Hc" as "(%l' & Hl & Hb)".
+ iMod (ltype_own_deinit_ghost_drop_uniq with "Hb") as "Hrfn"; [done.. | ].
+ iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. iExists ly.
+ iSplitR. { destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ simpl. iPureIntro. eapply syn_type_has_layout_make_untyped; last done.
+ by eapply syn_type_has_layout_inj. }
+ iR. iSplitR. { rewrite /ty_own_val/=//. }
+ iFrame. iSplitR "Hl".
+ { iModIntro. destruct wl; last done. simpl. rewrite /num_cred. iFrame. iApply lc_succ; iFrame. }
+ iExists tt. iR. iModIntro. iExists _. iFrame.
+ rewrite uninit_own_spec. iExists ly.
+ apply syn_type_has_layout_ptr_inv in Halg as ->. iSplitR; last done.
+ iPureIntro. destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ specialize (syn_type_has_layout_ptr_inv _ Hst') as ->.
+ eapply syn_type_has_layout_make_untyped; done.
+ Qed.
+
+ Lemma ltype_uniq_extractable_deinit_mut F π l st {rt} (lt : ltype rt) r κ κm γ wl :
+ lftE ⊆ F →
+ ltype_uniq_extractable lt = Some κm →
+ syn_type_compat PtrSynType st →
+ (l â—â‚—[Ï€, Owned wl] #(r, γ) @ (MutLtype lt κ)) ={F}=∗
+ l â—â‚—[Ï€, Owned false] #() @ (â— uninit st) ∗ MaybeInherit κm InheritGhost (place_rfn_interp_mut r γ).
+ Proof.
+ iIntros (? Hdeinit Hcompat).
+ iIntros "Hl".
+ rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hlb & Hcred & %γ' & %r' & %Heq & Hb)".
+ injection Heq as <- <-.
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hc)"; first done.
+ iDestruct "Hc" as "(%l' & Hl & Hb)".
+ iMod (ltype_own_extract_ghost_drop_uniq with "Hb") as "Hrfn"; [done.. | ].
+ iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. iExists ly.
+ iSplitR. { destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ simpl. iPureIntro. eapply syn_type_has_layout_make_untyped; last done.
+ by eapply syn_type_has_layout_inj. }
+ iR. iSplitR. { rewrite /ty_own_val/=//. }
+ iFrame. iR. iExists tt. iR. iModIntro. iExists _. iFrame.
+ rewrite uninit_own_spec. iExists ly.
+ apply syn_type_has_layout_ptr_inv in Halg as ->. iSplitR; last done.
+ iPureIntro. destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ specialize (syn_type_has_layout_ptr_inv _ Hst') as ->.
+ eapply syn_type_has_layout_make_untyped; done.
+ Qed.
+
+ (* TODO try to find a good way to unify with previous lemma *)
+ Lemma ltype_uniq_extractable_deinit_mut' F π l st {rt} (lt : ltype rt) r κ κm γ wl :
+ lftE ⊆ F →
+ ltype_uniq_extractable lt = Some κm →
+ syn_type_compat PtrSynType st →
+ £ (Nat.b2n wl) -∗
+ (l â—â‚—[Ï€, Owned wl] #(r, γ) @ (MutLtype lt κ)) ={F}=∗
+ l â—â‚—[Ï€, Owned wl] #() @ (â— uninit st) ∗ MaybeInherit κm InheritGhost (place_rfn_interp_mut r γ).
+ Proof.
+ iIntros (? Hdeinit Hcompat).
+ iIntros "Hcred' Hl".
+ rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hlb & Hcred & %γ' & %r' & %Heq & Hb)".
+ injection Heq as <- <-.
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hc)"; first done.
+ iDestruct "Hc" as "(%l' & Hl & Hb)".
+ iMod (ltype_own_extract_ghost_drop_uniq with "Hb") as "Hrfn"; [done.. | ].
+ iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. iExists ly.
+ iSplitR. { destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ simpl. iPureIntro. eapply syn_type_has_layout_make_untyped; last done.
+ by eapply syn_type_has_layout_inj. }
+ iR. iSplitR. { rewrite /ty_own_val/=//. }
+ iFrame. iSplitR "Hl".
+ { iModIntro. destruct wl; last done. simpl. rewrite /num_cred. iFrame. iApply lc_succ; iFrame. }
+ iExists tt. iR. iModIntro. iExists _. iFrame.
+ rewrite uninit_own_spec. iExists ly.
+ apply syn_type_has_layout_ptr_inv in Halg as ->. iSplitR; last done.
+ iPureIntro. destruct Hcompat as [<- | (ly1 & Hst' & ->)]; first done.
+ specialize (syn_type_has_layout_ptr_inv _ Hst') as ->.
+ eapply syn_type_has_layout_make_untyped; done.
+ Qed.
+
+ Lemma ltype_deinit_shr F π l st {rt} (lt : ltype rt) r κ wl :
+ lftE ⊆ F →
+ syn_type_compat PtrSynType st →
+ (l â—â‚—[Ï€, Owned wl] r @ (ShrLtype lt κ)) ={F}=∗
+ l â—â‚—[Ï€, Owned false] #() @ (â— uninit st).
+ Proof.
+ iIntros (? Hstcomp) "Hl".
+ rewrite ltype_own_shr_ref_unfold /shr_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & % & ? & Hcreds & %r' & ? & Hb)".
+ iMod (maybe_use_credit with "Hcreds Hb") as "(? & ? & %l' & Hl & Hb)"; first done.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iModIntro. iExists ly. simpl. iSplitR.
+ { destruct Hstcomp as [<- | (ly1 & Hst' & ->)]; first done.
+ simpl. iPureIntro. eapply syn_type_has_layout_make_untyped; last done.
+ by eapply syn_type_has_layout_inj. }
+ iR. iR. iFrame. iR. iExists tt. iR.
+ iModIntro. iExists l'. iFrame. rewrite uninit_own_spec. iExists ly.
+ apply syn_type_has_layout_ptr_inv in Halg as ->. iSplitR; last done.
+ iPureIntro. destruct Hstcomp as [<- | (ly1 & Hst' & ->)]; first done.
+ specialize (syn_type_has_layout_ptr_inv _ Hst') as ->.
+ eapply syn_type_has_layout_make_untyped; done.
+ Qed.
+
+ Lemma ltype_deinit_shr' F π l st {rt} (lt : ltype rt) r κ wl :
+ lftE ⊆ F →
+ syn_type_compat PtrSynType st →
+ £ (Nat.b2n wl) -∗
+ (l â—â‚—[Ï€, Owned wl] r @ (ShrLtype lt κ)) ={F}=∗
+ l â—â‚—[Ï€, Owned wl] #() @ (â— uninit st).
+ Proof.
+ iIntros (? Hstcomp) "Hcred Hl".
+ rewrite ltype_own_shr_ref_unfold /shr_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & % & ? & Hcreds & %r' & ? & Hb)".
+ iMod (maybe_use_credit with "Hcreds Hb") as "(? & ? & %l' & Hl & Hb)"; first done.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iModIntro. iExists ly. simpl. iSplitR.
+ { destruct Hstcomp as [<- | (ly1 & Hst' & ->)]; first done.
+ simpl. iPureIntro. eapply syn_type_has_layout_make_untyped; last done.
+ by eapply syn_type_has_layout_inj. }
+ iR. iR. iFrame. iSplitR "Hl".
+ { destruct wl; last done. simpl. rewrite /num_cred. iFrame. iApply lc_succ; iFrame. }
+ iExists tt. iR.
+ iModIntro. iExists l'. iFrame. rewrite uninit_own_spec. iExists ly.
+ apply syn_type_has_layout_ptr_inv in Halg as ->. iSplitR; last done.
+ iPureIntro. destruct Hstcomp as [<- | (ly1 & Hst' & ->)]; first done.
+ specialize (syn_type_has_layout_ptr_inv _ Hst') as ->.
+ eapply syn_type_has_layout_make_untyped; done.
+ Qed.
+End deinit.
diff --git a/theories/rust_typing/ltypes.v b/theories/rust_typing/ltypes.v
new file mode 100644
index 0000000000000000000000000000000000000000..142d4e1c6ebb75e002f4668123c9fed77aedaa2e
--- /dev/null
+++ b/theories/rust_typing/ltypes.v
@@ -0,0 +1,4765 @@
+From Equations Require Import Equations.
+From iris.bi Require Export fractional.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From caesium Require Export proofmode notation.
+From caesium Require Import derived.
+From lrust.lifetime Require Export frac_borrow.
+From refinedrust Require Export hlist.
+From refinedrust Require Export base lft_contexts gvar_refinement type uninit_def.
+
+From iris Require Import options.
+
+(** * Place types *)
+
+(* TODO move *)
+Lemma maybe_later_mono {Σ} (P : iProp Σ) b : ▷?b P -∗ ▷ P.
+Proof.
+ iIntros "P". by iPoseProof (bi.laterN_le _ 1 with "P") as "P"; first (destruct b; simpl; lia).
+Qed.
+
+(** bor_kind *)
+Section ltype.
+Context `{typeGS Σ}.
+
+(**
+ A [bor_kind] determines which ownership we have of an ltype.
+ [Owned with_later] says that we fully own it, where inner ownership is optionally guarded by a later.
+ + the [with_later = true] case is needed for Box types, which need to guard their inner type to enable recursive types.
+ + the [with_later = false] case is needed for top-level ownership of places in the typing context (for modelling stack places).
+ [Shared κ] says that we have shared ownership at lifetime κ.
+ [Uniq κ γ] says that we own it under a mutable borrow at lifetime κ, where γ is the ghost variable for the mutable reference. This is needed for properly nesting the refinements of mutable references.
+ *)
+Inductive bor_kind :=
+ | Owned (with_later : bool) | Shared (κ : lft) | Uniq (κ : lft) (γ : gname).
+Global Instance bor_kind_inhabited : Inhabited bor_kind := populate (Owned false).
+
+Definition lctx_bor_kind_alive (E : elctx) (L : llctx) (b : bor_kind) :=
+ match b with
+ | Owned _ => True
+ | Shared κ | Uniq κ _ => lctx_lft_alive E L κ
+ end.
+
+(** ** Inclusion of bor_kinds *)
+(* we ignore the ghost variable names *)
+Definition bor_kind_min (b1 b2 : bor_kind) : bor_kind :=
+ match b1, b2 with
+ | Owned wl, _ => b2
+ | _, Owned wl => b1
+ | Uniq κ1 γ1, Uniq κ2 γ2 => Uniq (κ1 ⊓ κ2) γ1
+ | Shared κ1, Uniq κ2 γ2 => Shared (κ1 ⊓ κ2)
+ | Uniq κ1 γ1, Shared κ2 => Shared (κ1 ⊓ κ2)
+ | Shared κ1, Shared κ2 => Shared (κ1 ⊓ κ2)
+ end.
+Arguments bor_kind_min : simpl nomatch.
+
+Definition bor_kind_incl (b1 b2 : bor_kind) : iProp Σ :=
+ match b1, b2 with
+ | _, Owned _ => True
+ | Uniq κ1 γ1, Uniq κ2 γ2 => κ1 ⊑ κ2
+ | Shared κ1, Uniq κ2 γ2 => κ1 ⊑ κ2
+ | Shared κ1, Shared κ2 => κ1 ⊑ κ2
+ | _, _ => False
+ end%I.
+Arguments bor_kind_incl : simpl nomatch.
+
+Definition bor_kind_direct_incl (b1 b2 : bor_kind) : iProp Σ :=
+ match b1, b2 with
+ | Owned wl1, Owned wl2 => ⌜wl1 = wl2âŒ
+ | Uniq κ1 γ1, Uniq κ2 γ2 => κ1 ⊑ κ2 ∗ ⌜γ1 = γ2âŒ
+ | Shared κ1, Shared κ2 => κ1 ⊑ κ2
+ | _, _ => False
+ end.
+Arguments bor_kind_direct_incl : simpl nomatch.
+
+
+Infix "⊑ₖ" := bor_kind_incl (at level 70) : bi_scope.
+Infix "⊓ₖ" := bor_kind_min (at level 40) : stdpp_scope.
+Infix "⊑ₛₖ" := bor_kind_direct_incl (at level 70) : bi_scope.
+
+Global Instance bor_kind_incl_pers b1 b2 : Persistent (b1 ⊑ₖ b2).
+Proof. destruct b1, b2; apply _. Qed.
+
+Lemma bor_kind_incl_refl b:
+ ⊢ (b ⊑ₖ b)%I.
+Proof. destruct b; first done; iApply lft_incl_refl. Qed.
+Lemma bor_kind_min_incl_l b1 b2 :
+ ⊢ (b1 ⊓ₖ b2 ⊑ₖ b1)%I.
+Proof. destruct b1, b2; simpl; eauto using lft_incl_refl, lft_intersect_incl_l. Qed.
+Lemma bor_kind_min_incl_r b1 b2 :
+ ⊢ (b1 ⊓ₖ b2 ⊑ₖ b2)%I.
+Proof. destruct b1, b2; simpl; eauto using lft_incl_refl, lft_intersect_incl_r. Qed.
+Lemma bor_kind_incl_trans b1 b2 b3 :
+ ⊢ (b1 ⊑ₖ b2 -∗ b2 ⊑ₖ b3 -∗ b1 ⊑ₖ b3)%I.
+Proof. destruct b1, b2, b3; simpl; iIntros "#?? //"; by iApply lft_incl_trans. Qed.
+Lemma bor_kind_incl_glb b1 b2 b3 :
+ b1 ⊑ₖ b2 -∗
+ b1 ⊑ₖ b3 -∗
+ b1 ⊑ₖ b2 ⊓ₖ b3.
+Proof.
+ iIntros "Hincl1 Hincl2".
+ destruct b1, b2, b3; unfold bor_kind_min, bor_kind_incl; simpl; try done; try iApply lft_incl_refl.
+ all: iApply (lft_incl_glb with "Hincl1 Hincl2").
+Qed.
+
+Definition lctx_bor_kind_incl (E : elctx) (L : llctx) b b' : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ □ (elctx_interp E -∗ b ⊑ₖ b').
+
+Lemma lctx_bor_kind_incl_acc E L k1 k2 :
+ lctx_bor_kind_incl E L k1 k2 →
+ elctx_interp E -∗ llctx_interp L -∗ k1 ⊑ₖ k2.
+Proof.
+ intros Hincl. iIntros "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iApply (Hincl with "HL HE").
+Qed.
+
+(** Outliving *)
+Definition bor_kind_outlives (b : bor_kind) (κ : lft) : iProp Σ :=
+ match b with
+ | Owned _ => True
+ | Uniq κ' _ => κ ⊑ κ'
+ | Shared κ' => κ ⊑ κ'
+ end.
+Global Instance bor_kind_outlives_persistent b κ : Persistent (bor_kind_outlives b κ).
+Proof. destruct b; apply _. Qed.
+Lemma bor_kind_outlives_mono b b' κ :
+ b ⊑ₖ b' -∗ bor_kind_outlives b κ -∗ bor_kind_outlives b' κ.
+Proof.
+ iIntros "#Hincl1 #Hincl2". destruct b, b'; unfold bor_kind_incl; simpl; first [done | iApply lft_incl_trans; done ].
+Qed.
+
+Definition lctx_bor_kind_outlives (E : elctx) (L : llctx) (b : bor_kind) (κ : lft) :=
+ ∀ qL, llctx_interp_noend L qL -∗ elctx_interp E -∗ bor_kind_outlives b κ.
+Arguments lctx_bor_kind_outlives : simpl nomatch.
+
+Lemma lctx_bor_kind_outlives_all_use (E : elctx) (L : llctx) k κs :
+ ⌜Forall (lctx_bor_kind_outlives E L k) κs⌠-∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ [∗ list] κ ∈ κs, bor_kind_outlives k κ.
+Proof.
+ iIntros (Hf) "#HE HL".
+ iPoseProof (Forall_big_sepL _ (bor_kind_outlives k) with "HL []") as "(Houtl & HL)"; first apply Hf.
+ { iModIntro. iIntros (?) "HL %Hout". iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iPoseProof (Hout with "HL HE") as "#Hout". iPoseProof ("HL_cl" with "HL") as "?". by iFrame. }
+ done.
+Qed.
+
+(** Direct inclusion *)
+Global Instance bor_kind_direct_incl_pers b1 b2 : Persistent (b1 ⊑ₛₖ b2).
+Proof. destruct b1, b2; apply _. Qed.
+
+Lemma bor_kind_direct_incl_refl b:
+ ⊢ (b ⊑ₛₖ b)%I.
+Proof.
+ destruct b; simpl.
+ - eauto.
+ - iApply lft_incl_refl.
+ - iSplit; last done. iApply lft_incl_refl.
+Qed.
+Lemma bor_kind_direct_incl_trans b1 b2 b3 :
+ ⊢ (b1 ⊑ₛₖ b2 -∗ b2 ⊑ₛₖ b3 -∗ b1 ⊑ₛₖ b3)%I.
+Proof.
+ destruct b1, b2, b3; simpl; first [iIntros "-> ->" | iIntros "[#? ->] [#? ->]" | iIntros "#?? //"].
+ - done.
+ - by iApply lft_incl_trans.
+ - iSplit; last done. by iApply lft_incl_trans.
+Qed.
+Lemma bor_kind_direct_incl_glb b1 b2 b3 :
+ b1 ⊑ₛₖ b2 -∗
+ b1 ⊑ₛₖ b3 -∗
+ b1 ⊑ₛₖ b2 ⊓ₖ b3.
+Proof.
+ iIntros "Hincl1 Hincl2".
+ destruct b1, b2, b3; unfold bor_kind_min, bor_kind_incl; simpl; try done; try iApply lft_incl_refl.
+ - iApply (lft_incl_glb with "Hincl1 Hincl2").
+ - iDestruct "Hincl1" as "(Hincl1 & ->)". iDestruct "Hincl2" as "(Hincl2 & ->)".
+ iSplit; last done. iApply (lft_incl_glb with "Hincl1 Hincl2").
+Qed.
+Lemma bor_kind_direct_incl_bor_kind_incl b1 b2 :
+ b1 ⊑ₛₖ b2 -∗ b1 ⊑ₖ b2.
+Proof.
+ iIntros "Hincl".
+ destruct b1, b2; unfold bor_kind_incl, bor_kind_direct_incl; simpl; try done.
+ iDestruct "Hincl" as "($ & _)".
+Qed.
+
+Definition lctx_bor_kind_direct_incl (E : elctx) (L : llctx) b b' : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ □ (elctx_interp E -∗ b ⊑ₛₖ b').
+
+End ltype.
+
+Infix "⊑ₖ" := bor_kind_incl (at level 70) : bi_scope.
+Infix "⊑ₛₖ" := bor_kind_direct_incl (at level 70) : bi_scope.
+Infix "⊓ₖ" := bor_kind_min (at level 40) : stdpp_scope.
+
+Global Arguments bor_kind_min : simpl never.
+Global Arguments bor_kind_incl : simpl never.
+Global Arguments bor_kind_direct_incl : simpl never.
+
+(*Global Hint Extern 4 (Inhabited _) => refine (populate _); assumption : typeclass_instances.*)
+
+Section ltype_def.
+ Context `{typeGS Σ}.
+
+ (*
+ [PlaceIn]: the current inner refinement is accurate (no blocking of the inner refinement).
+ [PlaceGhost]: the current inner refinement is determined by a ghost variable, either because it is currently blocked or was implicitly unblocked.
+ *)
+ Inductive place_rfn_mode := PlaceModeIn | PlaceModeGhost.
+ (* concrete refinements *)
+ Inductive place_rfn (rt : Type) :=
+ | PlaceIn (r : rt)
+ | PlaceGhost (γ : gname).
+ Global Arguments PlaceIn {_}.
+ Global Arguments PlaceGhost {_}.
+
+ Global Instance place_rfn_inh rt : Inhabited (place_rfn rt).
+ Proof. refine (populate (PlaceGhost inhabitant )). Qed.
+ Global Instance place_rfn_mode_inh : Inhabited (place_rfn_mode).
+ Proof. refine (populate (PlaceModeGhost)). Qed.
+
+ (* interpretation of place_rfn under owned *)
+ Definition place_rfn_interp_owned {rt} (r : place_rfn rt) (r' : rt) : iProp Σ :=
+ match r with
+ | PlaceIn r'' => ⌜r'' = r'âŒ
+ | PlaceGhost γ' =>
+ (* credit is paid for at borrow time, and used by resolve_ghost *)
+ gvar_auth γ' r' ∗ £1
+ end.
+
+ (* interpretation of place_rfn under mut *)
+ Definition place_rfn_interp_mut {rt} (r : place_rfn rt) γ : iProp Σ :=
+ match r with
+ | PlaceIn r' => gvar_obs γ r'
+ | PlaceGhost γ' =>
+ £1 ∗ Rel2 γ' γ (@eq rt)
+ end.
+
+ (* interpretation of place_rfn under shared *)
+ (* we don't get any knowledge for PlaceGhost: we should really unblock before initiating sharing *)
+ Definition place_rfn_interp_shared {rt} (r : place_rfn rt) (r' : rt) : iProp Σ :=
+ match r with
+ | PlaceIn r'' => ⌜r'' = r'âŒ
+ | _ => True
+ end.
+ Global Instance place_rfn_interp_shared_pers {rt} (r : place_rfn rt) r' : Persistent (place_rfn_interp_shared r r').
+ Proof. destruct r; apply _. Qed.
+ (* NOTE: It's a bit unlucky that we have to rely on timelessness of this in some cases, in particular for some of the unfolding lemmas. *)
+ Global Instance place_rfn_interp_shared_timeless {rt} (r : place_rfn rt) r' : Timeless (place_rfn_interp_shared r r').
+ Proof. destruct r; apply _. Qed.
+ Global Instance place_rfn_interp_owned_timeless {rt} (r : place_rfn rt) r' : Timeless (place_rfn_interp_owned r r').
+ Proof. destruct r; apply _. Qed.
+
+ Lemma place_rfn_interp_mut_owned {rt} (r : place_rfn rt) r' γ :
+ place_rfn_interp_mut r γ -∗
+ gvar_auth γ r' -∗
+ place_rfn_interp_owned r r' ∗
+ gvar_obs γ r' ∗ gvar_auth γ r'.
+ Proof.
+ iIntros "Hrfn Hauth".
+ destruct r as [r'' | γ'].
+ - iPoseProof (gvar_agree with "Hauth Hrfn") as "#->".
+ iSplitR; first done. by iFrame.
+ - iDestruct "Hrfn" as "(Hcred & %r1 & %r2 & Hauth' & Hobs & ->)".
+ iPoseProof (gvar_agree with "Hauth Hobs") as "#->". by iFrame.
+ Qed.
+ Lemma place_rfn_interp_owned_mut {rt} (r : place_rfn rt) r' γ :
+ place_rfn_interp_owned r r' -∗
+ gvar_obs γ r' -∗
+ place_rfn_interp_mut r γ.
+ Proof.
+ iIntros "Hrfn Hobs".
+ destruct r as [r'' | γ'].
+ - iDestruct "Hrfn" as "<-". iFrame.
+ - iDestruct "Hrfn" as "(Hauth' & Hcred)".
+ iFrame. iExists _, _. by iFrame.
+ Qed.
+
+ Lemma place_rfn_interp_owned_share F {rt} (r : place_rfn rt) (r' : rt) q κ :
+ lftE ⊆ F →
+ lft_ctx -∗
+ &{κ} (place_rfn_interp_owned r r') -∗
+ q.[κ] ={F}=∗
+ place_rfn_interp_shared r r' ∗ q.[κ].
+ Proof.
+ iIntros (?) "#LFT Hb Htok".
+ iMod (bor_acc with "LFT Hb Htok") as "(>Hrfn & Hcl)"; first solve_ndisj.
+ destruct r.
+ - iDestruct "Hrfn" as "->". iMod ("Hcl" with "[//]") as "(? & $)". eauto.
+ - iMod ("Hcl" with "Hrfn") as "(? & $)". eauto.
+ Qed.
+
+ (** For adding information to the context *)
+ Definition place_rfn_interp_mut_extracted {rt} (r : place_rfn rt) (γ : gname) : iProp Σ :=
+ match r with
+ | PlaceIn r' => gvar_pobs γ r'
+ | PlaceGhost γ' => Rel2 (T:=rt) γ' γ eq
+ end.
+ Definition place_rfn_interp_owned_extracted {rt} (r : place_rfn rt) (r' : rt) : iProp Σ :=
+ match r with
+ | PlaceIn r'' => ⌜r'' = r'âŒ
+ | PlaceGhost γ' => gvar_pobs γ' r'
+ end.
+
+ Lemma place_rfn_interp_mut_extract {rt} (r : place_rfn rt) (γ : gname) :
+ place_rfn_interp_mut r γ ==∗ place_rfn_interp_mut_extracted r γ.
+ Proof.
+ destruct r; simpl.
+ - iIntros "Hobs". iApply (gvar_obs_persist with "Hobs").
+ - by iIntros "(_ & $)".
+ Qed.
+ Lemma place_rfn_interp_owned_extract {rt} (r : place_rfn rt) (r' : rt) :
+ place_rfn_interp_owned r r' ==∗ place_rfn_interp_owned_extracted r r'.
+ Proof.
+ destruct r; simpl.
+ - eauto.
+ - iIntros "(Hauth & _)". iApply (gvar_obs_persist with "Hauth").
+ Qed.
+
+ Implicit Types
+ (κ : lft)
+ (k : bor_kind)
+ (l : loc)
+ (Ï€ : thread_id)
+ .
+
+ (* TODO move *)
+ Lemma zip_fmap_l {A B C} (l1 : list A) (l2 : list B) (f : A → C) :
+ zip (f <$> l1) l2 = (λ x : A * B, (f x.1, x.2)) <$> (zip l1 l2).
+ Proof.
+ induction l1 as [ | a l1 IH] in l2 |-*; destruct l2 as [ | l2]; simpl; [done.. | ].
+ f_equiv. apply IH.
+ Qed.
+
+ (* TODO move *)
+ Section list_map.
+ Context {K : Type} `{!EqDecision K}.
+ Fixpoint lookup_iml {X} (iml : list (K * X)) (i : K) : option X :=
+ match iml with
+ | [] => None
+ | (j, x) :: iml => if decide (i = j) then Some x else lookup_iml iml i
+ end.
+
+ Lemma lookup_iml_Some_iff {X} (iml : list (K * X)) i x :
+ (∃ a, iml !! a = Some (i, x) ∧ (∀ b j y, b < a → iml !! b = Some (j, y) → j ≠i)) ↔ lookup_iml iml i = Some x.
+ Proof.
+ induction iml as [ | [j y] iml IH] in i |-*; simpl.
+ - split.
+ + intros (? & Ha & _). rewrite lookup_nil in Ha. done.
+ + intros [=].
+ - split.
+ + intros (a & Hlook & Hle). destruct a as [ | a].
+ * simpl in *. injection Hlook as -> ->. rewrite decide_True; done.
+ * simpl in *. destruct (decide (i = j)) as [<- | Hneq].
+ { by efeed pose proof (Hle 0); [lia | done | done | ]. }
+ eapply IH. eexists. split; first done. intros. eapply (Hle (S b)); last done. lia.
+ + destruct (decide (i = j)) as [<- | Hneq].
+ * intros [= ->]. exists 0. simpl. split; first done. intros. lia.
+ * intros (a & Ha & Hleq)%IH. exists (S a).
+ split; first done. intros ???? Hlook.
+ destruct b; simpl in *. { congruence. }
+ eapply Hleq; last done. lia.
+ Qed.
+ Lemma lookup_iml_None {X} (iml : list (K * X)) i :
+ (∀ b j y, iml !! b = Some (j, y) → j ≠i) ↔ lookup_iml iml i = None.
+ Proof.
+ induction iml as [ | [j y] iml IH] in i |-*; simpl.
+ { split; first done. naive_solver. }
+ split.
+ - intros Ha. destruct (decide (i = j)) as [<- | ]; first last.
+ { eapply IH. intros. eapply (Ha (S b)); done. }
+ by efeed pose proof (Ha 0); [done | done | ].
+ - destruct (decide (i = j)) as [<- | ]; first done.
+ intros Ha b ??. destruct b as [ | b]; first (simpl; congruence).
+ simpl. intros Hlook. eapply IH; done.
+ Qed.
+ End list_map.
+
+ (* Interpretation of an insertion list: from front to back. The same index may appear multiple times,
+ then the first occurrence is what is relevant. *)
+ Definition interpret_inserts {X} (iml : list (nat * X)) (ls : list X) : list X :=
+ foldr (λ '(i, x) acc, <[i := x]> acc) ls iml.
+ Definition interpret_iml {X} (def : X) (len : nat) (iml : list (nat * X)) : list X :=
+ interpret_inserts iml (replicate len def).
+
+ Lemma interpret_inserts_length {X} (iml : list (nat * X)) (ls : list X) :
+ length (interpret_inserts iml ls) = length ls.
+ Proof.
+ induction iml as [ | [i x] iml IH]; simpl; first done.
+ rewrite insert_length //.
+ Qed.
+ Lemma interpret_iml_length {X} (def : X) (len : nat) (iml : list (nat * X)) :
+ length (interpret_iml def len iml) = len.
+ Proof.
+ rewrite /interpret_iml interpret_inserts_length replicate_length //.
+ Qed.
+
+ Lemma lookup_interpret_inserts_Some_inv {X} (iml : list (nat * X)) (ls : list X) i x :
+ interpret_inserts iml ls !! i = Some x →
+ ((i, x) ∈ iml) ∨ ls !! i = Some x.
+ Proof.
+ intros Ha. specialize (lookup_lt_Some _ _ _ Ha) as Hlen.
+ induction iml as [ | [j y] iml IH] in i, Hlen, Ha |-*; simpl; first by eauto.
+ move: Ha. simpl in *.
+ rewrite insert_length in Hlen.
+ destruct (decide (i = j)) as [ <- | Hneq].
+ - rewrite list_lookup_insert; last done.
+ intros [= ->]. left. apply elem_of_cons. by left.
+ - rewrite list_lookup_insert_ne; last done.
+ intros Ha%IH; last done.
+ destruct Ha as [ Ha| Ha].
+ + left. rewrite elem_of_cons. by right.
+ + right. done.
+ Qed.
+ Lemma lookup_interpret_iml_Some_inv {X} (iml : list (nat * X)) def len i x :
+ interpret_iml def len iml !! i = Some x →
+ i < len ∧ (x = def ∨ (i, x) ∈ iml).
+ Proof.
+ rewrite /interpret_iml. intros Ha.
+ specialize (lookup_lt_Some _ _ _ Ha) as Hlen.
+ rewrite interpret_inserts_length replicate_length in Hlen.
+ split; first done.
+ apply lookup_interpret_inserts_Some_inv in Ha as [ | Ha]; first by eauto.
+ apply lookup_replicate_1 in Ha as [ ]. by left.
+ Qed.
+
+ Lemma lookup_interpret_inserts_1 {X} (iml : list (nat * X)) (ls : list X) i :
+ lookup_iml iml i = None →
+ interpret_inserts iml ls !! i = ls !! i.
+ Proof.
+ intros Ha. induction iml as [ | [j x] iml IH]; simpl in *; first done.
+ destruct (decide (i = j)) as [<- | Hneq]; first done.
+ rewrite list_lookup_insert_ne; last done. by eapply IH.
+ Qed.
+ Lemma lookup_interpret_inserts_Some_2 {X} (iml : list (nat * X)) (ls : list X) i x :
+ i < length ls →
+ lookup_iml iml i = Some x →
+ interpret_inserts iml ls !! i = Some x.
+ Proof.
+ induction iml as [ | [j y] iml IH]; simpl; first done.
+ intros Hlen Ha. destruct (decide (i = j)) as [<- | Hneq].
+ - injection Ha as ->. rewrite list_lookup_insert; first done.
+ rewrite interpret_inserts_length //.
+ - rewrite list_lookup_insert_ne; last done. by eapply IH.
+ Qed.
+
+ Lemma lookup_interpret_iml_Some_1 {X} (iml : list (nat * X)) (def : X) len i :
+ lookup_iml iml i = None →
+ i < len →
+ interpret_iml def len iml !! i = Some def.
+ Proof.
+ intros Ha Hlen. rewrite lookup_interpret_inserts_1; last done.
+ rewrite lookup_replicate; done.
+ Qed.
+ Lemma lookup_interpret_iml_None_1 {X} (iml : list (nat * X)) (def : X) len i :
+ lookup_iml iml i = None →
+ len ≤ i →
+ interpret_iml def len iml !! i = None.
+ Proof.
+ intros Ha Hlen. rewrite lookup_interpret_inserts_1; last done.
+ apply lookup_replicate_None; done.
+ Qed.
+ Lemma lookup_interpret_iml_Some_2 {X} (iml : list (nat * X)) (def : X) len i x :
+ lookup_iml iml i = Some x →
+ i < len →
+ interpret_iml def len iml !! i = Some x.
+ Proof.
+ intros Ha Hlen. induction iml as [ | [j y] iml IH]; simpl; first done.
+ simpl in *. destruct (decide (i = j)) as [<- | Hneq].
+ - injection Ha as ->. rewrite list_lookup_insert; first done.
+ rewrite interpret_iml_length//.
+ - rewrite list_lookup_insert_ne; last done. by apply IH.
+ Qed.
+
+ Lemma elem_of_interpret_iml_inv {X} (def : X) iml len x :
+ x ∈ interpret_iml def len iml → x = def ∨ ∃ i, (i, x) ∈ iml.
+ Proof.
+ intros (i & Hel)%elem_of_list_lookup_1.
+ apply lookup_interpret_iml_Some_inv in Hel as (? & [? | ?]); eauto.
+ Qed.
+
+
+ Lemma interpret_inserts_fmap {X Y} (f : X → Y) iml ls :
+ interpret_inserts ((λ '(a, b), (a, f b)) <$> iml) (f <$> ls) =
+ f <$> interpret_inserts iml ls.
+ Proof.
+ induction iml as [ | [i x] iml IH]; simpl; first done.
+ rewrite list_fmap_insert. f_equiv. by apply IH.
+ Qed.
+ Lemma interpret_iml_fmap {X Y} (f : X → Y) (def : X) len iml :
+ interpret_iml (f def) len ((λ '(a, b), (a, f b)) <$> iml) =
+ f <$> interpret_iml def len iml.
+ Proof.
+ rewrite /interpret_iml -interpret_inserts_fmap.
+ rewrite fmap_replicate. done.
+ Qed.
+
+ (** ** Definition *)
+ (** ltypes are Type-indexed by their refinement type.
+ However, defining this directly makes it hard to define an induction principle on them,
+ so we first define a separate version [lty] that is not indexed, but rather Type-equalities when using them,
+ and later on define [ltype], which exposes [lty_rt] as in index, on top. *)
+ Inductive lty : Type :=
+ | BlockedLty {rt} (t : type rt) (κ : lft)
+ | ShrBlockedLty {rt} (t : type rt) (κ : lft)
+ | OfTyLty {rt} (t : type rt)
+ (* AliasLty is polymorphic in the refinement type -- it accepts any refinement *)
+ | AliasLty (rt : Type) (st : syn_type) (l : loc)
+ | MutLty (lt : lty) (κ : lft)
+ | ShrLty (lt : lty) (κ : lft)
+ | BoxLty (lt : lty)
+ (* [ls = true] iff this should put a later *)
+ | OwnedPtrLty (lt : lty) (ls : bool)
+ | StructLty (lts : list lty) (sls : struct_layout_spec)
+ (* [def] is the default element type; [lts] masks this for certain indices *)
+ | ArrayLty {rt} (def : type rt) (len : nat) (lts : list (nat * lty))
+ | OpenedLty
+ (* NOTE: we parameterize over the refinement types here,
+ as we don't have support for induction-recursion in Coq to define [lty_rfn] mutually.
+ The ownership predicate will require that they are equal to the actual refinement types. *)
+ (** [lt_cur] is the currently owned ltype here.
+ [lt_inner] is the condition on when we can fold again: the core of [lt_cur] needs to be equivalent to [lt_inner].
+ [ty_full] is the type describing the original ownership. It needs to be a type to formulate the Uniq case.
+ (we might be able to lift this restriction by having equations that unfold applicable ltypes from Uniq to Owned, exposing the borrow in the process) *)
+ {rt_inner rt_full : Type}
+ (lt_cur : lty) (lt_inner : lty) (lt_full : lty)
+ (Cpre : rt_inner → rt_full → iProp Σ)
+ (Cpost : rt_inner → rt_full → iProp Σ)
+ | CoreableLty
+ (** gives us [lt_full] after all [κs] are dead; with no currently accessible ownership *)
+ (* TODO think about how we can unify this with BlockedLtype *)
+ (κs : list lft)
+ (lt_full : lty)
+ | ShadowedLty {rt : Type} (lt_cur : lty) (r_cur : place_rfn rt) (lt_full : lty)
+ .
+
+ (*
+ Basic setup for augmenting these with place_rfns:
+ - since we move down the interpretation of ownership by one level anyways,
+ we also handle the interpretation of place_rfn for a particular place there,
+ one level down (for the respective place)
+ - this enables us to state ownership of the gvar_obs of the outer mut ref (one above) depending on the state of the place owned by the reference.
+ i.e.:
+ - for blocked this is quite clear, we want to link up the outer reference with the inner reference.
+ - for other places, this controls the presence of the gvar_obs fragment/what we know about the inner refinement
+ *)
+ Fixpoint lty_rt (lt : lty) : Type :=
+ match lt with
+ | @BlockedLty rt _ _ => rt
+ | @ShrBlockedLty rt _ _ => rt
+ | @OfTyLty rt _ => rt
+ | AliasLty rt st l => rt
+ | MutLty lt _ => (place_rfn (lty_rt lt) * gname)%type
+ | BoxLty lt => place_rfn (lty_rt lt)
+ | OwnedPtrLty lt ls => (place_rfn (lty_rt lt) * loc)
+ | ShrLty lt _ => place_rfn (lty_rt lt)
+ | StructLty lts _ =>
+ (*unit*)
+ plist (λ lt, place_rfn (lty_rt lt)) lts
+ | @ArrayLty rt def len lts => list (place_rfn rt)
+ | OpenedLty lt_cur lt_inner lt_full Cpre Cpost =>
+ lty_rt lt_cur
+ | CoreableLty κ lt_full =>
+ lty_rt lt_full
+ | ShadowedLty lt_cur r_cur lt_full =>
+ lty_rt lt_full
+ end.
+
+ Fixpoint lty_st (lt : lty) : syn_type :=
+ match lt with
+ | BlockedLty ty _ => ty.(ty_syn_type)
+ | ShrBlockedLty ty _ => ty.(ty_syn_type)
+ | OfTyLty ty => ty.(ty_syn_type)
+ | AliasLty _ st l => st
+ | MutLty _ _ => PtrSynType
+ | BoxLty _ => PtrSynType
+ | OwnedPtrLty _ _ => PtrSynType
+ | ShrLty _ _ => PtrSynType
+ | StructLty _ sls => sls
+ | ArrayLty def len lts => ArraySynType (ty_syn_type def) len
+ | OpenedLty lt_cur _ _ _ _ => lty_st lt_cur
+ | CoreableLty _ lt_full =>
+ lty_st lt_full
+ | ShadowedLty lt_cur r_cur lt_full =>
+ lty_st lt_full
+ end.
+
+ Fixpoint lty_wf (lt : lty) : Prop :=
+ match lt with
+ | BlockedLty _ _ => True
+ | ShrBlockedLty _ _ => True
+ | OfTyLty _ => True
+ | AliasLty _ st l => True
+ | MutLty lt κ => lty_wf lt
+ | ShrLty lt _ => lty_wf lt
+ | BoxLty lt => lty_wf lt
+ | OwnedPtrLty lt _ => lty_wf lt
+ | StructLty lts _ => Forall_cb lty_wf lts
+ | @ArrayLty rt def len lts =>
+ Forall_cb (λ '(i, lt), lty_wf lt ∧ lty_rt lt = rt(*∧ i < len *)) lts
+ | @OpenedLty rt_inner rt_full lt_cur lt_inner lt_full _ _ =>
+ (* require that the refinements actually match *)
+ rt_inner = lty_rt lt_inner ∧ rt_full = lty_rt lt_full ∧ lty_wf lt_cur ∧ lty_wf lt_inner ∧ lty_wf lt_full
+ (*∧ lty_st lt_inner = lty_st lt_full ∧ lty_st lt_cur = lty_st lt_full*)
+ | CoreableLty _ lt =>
+ lty_wf lt
+ | @ShadowedLty rt_cur lt_cur r_cur lt_full =>
+ lty_wf lt_cur ∧ lty_wf lt_full ∧ lty_rt lt_cur = rt_cur
+ end.
+
+ (* unary parametricity translation *)
+ Inductive list_is_list (A : Type) (PA : A → Type) : list A → Type :=
+ | list_is_nil : list_is_list A PA []
+ | list_is_cons : ∀ a : A, PA a → ∀ l : list A, list_is_list A PA l → list_is_list A PA (a :: l).
+
+ Lemma list_is_list_full {A} (PA : A → Type) (l : list A) :
+ (∀ a, PA a) → list_is_list A PA l.
+ Proof.
+ intros Hf. induction l; constructor; eauto.
+ Defined.
+
+ (* induction principle loosely based on unary parametricity *)
+ Lemma lty_recursor :
+ ∀ P : lty → Type,
+ (∀ (rt : Type) (t : type rt), ∀ κ : lft, P (BlockedLty t κ)) →
+ (∀ (rt : Type) (t : type rt), ∀ κ : lft, P (ShrBlockedLty t κ)) →
+ (∀ (rt : Type) (t : type rt), P (OfTyLty t)) →
+ (∀ (rt : Type) (st : syn_type) (l : loc), P (AliasLty rt st l)) →
+ (∀ lt : lty, P lt → ∀ κ : lft, P (MutLty lt κ)) →
+ (∀ lt : lty, P lt → ∀ κ : lft, P (ShrLty lt κ)) →
+ (∀ lt : lty, P lt → P (BoxLty lt)) →
+ (∀ (lt : lty) (ls : bool), P lt → P (OwnedPtrLty lt ls)) →
+ (∀ lts : list lty, list_is_list lty P lts → ∀ sls : struct_layout_spec, P (StructLty lts sls)) →
+ (∀ (rt : Type) (def : type rt) (len : nat) (lts : list (nat * lty)),
+ list_is_list _ (λ '(_, lt), P lt) lts → P (ArrayLty def len lts)) →
+ (∀ (rt_inner rt_full : Type) (lt_cur lt_inner lt_full : lty)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ),
+ P lt_cur → P lt_inner → P lt_full → P (OpenedLty lt_cur lt_inner lt_full Cpre Cpost)) →
+ (∀ κs (lt_full : lty), P lt_full → P (CoreableLty κs lt_full)) →
+ (∀ (rt_cur : Type) (lt_cur : lty) (r_cur : place_rfn rt_cur) (lt_full : lty), P lt_cur → P lt_full → P (ShadowedLty lt_cur r_cur lt_full)) →
+ ∀ lt : lty, P lt.
+ Proof.
+ intros P Hblocked Hshrblocked Hofty Halias Hmut Hshr Hbox Hptr Hstruct Harr Hopened Hcoreable Hshadow.
+ (* doing induction does not give us the IH *)
+ refine (fix IH (lt : lty) {struct lt} : P lt :=
+ match lt return (P lt) with
+ | BlockedLty t κ => Hblocked _ t κ
+ | ShrBlockedLty t κ => Hshrblocked _ t κ
+ | OfTyLty t => Hofty _ t
+ | AliasLty rt st l => Halias rt st l
+ | MutLty lt κ => Hmut lt _ κ
+ | ShrLty lt κ => Hshr lt _ κ
+ | BoxLty lt => Hbox lt _
+ | OwnedPtrLty lt ls => Hptr lt ls _
+ | StructLty lts sls =>
+ _
+ | @ArrayLty rt def len lts =>
+ _
+ | OpenedLty lt_cur lt_inner lt_full Cpre Cpost =>
+ _
+ | CoreableLty κ lt_full =>
+ _
+ | ShadowedLty lt_cur r_cur lt_full =>
+ _
+ end); [apply IH.. | | | | | ].
+ - apply Hstruct.
+ apply list_is_list_full.
+ apply IH.
+ - apply Harr. apply list_is_list_full. intros []. apply IH.
+ - apply Hopened; apply IH.
+ - apply Hcoreable; apply IH.
+ - apply Hshadow; apply IH.
+ Defined.
+
+ Lemma lty_induction :
+ ∀ P : lty → Prop,
+ (∀ (rt : Type) (t : type rt), ∀ κ : lft, P (BlockedLty t κ)) →
+ (∀ (rt : Type) (t : type rt), ∀ κ : lft, P (ShrBlockedLty t κ)) →
+ (∀ (rt : Type) (t : type rt), P (OfTyLty t)) →
+ (∀ (rt : Type) (st : syn_type) (l : loc), P (AliasLty rt st l)) →
+ (∀ lt : lty, P lt → ∀ κ : lft, P (MutLty lt κ)) →
+ (∀ lt : lty, P lt → ∀ κ : lft, P (ShrLty lt κ)) →
+ (∀ lt : lty, P lt → P (BoxLty lt)) →
+ (∀ (lt : lty) (ls : bool), P lt → P (OwnedPtrLty lt ls)) →
+ (∀ lts : list lty, (∀ lt, lt ∈ lts → P lt) → ∀ sls : struct_layout_spec, P (StructLty lts sls)) →
+ (∀ (rt : Type) (def : type rt) (len : nat) (lts : list (nat * lty)), (∀ i lt, (i, lt) ∈ lts → P lt) → P (ArrayLty def len lts)) →
+ (∀ (rt_inner rt_full : Type) (lt_cur lt_inner lt_full : lty)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ),
+ P lt_cur → P lt_inner → P lt_full → P (OpenedLty lt_cur lt_inner lt_full Cpre Cpost)) →
+ (∀ κs (lt_full : lty), P lt_full → P (CoreableLty κs lt_full)) →
+ (∀ (rt_cur : Type) (lt_cur : lty) (r_cur : place_rfn rt_cur) (lt_full : lty), P lt_cur → P lt_full → P (ShadowedLty lt_cur r_cur lt_full)) →
+ ∀ lt : lty, P lt.
+ Proof.
+ intros P ? ? ? ? ? ? ? ? Hstruct Harr Hopened Hcoreable Hshadow lt.
+ induction lt as [ | | | | | | | | lts IH sls | rt def len lts IH | | | ] using lty_recursor; [by eauto.. | | | | | ].
+ - eapply Hstruct. intros lt Hin. induction lts as [ | lt' lts IH'].
+ + apply elem_of_nil in Hin. done.
+ + inversion IH; subst. apply elem_of_cons in Hin as [<- | Hin]; first done.
+ by apply IH'.
+ - eapply Harr.
+ intros i lt Hin. induction lts as [ | [j lt'] lts IH'].
+ + apply elem_of_nil in Hin. done.
+ + inversion IH; subst. apply elem_of_cons in Hin as [ [= <- <-] | Hin]; first done.
+ by apply IH'.
+ - eapply Hopened; eauto.
+ - eapply Hcoreable; eauto.
+ - eapply Hshadow; eauto.
+ Qed.
+
+ (** Stronger induction principle for the OpenedLtype case, but requires well-formedness. *)
+ Lemma lty_induction_wf :
+ ∀ P : lty → Prop,
+ (∀ (rt : Type) (t : type rt), ∀ κ : lft, P (BlockedLty t κ)) →
+ (∀ (rt : Type) (t : type rt), ∀ κ : lft, P (ShrBlockedLty t κ)) →
+ (∀ (rt : Type) (t : type rt), P (OfTyLty t)) →
+ (∀ (rt : Type) (st : syn_type) (l : loc), P (AliasLty rt st l)) →
+ (∀ lt : lty, P lt → ∀ κ : lft, P (MutLty lt κ)) →
+ (∀ lt : lty, P lt → ∀ κ : lft, P (ShrLty lt κ)) →
+ (∀ lt : lty, P lt → P (BoxLty lt)) →
+ (∀ (lt : lty) (ls : bool), P lt → P (OwnedPtrLty lt ls)) →
+ (∀ lts : list lty, (∀ lt, lt ∈ lts → P lt) → ∀ sls : struct_layout_spec, P (StructLty lts sls)) →
+ (∀ (rt : Type) (def : type rt) (len : nat) (lts : list (nat * lty)),
+ (∀ i lt, (i, lt) ∈ lts → P lt ∧ lty_rt lt = rt) → P (ArrayLty def len lts)) →
+ (∀ (lt_cur lt_inner lt_full : lty) (Cpre : (lty_rt lt_inner) → lty_rt lt_full → iProp Σ)
+ (Cpost : (lty_rt lt_inner) → (lty_rt lt_full) → iProp Σ),
+ P lt_cur → P lt_inner → P lt_full → P (OpenedLty lt_cur lt_inner lt_full Cpre Cpost)) →
+ (∀ κs (lt_full : lty), P lt_full → P (CoreableLty κs lt_full)) →
+ (∀ (lt_cur : lty) (r_cur : place_rfn (lty_rt lt_cur)) (lt_full : lty),
+ P lt_cur → P lt_full → P (ShadowedLty lt_cur r_cur lt_full)) →
+ ∀ lt : lty, lty_wf lt → P lt.
+ Proof.
+ intros P ???????? Hstruct Harr Hopened Hcoreable Hshadow lt Hwf.
+ induction lt as [ | | | | | | | | lts IH sls | rt def len lts IH | rt_inner rt_full lt_cur lt_inner lt_full Cpre Cpost IH1 IH2 IH3 | κ lt_full IH | ] using lty_induction; [by eauto.. | | | | | ].
+ - eapply Hstruct. intros lt Hlt. eapply IH; first done.
+ simpl in Hwf. apply Forall_Forall_cb in Hwf.
+ eapply Forall_forall; done.
+ - simpl in Hwf. eapply Harr.
+ intros i lt Hin.
+ simpl in Hwf. apply Forall_Forall_cb in Hwf.
+ eapply Forall_forall in Hwf; last apply Hin.
+ destruct Hwf as (? & ?). split_and!; [ | done..].
+ eapply IH; done.
+ - destruct Hwf as (Heq1 & Heq2 & Hcur & Hinner & Hfull ). subst.
+ eapply Hopened; eauto.
+ - eapply Hcoreable; eauto.
+ - destruct Hwf as (? & ? & <-).
+ eapply Hshadow; eauto.
+ Qed.
+
+ Fixpoint lty_size (lt : lty) : nat :=
+ match lt with
+ | OfTyLty _ => 0
+ | AliasLty rt st l => 0
+ | BlockedLty _ _ => 0
+ | ShrBlockedLty _ _ => 0
+ | BoxLty lt => 1 + lty_size lt
+ | OwnedPtrLty lt _ => 1 + lty_size lt
+ | MutLty lt _ => 1 + lty_size lt
+ | ShrLty lt _ => 1 + lty_size lt
+ | StructLty lts _ => 1 + list_max (fmap lty_size lts)
+ | ArrayLty def len lts => 1 + (list_max (fmap (λ '(_, lt), lty_size lt) lts))
+ | OpenedLty lt_cur lt_inner lt_full Cpre Cpost =>
+ (* we will be using both [lt_cur] and [lt_inner] and [lt_full] recursively *)
+ 1 + max (lty_size lt_cur) (max (lty_size lt_inner) (lty_size lt_full))
+ | CoreableLty _ lt_full =>
+ 1 + lty_size lt_full
+ | ShadowedLty lt_cur r_cur lt_full =>
+ 1 + lty_size lt_cur + lty_size lt_full
+ end.
+ Definition lty_size_rel : lty → lty → Prop :=
+ ltof _ lty_size.
+ Global Instance lty_size_rel_wf : WellFounded lty_size_rel.
+ Proof. apply well_founded_ltof. Qed.
+
+ (** Derived, stronger well-founded induction principle *)
+ Lemma lty_size_recursor (P : lty → Type) :
+ (∀ lt, (∀ lt', lty_size lt' < lty_size lt → P lt') → P lt) →
+ ∀ lt, P lt.
+ Proof.
+ apply induction_ltof1.
+ Defined.
+ Lemma lty_size_induction (P : lty → Prop) :
+ (∀ lt, (∀ lt', lty_size lt' < lty_size lt → P lt') → P lt) →
+ ∀ lt, P lt.
+ Proof.
+ apply lty_size_recursor.
+ Qed.
+
+
+ (** The "core" of an ltype that we need to fold it to a type *)
+ Fixpoint lty_core (lt : lty) : lty :=
+ match lt with
+ | BlockedLty t _ => OfTyLty t
+ | ShrBlockedLty t _ => OfTyLty t
+ | OfTyLty t => OfTyLty t
+ | AliasLty rt st l => AliasLty rt st l
+ | MutLty lt κ => MutLty (lty_core lt) κ
+ | ShrLty lt κ => ShrLty (lty_core lt) κ
+ | BoxLty lt => BoxLty (lty_core lt)
+ | OwnedPtrLty lt ls => OwnedPtrLty (lty_core lt) ls
+ | StructLty lts sls => StructLty (fmap lty_core lts) sls
+ | ArrayLty def len lts => ArrayLty def len (fmap (λ '(i, lt), (i, lty_core lt)) lts)
+ | OpenedLty lt_cur lt_inner lt_full Cpre Cpost =>
+ (** Rationale: below unfolded stuff, the core just doesn't matter, because we have currently
+ anyways broken all contracts and invariants.
+ This is also important to get the [lty_core_rt_eq] law, which we use heavily (and is intrinsic to the definition of ltype ownership!).
+ Otherwise, we would like to define it as [lt_full], but that breaks this law. *)
+ OpenedLty lt_cur lt_inner lt_full Cpre Cpost
+ | CoreableLty κ lt_full =>
+ lty_core lt_full
+ | ShadowedLty lt_cur r_cur lt_full =>
+ lty_core lt_full
+ end.
+
+ Lemma lty_core_syn_type_eq (lt : lty) :
+ lty_st (lty_core lt) = lty_st lt.
+ Proof.
+ induction lt as [ | | | | | | | | | ? IH | | | ]; by eauto.
+ Qed.
+
+ Lemma lty_core_rt_eq lt :
+ lty_rt (lty_core lt) = lty_rt lt.
+ Proof.
+ induction lt as [ | | | | ? IH ? | ? IH ? | ? IH | ? ? IH | ? IH ? | ???? IH | | | ] using lty_induction; simpl; [done.. | | | | | | | done | done | done].
+ - by rewrite IH.
+ - by rewrite IH.
+ - by rewrite IH.
+ - by rewrite IH.
+ - rewrite !(plist_fmap_shift _ lty_rt). f_equiv.
+ induction lts as [ | lt lts IH']; first done.
+ simpl. rewrite IH; first last. { apply elem_of_cons; eauto. }
+ f_equiv. apply IH'. intros. apply IH. apply elem_of_cons; eauto.
+ - done.
+ Qed.
+
+ (* We cannot get the other direction because of CoreableLty *)
+ Lemma lty_core_wf lt :
+ lty_wf lt → lty_wf (lty_core lt).
+ Proof.
+ induction lt as [ | | | | | | | | lts IH sls | rt def len lts IH | | rt lt IH | ] using lty_induction; simpl; [done.. | | | done | | ].
+ - rewrite -!Forall_Forall_cb.
+ rewrite Forall_fmap.
+ apply Forall_impl_strong.
+ intros; by apply IH.
+ - rewrite -!Forall_Forall_cb.
+ rewrite Forall_fmap.
+ intros Hwf.
+ eapply Forall_impl_strong; last done.
+ intros [i lt] Hlt (? & Hrt). simpl.
+ rewrite lty_core_rt_eq.
+ split; last done. eapply IH; done.
+ - done.
+ - intros (? & ? & <-). eauto.
+ Qed.
+
+ Lemma lty_size_core (lt : lty) :
+ lty_size (lty_core lt) ≤ lty_size lt.
+ Proof.
+ induction lt as [ | | | | | | | |lts IH sls | rt def len lts IH | | | ] using lty_induction; simpl; [lia.. | | | lia| lia | lia].
+ - induction lts as [ | lt lts IH']; simpl; first done.
+ efeed pose proof (IH lt) as IH0. { apply elem_of_cons. by left. }
+ feed specialize IH'. { intros. apply IH. apply elem_of_cons. by right. }
+ unfold fmap in IH'. lia.
+ - induction lts as [ | [i lt] lts IH2]; simpl; first lia.
+ efeed pose proof (IH i lt) as IH0. { apply elem_of_cons. by left. }
+ feed specialize IH2. { intros. eapply IH. apply elem_of_cons. by right. }
+ unfold fmap in IH2. lia.
+ Qed.
+
+ (*
+ Notes on the placement of laters and fancy updates in the interpretations:
+
+ For sharing:
+ What are the constraints here/design space?
+ - we are forced to have a later over recursive calls to the sharing predicate, due to contractiveness
+ - we should not put laters over the fractured borrow (that would require us to take two steps when reading/unable to use timelessness over pointsto)
+
+ So: need to put a later in each of the sharing cases, directly over the recursive call.
+
+ Q: should we also put a later in the ofty case?
+ Pro: makes the equation _1 for mut ref unfolding go through easily
+ Con: Now I need to put a later above the fractional borrow in MutLty to get the equation _2, which I don't want to do.
+ So: just put an update there for timeless stripping
+
+ Approach: put an update in ltype_eq also for the shared borrow case. Does this have drawbacks?
+ => Problem: this kills the compatibility with e.g. mut_lty, due to later fupd commuting problems. So this does not seem like the right approach.
+
+ Approach: I need to put an update over the whole MutLty (because all interesting stuff is under the update)
+ What is the downside? we anyways need to be able to eliminate an update when accessing the fractional borrow.
+ the same trick also seems to work just fine for mutable borrows, where we have an update over the full borrow.
+ => This seems to work fine.
+
+ Approach: try to modify the definition of the sharing case of ofty in order to get more useful stuff directly.
+ (fundamental problem in this equation here: MutLty has a lot of info upfront, while the def of ofty can't really provide a lot directly) one idea for that: give sharing a "with_later" parameter that allows pushing laters down a bit. still doesn't answer how to get the fractured borrow here without a later though.
+ *)
+
+
+ Definition lty_own_type (lt : lty) := bor_kind → thread_id → place_rfn (lty_rt lt) → loc → iProp Σ.
+
+ Definition lty_own_type_rec (lt0 : lty) := ∀ lt : lty, bor_kind → thread_id → place_rfn (lty_rt lt) → loc → lty_size_rel lt lt0 → iProp Σ.
+
+ Definition UninitLty st := OfTyLty (uninit st).
+
+ Definition maybe_creds (wl : bool) := (if wl then £ num_cred ∗ atime 1 else True)%I.
+
+ Definition lty_of_ty_own {rt} (ty : type rt) k π (r : place_rfn rt) l :=
+ (∃ ly : layout, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ ty.(ty_sidecond) ∗ loc_in_bounds l 0 (ly.(ly_size)) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ ∃ r' : rt,
+ place_rfn_interp_owned r r' ∗
+ (* Have a later here according to wl, which is imposed by e.g. a Box directly above it.
+ As such, this is really needed for contractiveness/making working with rec types possible. *)
+ ▷?(wl)|={lftE}=> ∃ v, l ↦ v ∗ ty.(ty_own_val) π r' v
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ (* Note: need an update inside the borrow over the recursive thing to get the unfolding equation for products
+ (as products need an update there)
+ This is really annoying, as this propagates to the other ltypes as well.
+ And there, it means that we actually have an update over the pointsto (e.g. in Box and Mutref) in the Uniq case,
+ which breaks timelessness after opening the borrow..
+ *)
+ |={lftE}=> &pin{κ} (∃ r', gvar_auth γ r' ∗ |={lftE}=> l ↦: ty.(ty_own_val) π r')
+ | Shared κ =>
+ (* we need an update for timelessness in the unfolding equations (eg for mut_ref) *)
+ ∃ r' : rt, place_rfn_interp_shared r r' ∗ □ |={lftE}=> ty.(ty_shr) κ π r' l
+ end)%I.
+
+ Definition alias_lty_own (rt : Type) (st : syn_type) (p : loc) k π (r : place_rfn rt) l :=
+ match k with
+ | Owned wl =>
+ ∃ ly, ⌜syn_type_has_layout st ly⌠∗ ⌜p = l⌠∗
+ ⌜l `has_layout_loc` ly⌠∗ loc_in_bounds l 0 (ly_size ly) ∗ maybe_creds wl
+ | _ => False
+ end%I.
+
+ Definition blocked_lty_own {rt} (ty : type rt) κ k π (r : place_rfn rt) l :=
+ (∃ ly, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ ty.(ty_sidecond) ∗ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ ([†κ] ={lftE}=∗
+ ∃ (r' : rt), place_rfn_interp_owned r r' ∗ |={lftE}=> l ↦: (ty.(ty_own_val) π r')) ∗
+ (* and the original credits *)
+ maybe_creds wl
+ | Shared κ' =>
+ (* sharing of inheritances is weird, they are of no use like that,
+ and there's no reason to create inheritances directly below
+ shared borrows in the first place *)
+ False
+ | Uniq κ' γ' =>
+ (* borrow needs to be synced up with OfTy *)
+ ([†κ] ={lftE}=∗
+ place_rfn_interp_mut r γ' ∗
+ &pin{κ'} (∃ r' : rt, gvar_auth γ' r' ∗ |={lftE}=> l ↦: ty.(ty_own_val) π r')) ∗
+ (* and the original credits *)
+ £ num_cred ∗ atime 1
+ end)%I.
+
+ Definition shr_blocked_lty_own {rt} (ty : type rt) κ k π (r : place_rfn rt) l :=
+ (∃ ly : layout, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗ ⌜l `has_layout_loc` ly⌠∗ ty.(ty_sidecond) ∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ ∃ r': rt, ⌜r = PlaceIn r'⌠∗
+ match k with
+ | Owned wl =>
+ (* also have the sharing predicate *)
+ ty.(ty_shr) κ π r' l ∗
+ ([†κ] ={lftE}=∗ l ↦: ty.(ty_own_val) π r') ∗
+ maybe_creds wl
+ | Shared κ' =>
+ (* already shared -- no need to do something special *)
+ (*ty.(ty_shr) κ' π r' l*)
+ False
+ | Uniq κ' γ' =>
+ gvar_obs γ' r' ∗
+ ty.(ty_shr) κ π r' l ∗
+ ([†κ] ={lftE}=∗
+ (* this needs to be synced up with [OfTy] *)
+ &pin{κ'} (∃ r'': rt, gvar_auth γ' r'' ∗ |={lftE}=> l ↦: ty.(ty_own_val) π r'')) ∗
+ (* original credits *)
+ £ num_cred ∗ atime 1
+ end)%I.
+
+ (** Shows that the recursive struct case is well-formed. Crucially uses the information we obtain from [big_sepL_P]. *)
+ Lemma struct_lts_size_decreasing sl sls (lts : list lty) (r' : plist (λ lt, place_rfn (lty_rt lt)) lts) ty :
+ ty ∈ pad_struct (sl_members sl) (pzipl lts r') (λ ly : layout, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())) →
+ lty_size_rel (projT1 ty) (StructLty lts sls).
+ Proof.
+ intros HP.
+ destruct ty as (lt & rlt).
+ apply elem_of_list_lookup_1 in HP as (j & HP).
+ apply pad_struct_lookup_Some_1 in HP as (n & ly & Hlook1 & Hlook2).
+ destruct Hlook2 as [ Hlook2 | [_ [= -> ->]]]; first last.
+ { unfold lty_size_rel, ltof. simpl. lia. }
+ move: Hlook2. generalize (field_idx_of_idx (sl_members sl) j) as m. clear.
+ unfold lty_size_rel, ltof; simpl. intros m.
+ induction lts as [ | lt0 lts IH] in m, r' |-*; intros [ ? Heq ]; simpl; first done.
+ destruct m as [ | m]; simpl.
+ - injection Heq as [= <- Heq]. apply existT_inj in Heq. subst rlt. lia.
+ - eapply Nat.lt_le_trans; first eapply IH. { split; first done. apply Heq. }
+ unfold fmap. lia.
+ Qed.
+
+ Lemma array_lts_size_decreasing {rt} (def : type rt) len (lts : list (nat * lty)) {A} (r : list A) (lt : lty * A) :
+ lt ∈ (zip (interpret_iml (OfTyLty def) len lts) r) → lty_size_rel (lt.1) (ArrayLty def len lts).
+ Proof.
+ intros HP.
+ apply elem_of_list_lookup_1 in HP as (j & HP).
+ unfold lty_size_rel, ltof; simpl.
+ apply lookup_zip in HP as [Hlook1 Hlook2].
+ apply lookup_interpret_iml_Some_inv in Hlook1 as (Hlen & Hlook1).
+ destruct lt as [lt a].
+ destruct Hlook1 as [-> | Hlook1]; simpl; first lia.
+ assert (lty_size lt ≤ list_max ((λ '(_, lt), lty_size lt) <$> lts)) as ?; last lia.
+ apply elem_of_list_lookup_1 in Hlook1 as (k & Hlook).
+ eapply (list_max_le_lookup _ k).
+ { rewrite list_lookup_fmap. rewrite Hlook. done. }
+ done.
+ Qed.
+
+ Import EqNotations.
+ Equations lty_own_pre (core : bool) (ltp : lty) (k : bor_kind) (π : thread_id) (r : place_rfn (lty_rt ltp)) (l : loc) : iProp Σ by wf ltp lty_size_rel :=
+ lty_own_pre core (OfTyLty ty) k π r l :=
+ (* OfTy *)
+ lty_of_ty_own ty k π r l;
+ lty_own_pre core (AliasLty rt st p) k π r l :=
+ alias_lty_own rt st p k π r l;
+ lty_own_pre core (BlockedLty ty κ) k π r l :=
+ (** Blocked *)
+ if core then lty_of_ty_own ty k π r l else blocked_lty_own ty κ k π r l ;
+ lty_own_pre core (ShrBlockedLty ty κ) k π r l :=
+ (** ShrBlocked *)
+ if core then lty_of_ty_own ty k π r l else shr_blocked_lty_own ty κ k π r l;
+
+ lty_own_pre core (BoxLty lt) k π r l :=
+ (** Box *)
+ (* TODO: eventually remove this when we model Box as a struct *)
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ (* the placement of the pointsto below the later let's us get the unfoldings equation without timelessness *)
+ ∃ r' : place_rfn (lty_rt lt), place_rfn_interp_owned r r' ∗ ▷?wl |={lftE}=>
+ ∃ (l' : loc) (ly' : layout), l ↦ l' ∗
+ ⌜syn_type_has_layout (lty_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ freeable_nz l' ly'.(ly_size) 1 HeapAlloc ∗
+ lty_own_pre core lt (Owned true) π r' l'
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ (* TODO can we remove the update here? *)
+ |={lftE}=> &pin{κ}
+ [∃ (r' : place_rfn (lty_rt lt)),
+ gvar_auth γ r' ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (l' : loc) (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (lty_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ (freeable_nz l' ly'.(ly_size) 1 HeapAlloc) ∗
+ lty_own_pre true lt (Owned true) π r' l'
+ ]
+ (∃ (r' : place_rfn (lty_rt lt)),
+ gvar_auth γ r' ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (l' : loc) (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (lty_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ (freeable_nz l' ly'.(ly_size) 1 HeapAlloc) ∗
+ lty_own_pre core lt (Owned true) π r' l')
+ | Shared κ =>
+ (∃ r', place_rfn_interp_shared r r' ∗
+ □ |={lftE}=> ∃ li : loc,
+ &frac{κ}(λ q', l ↦{q'} li) ∗
+ ▷ lty_own_pre core lt (Shared κ) π r' li)%I
+ end)%I;
+
+ lty_own_pre core (OwnedPtrLty lt ls) k π r l :=
+ (** OwnedPtr *)
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ (* the placement of the pointsto below the later let's us get the unfoldings equation without timelessness *)
+ ∃ (r' : place_rfn (lty_rt lt)) (l' : loc), place_rfn_interp_owned r (r', l') ∗ ▷?wl |={lftE}=>
+ ∃ (ly' : layout), l ↦ l' ∗
+ ⌜syn_type_has_layout (lty_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ lty_own_pre core lt (Owned ls) π r' l'
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ |={lftE}=> &pin{κ}
+ [∃ (r' : place_rfn (lty_rt lt)) (l' : loc),
+ gvar_auth γ (r', l') ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (lty_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ lty_own_pre true lt (Owned ls) π r' l'
+ ]
+ (∃ (r' : place_rfn (lty_rt lt)) (l' : loc),
+ gvar_auth γ (r', l') ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (lty_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ lty_own_pre core lt (Owned ls) π r' l')
+ | Shared κ =>
+ (∃ r' li, place_rfn_interp_shared r (r', li) ∗
+ â–¡ |={lftE}=>
+ &frac{κ}(λ q', l ↦{q'} li) ∗
+ ▷ lty_own_pre core lt (Shared κ) π r' li)%I
+ end)%I;
+
+ lty_own_pre core (MutLty lt κ) k π r l :=
+ (** Mut *)
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ (* it's fine to existentially quantify here over the gvar_obs, since
+ the outer can actually tell us about it. Keep in mind that the gvar here can actually
+ change if we write under nested places. *)
+ ∃ (γ : gname) (r' : place_rfn (lty_rt lt)) ,
+ place_rfn_interp_owned r (r', γ) ∗
+ (* TODO layout requirements on l' here? *)
+ ▷?wl |={lftE}=> ∃ l' : loc , l ↦ l' ∗ (lty_own_pre core lt (Uniq κ γ) π r' l')
+ | Uniq κ' γ' =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ' ∗
+ |={lftE}=> &pin{κ'}
+ [∃ (r' : (place_rfn (lty_rt lt)) * gname),
+ gvar_auth γ' r' ∗
+ (* update here to be compatible with ofty *)
+ |={lftE}=>
+ ∃ (l' : loc), l ↦ l' ∗
+ lty_own_pre true lt (Uniq κ r'.2) π r'.1 l'
+ ]
+ (∃ (r' : (place_rfn (lty_rt lt)) * gname),
+ gvar_auth γ' r' ∗
+ (* update here to be compatible with ofty *)
+ |={lftE}=>
+ ∃ (l' : loc), l ↦ l' ∗
+ lty_own_pre core lt (Uniq κ r'.2) π r'.1 l')
+ | Shared κ' =>
+ (∃ r' γ, place_rfn_interp_shared r (r', γ) ∗
+ (* the update is also over the fractional borrow to deal with timelessness *)
+ □ |={lftE}=> ∃ (li : loc),
+ &frac{κ'}(λ q', l ↦{q'} li) ∗
+ (* later is for contractiveness, the update for timelessness *)
+ ▷ lty_own_pre core lt (Shared (κ⊓κ')) π r' li)%I
+ end)%I;
+
+ lty_own_pre core (ShrLty lt κ) k π r l :=
+ (** Shr *)
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ ∃ (r' : place_rfn (lty_rt lt)), place_rfn_interp_owned r r' ∗
+ ▷?wl |={lftE}=> ∃ (l' : loc), l ↦ l' ∗
+ lty_own_pre core lt (Shared κ) π r' l'
+ | Uniq κ' γ' =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ' ∗
+ |={lftE}=> &pin{κ'}(∃ (r' : place_rfn (lty_rt lt)), gvar_auth γ' r' ∗
+ |={lftE}=> ∃ (l' : loc), l ↦ l' ∗ lty_own_pre core lt (Shared κ) π r' l')
+ | Shared κ' =>
+ ∃ (r' : place_rfn (lty_rt lt)),
+ place_rfn_interp_shared r r' ∗
+ (* the update is also over the fractional borrow to deal with timelessness *)
+ □ |={lftE}=> ∃ (l' : loc),
+ &frac{κ'} (λ q, l ↦{q} l') ∗
+ (* no intersection here, as we also don't do that for the type interpretation *)
+ ▷ lty_own_pre core lt (Shared κ) π r' l'
+ end)%I;
+
+ lty_own_pre core (StructLty lts sls) k π r l :=
+ (** Struct *)
+ ∃ sl : struct_layout,
+ ⌜use_struct_layout_alg sls = Some sl⌠∗
+ ⌜length (sls_fields sls) = length lts⌠∗
+ ⌜l `has_layout_loc` sl⌠∗
+ loc_in_bounds l 0 (sl.(ly_size)) ∗
+ match k with
+ | Owned wl =>
+ (* We change the interpretation to Owned false and interpret the later here, because we cannot push down/split up the credits for each of the components *)
+ maybe_creds wl ∗
+ ∃ r' : plist (λ lt, place_rfn (lty_rt lt)) lts, place_rfn_interp_owned r r' ∗
+ â–·?wl |={lftE}=>
+ big_sepL_P (pad_struct sl.(sl_members) (pzipl lts r') (λ ly, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())))
+ (λ i ty HP,
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre core (projT1 ty) (Owned false) π (projT2 ty) (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i)))
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ (* We change the ownership to Owned false, because we can't push the borrow down in this formulation of products.
+ The cost of this is that we need an update here (to get congruence rules for ltype_eq),
+ which propagates to all the other Uniq cases of other ltypes. *)
+ |={lftE}=> &pin{κ}
+ [∃ (r' : plist (λ lt, place_rfn (lty_rt lt)) lts),
+ gvar_auth γ r' ∗ |={lftE}=>
+ big_sepL_P (pad_struct sl.(sl_members) (pzipl lts r') (λ ly, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())))
+ (λ i ty HP,
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre true (projT1 ty) (Owned false) π (projT2 ty) (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i)))
+ ]
+ (∃ (r' : plist (λ lt, place_rfn (lty_rt lt)) lts),
+ gvar_auth γ r' ∗ |={lftE}=>
+ big_sepL_P (pad_struct sl.(sl_members) (pzipl lts r') (λ ly, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())))
+ (λ i ty HP,
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre core (projT1 ty) (Owned false) π (projT2 ty) (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i)))
+ )
+ | Shared κ =>
+ (∃ r', place_rfn_interp_shared r r' ∗
+ (* update needed to make the unfolding equation work *)
+ â–¡ |={lftE}=>
+ big_sepL_P (pad_struct sl.(sl_members) (pzipl lts r') (λ ly, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())))
+ (λ i ty HP,
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre core (projT1 ty) (Shared κ) π (projT2 ty) (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i))))
+ end;
+
+ lty_own_pre core (@ArrayLty rt def len lts) k π r l :=
+ (** ArrayLty *)
+ ∃ ly,
+ ⌜syn_type_has_layout (ty_syn_type def) ly⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly.(ly_size) * len) ∗
+ (*⌜Forall (λ '(i, lts), i < len) lts⌠∗*)
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ ∃ r' : list (place_rfn rt), place_rfn_interp_owned r r' ∗
+ ⌜length r' = len⌠∗
+ â–·?wl |={lftE}=>
+ big_sepL_P (zip (interpret_iml (OfTyLty def) len lts) r')
+ (λ i ty HP,
+ ∃ (Heq : lty_rt ty.1 = rt),
+ ⌜lty_st ty.1 = ty_syn_type def⌠∗
+ lty_own_pre core ty.1 (Owned false) π (rew <-Heq in ty.2) (offset_loc l ly i))
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ |={lftE}=> &pin{κ}
+ [∃ r' : list (place_rfn rt), gvar_auth γ r' ∗ ⌜length r' = len⌠∗ |={lftE}=>
+ big_sepL_P (zip (interpret_iml (OfTyLty def) len lts) r')
+ (λ i ty HP,
+ ∃ (Heq : lty_rt ty.1 = rt),
+ ⌜lty_st ty.1 = ty_syn_type def⌠∗
+ lty_own_pre true ty.1 (Owned false) π (rew <-Heq in ty.2) (offset_loc l ly i))]
+ (∃ r' : list (place_rfn rt), gvar_auth γ r' ∗ ⌜length r' = len⌠∗ |={lftE}=>
+ big_sepL_P (zip (interpret_iml (OfTyLty def) len lts) r')
+ (λ i ty HP,
+ ∃ (Heq : lty_rt ty.1 = rt),
+ ⌜lty_st ty.1 = ty_syn_type def⌠∗
+ lty_own_pre core ty.1 (Owned false) π (rew <-Heq in ty.2) (offset_loc l ly i)))
+
+ | Shared κ =>
+ ∃ r', place_rfn_interp_shared r r' ∗ ⌜length r' = len⌠∗
+ â–¡ |={lftE}=> big_sepL_P (zip (interpret_iml (OfTyLty def) len lts) r')
+ (λ i ty HP,
+ ∃ (Heq : lty_rt ty.1 = rt),
+ ⌜lty_st ty.1 = ty_syn_type def⌠∗
+ lty_own_pre core ty.1 (Shared κ) π (rew <-Heq in ty.2) (offset_loc l ly i))
+ end;
+
+ lty_own_pre core (@OpenedLty rt_inner rt_full lt_cur lt_inner lt_full Cpre Cpost) k π r l :=
+ (** OpenedLty *)
+ ∃ ly, ⌜use_layout_alg (lty_st lt_cur) = Some ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly_size ly) ∗
+ ⌜lty_st lt_cur = lty_st lt_inner⌠∗
+ ⌜lty_st lt_inner = lty_st lt_full⌠∗
+
+ match k with
+ | Owned wl =>
+ lty_own_pre false lt_cur (Owned false) π r l ∗
+ logical_step lftE
+ (∃ (Heq_inner : rt_inner = lty_rt lt_inner) (Heq_full : rt_full = lty_rt lt_full),
+ (* once we have restored to [lt_inner], we can fold to [lt_full] again *)
+ ∀ (r : rt_inner) (r' : rt_full) (κs : list lft),
+ (lft_dead_list κs ={lftE}=∗ Cpre r r') -∗
+ (* directly hand out Cpost. We don't need to wait to get tokens from closing borrows etc. *)
+ Cpost r r' ∗
+ (lft_dead_list κs -∗
+ lty_own_pre false lt_inner (Owned false) π (PlaceIn (rew [id] Heq_inner in r)) l ={lftE}=∗
+ lty_own_pre true lt_full (Owned wl) π (PlaceIn (rew [id] Heq_full in r')) l
+ ))
+ | Uniq κ γ =>
+ lty_own_pre false lt_cur (Owned false) π r l ∗
+ (* Note: we are not interpreting γ here - it is currently completely unconstrained, and the
+ ownership of the ghost variable fragments lies with the closing viewshift *)
+
+ (* Main points important for this VS:
+ - we close the pinned borrow again, so that we can get lifetime tokens back in Cpost
+ - we cannot restore lt_full directly, because we want to be able to execute this while subplaces are still borrowed;
+ instead we require that we can shift to lt_inner once [κ] is dead (has a flavor of [imp_unblockable]). *)
+ (* to prove when unfolding in the first place:
+ if I assume Cpre r r' and lty_own_pre true lt_inner(Owned false) π r l, then I can restore lt_full again and produce Cpost r r' *)
+ logical_step lftE
+ (∃ (Heq : rt_inner = lty_rt lt_inner) (Heq_full : rt_full = lty_rt lt_full),
+ (* we will execute this VS when closing the invariant, after having already stratified [lt_cur].
+ At that point, we will know [lt_cur] is unblockable to [lt_inner] after some set of lifetimes [κs] is dead *)
+ ∀ (own_lt_cur' : thread_id → rt_inner → loc → iProp Σ) (κs : list lft)
+ (r : rt_inner) (r' : rt_full),
+ (lft_dead_list κs ={lftE}=∗ Cpre r r') -∗
+ ([∗ list] κ' ∈ κs, κ' ⊑ κ) -∗
+ own_lt_cur' π r l -∗
+
+ (* the ownership of [lt_cur'] needs to be shiftable to the _core_ of [lt_inner];
+ this is required for closing the borrow and for proving that it can be unblocked to lt_full
+ (which is needed for showing the shift to Coreable) *)
+ (□ (lft_dead_list κs -∗ own_lt_cur' π r l ={lftE}=∗
+ lty_own_pre true lt_inner (Owned false) π (rew Heq in PlaceIn r) l)) ={lftE}=∗
+
+ Cpost r r' ∗
+ gvar_obs γ (rew [id] Heq_full in r') ∗
+ (lft_dead_list κs -∗ gvar_obs γ (rew [id] Heq_full in r') ={lftE}=∗
+ lty_own_pre true lt_full (Uniq κ γ) π (rew Heq_full in PlaceIn r') l)
+ )
+
+ | Shared κ =>
+ (* TODO: how do we deal with fractional ownership of the pointsto we get from ofty?
+ And how does it interact with the types we want to unfold in practice?
+ *)
+ (*lty_own_pre false lt_cur (Shared κ) π r l*)
+ False
+ end;
+ lty_own_pre core (@CoreableLty κs lt_full) k π r l :=
+ (if core then
+ lty_own_pre true lt_full k π r l
+ else
+ ∃ ly, ⌜syn_type_has_layout (lty_st lt_full) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly_size ly) ∗
+ match k with
+ | Owned wl =>
+ lft_dead_list κs ={lftE}=∗ lty_own_pre true lt_full (Owned wl) π r l
+ | Uniq κ' γ =>
+ place_rfn_interp_mut r γ ∗
+ (lft_dead_list κs -∗ place_rfn_interp_mut r γ ={lftE}=∗ lty_own_pre true lt_full (Uniq κ' γ) π r l)
+ | Shared κ =>
+ (*False*)
+ lty_own_pre true lt_full (Shared κ) π r l
+ end)%I;
+ lty_own_pre core (@ShadowedLty rt_cur lt_cur r_cur lt_full) k π r l :=
+ (if core then lty_own_pre true lt_full k π r l
+ else
+ ∃ (Heq_cur : rt_cur = lty_rt lt_cur),
+ ⌜lty_st lt_cur = lty_st lt_full⌠∗
+ lty_own_pre core lt_cur k π ((rew Heq_cur in r_cur)) l ∗
+ lty_own_pre core lt_full k π r l)%I
+ .
+ Solve Obligations with first [unfold lty_size_rel, ltof; simpl; lia | intros; eauto using struct_lts_size_decreasing, array_lts_size_decreasing].
+
+ Definition lty_own := @lty_own_pre false.
+ Definition lty_own_core := @lty_own_pre true.
+
+ (** Basic laws of ltypes *)
+
+ (* NOTE: this does not hold true for [OpenedLtype]! *)
+ Lemma lty_own_pre_shr_pers core (lt : lty) κ π r l :
+ (*match lt with OpenedLty _ _ _ _ _ => False | _ => True end →*)
+ Persistent (lty_own_pre core lt (Shared κ) π r l).
+ Proof.
+ (*intros ?;*)
+ induction lt using lty_induction in κ, π, r, l, core |-*; simp lty_own_pre;
+ destruct core; simpl; try done; apply _.
+ Qed.
+ Global Instance lty_own_shr_pers (lt : lty) κ π r l :
+ (*TCDone (match lt with OpenedLty _ _ _ _ _ => False | _ => True end) →*)
+ Persistent (lty_own lt (Shared κ) π r l).
+ Proof. apply lty_own_pre_shr_pers. Qed.
+ Global Instance lty_own_core_shr_pers (lt : lty) κ π r l :
+ (*TCDone (match lt with OpenedLty _ _ _ _ _ => False | _ => True end) →*)
+ Persistent (lty_own_core lt (Shared κ) π r l).
+ Proof. apply lty_own_pre_shr_pers. Qed.
+
+ Lemma lty_core_idemp (lt : lty) :
+ lty_core (lty_core lt) = lty_core lt.
+ Proof.
+ induction lt as [ | | | | | | | | lts IH ? | rt def len lts IH | | | ] using lty_induction;
+ [simpl; f_equiv.. | | ]; [solve[eauto].. | | | | | ].
+ - done.
+ - induction lts as [ | lt lts IH']; first done.
+ simpl. rewrite IH; first last. { apply elem_of_cons; eauto. }
+ f_equiv. apply IH'.
+ intros. apply IH. apply elem_of_cons; eauto.
+ - induction lts as [ | [j lt] lts IH2]; first done.
+ simpl. erewrite IH; first last. { apply elem_of_cons; eauto. }
+ f_equiv. apply IH2.
+ intros. eapply (IH (i)). apply elem_of_cons; eauto.
+ - done.
+ - done.
+ Qed.
+
+ Lemma lty_own_has_layout (lt : lty) k π r l :
+ lty_own lt k Ï€ r l -∗ ∃ ly : layout, ⌜syn_type_has_layout (lty_st lt) ly⌠∗ ⌜l `has_layout_loc` lyâŒ.
+ Proof.
+ iIntros "Hown". rewrite /lty_own.
+ iInduction lt as [ | | | | | | | | | rt def len lts IH | ?? lt_cur lt_inner lt_full Cpre Cpost | | ] "IH" using lty_induction forall (k); simp lty_own_pre.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - destruct k; [ | done..].
+ iDestruct "Hown" as "(%ly & ? & ? & ? & ? & ?)"; eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)"; eauto.
+ - iDestruct "Hown" as "(%sl & % & % & % & _)".
+ iExists sl. simpl. iPureIntro. split; last done. by apply use_struct_layout_alg_Some_inv.
+ - iDestruct "Hown" as "(%ly & % & % & % & _)".
+ iExists (mk_array_layout ly len). iSplitR; last done.
+ iPureIntro. simpl.
+ eapply syn_type_has_layout_array; done.
+ - simpl. iDestruct "Hown" as "(%ly & ? & ? & ? & ? & _)".
+ eauto.
+ - iDestruct "Hown" as "(%ly & ? & ? & _)". eauto.
+ - iDestruct ("Hown") as (->) "(%Hst & Ha & Hb)".
+ simpl. rewrite -Hst. iApply ("IH" with "Ha").
+ Qed.
+
+ Lemma lty_own_loc_in_bounds (lt : lty) k π r l ly :
+ syn_type_has_layout (lty_st lt) ly →
+ lty_own lt k π r l -∗ loc_in_bounds l 0 ly.(ly_size).
+ Proof.
+ iIntros (Ha) "Hown". rewrite /lty_own.
+ iInduction lt as [ | | | | | | | | | | ? ??? | | ] "IH" using lty_induction forall (k); simp lty_own_pre.
+ - iDestruct "Hown" as "(%ly' & %Halg' & ? & ? & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & % & _ & _ & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & % & _ & _ & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - destruct k; [ | done..]. iDestruct "Hown" as "(%ly' & % & ? & ? & ? & ?)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & % & _ & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & % & _ & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & % & _ & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & % & _ & ? & _)".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%sl & %Hsl & _ & _ & ? & _)".
+ apply use_struct_layout_alg_Some_inv in Hsl.
+ have ?: layout_of sl = ly by eapply syn_type_has_layout_inj. by subst.
+ - iDestruct "Hown" as "(%ly' & %Halg & _ & _ & ? & _)".
+ apply syn_type_has_layout_array_inv in Ha as (ly0 & Halg' & -> & ?).
+ assert (ly0 = ly') as -> by by eapply syn_type_has_layout_inj.
+ done.
+ - iDestruct "Hown" as "(%ly' & %Halg & ? & ? & ? & ? & _)".
+ simpl in *. assert (ly' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ iFrame.
+ - iDestruct "Hown" as "(%ly' & %Halg & ? & ? & _)".
+ simpl in *. assert (ly' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ iFrame.
+ - iDestruct "Hown" as (->) "(%Hst & Ha & Hb)".
+ simpl in Ha. rewrite -Hst in Ha.
+ iApply "IH"; done.
+ Qed.
+
+ Import EqNotations.
+ Definition transport_rfn {rt1 rt2} (Heq : rt1 = rt2) (r1 : place_rfn rt1) : place_rfn rt2 :=
+ rew [place_rfn] Heq in r1.
+ Arguments transport_rfn : simpl never.
+
+ Lemma lty_own_pre_rfn_eq (lt : lty) π (r1 r2 : place_rfn (lty_rt lt)) core (b : bor_kind) (l : loc) :
+ r1 = r2 → lty_own_pre core lt b π r1 l -∗ lty_own_pre core lt b π r2 l.
+ Proof.
+ intros ->. auto.
+ Qed.
+ Lemma lty_own_pre_rfn_eq' (lt : lty) π (r1 r2 : place_rfn (lty_rt lt)) core (b : bor_kind) (l : loc) :
+ r1 = r2 → lty_own_pre core lt b π r1 l ⊣⊢ lty_own_pre core lt b π r2 l.
+ Proof.
+ intros ->. auto.
+ Qed.
+
+ Lemma lty_core_plist_rt_eq lts :
+ plist (λ lt, place_rfn (lty_rt lt)) (fmap lty_core lts) = plist (λ lt, place_rfn (lty_rt lt)) lts.
+ Proof.
+ induction lts as [ | lt lts IH]; simpl; first done.
+ rewrite /plist. rewrite lty_core_rt_eq. f_equiv. apply IH.
+ Qed.
+
+ Local Definition pzipl_core_map_fun := λ (p : sigT (λ lt, place_rfn (lty_rt lt))),
+ (existT (lty_core (projT1 p)) (rew <-[place_rfn] (lty_core_rt_eq (projT1 p)) in (projT2 p)) :
+ sigT (λ lt, place_rfn (lty_rt lt))).
+ Local Lemma pzipl_core_map_eq (lts : list lty) (r : plist (λ lt, place_rfn (lty_rt lt)) (map lty_core lts)) (Heq : plist (λ lt : lty, place_rfn (lty_rt lt)) (map lty_core lts) =
+ plist (λ lt : lty, place_rfn (lty_rt lt)) lts) :
+ pzipl (fmap lty_core lts) r = fmap pzipl_core_map_fun (pzipl lts (rew [id] Heq in r)).
+ Proof.
+ rewrite (pzipl_fmap_eqcast lty_core pzipl_core_map_fun _ _ lty_core_plist_rt_eq).
+ - rewrite (UIP_t _ _ _ (lty_core_plist_rt_eq lts) Heq). done.
+ - intros. rewrite lty_core_rt_eq. done.
+ - intros lt ? Heq1. unfold pzipl_core_map_fun. f_equiv; simpl.
+ generalize (lty_core_rt_eq lt) as Heq'.
+ move : Heq1.
+ generalize (lty_rt lt) => T.
+ intros Heq1 <-. rewrite (UIP_refl _ _ Heq1). done.
+ Qed.
+ (* Follows the same structure as the proof for the struct ltype unfolding.
+ Essentially the relevant part of the proof of [lty_own_core_core] below. *)
+ Local Lemma StructLty_own_core_core_lift (sl : struct_layout) (lts : list lty) (r' : plist (λ lt, place_rfn (lty_rt lt)) (map lty_core lts)) (Heq : plist (λ lt : lty, place_rfn (lty_rt lt)) (map lty_core lts) = plist (λ lt : lty, place_rfn (lty_rt lt)) lts) π l k :
+ (∀ lt : lty, lt ∈ lts → ∀ k π r (Heq : lty_rt (lty_core lt) = lty_rt lt) l, lty_own_pre true (lty_core lt) k π r l ≡ lty_own_pre true lt k π (transport_rfn Heq r) l) →
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (pzipl (map lty_core lts) r') (λ ly : layout, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre true (projT1 ty) k π (projT2 ty) (l +ₗ offset_of_idx (sl_members sl) i)) ⊣⊢
+ [∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (pzipl lts (rew [id] Heq in r')) (λ ly : layout, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre true (projT1 ty) k π (projT2 ty) (l +ₗ offset_of_idx (sl_members sl) i).
+ Proof.
+ intros IH.
+ rewrite pzipl_core_map_eq.
+ set (ps' := (λ ly : layout, pzipl_core_map_fun (existT (UninitLty (UntypedSynType ly)) (PlaceIn ())))).
+ rewrite (pad_struct_ext _ _ _ ps'); first last.
+ { intros. unfold ps', pzipl_core_map_fun. simpl. f_equiv.
+ generalize (lty_core_rt_eq (UninitLty (UntypedSynType ly))) => Heq2.
+ rewrite (UIP_refl _ _ Heq2). done. }
+ rewrite pad_struct_fmap.
+ rewrite big_sepL_fmap.
+ iApply big_sepL_proper.
+ iIntros (? [lt r0] Hlook).
+ specialize (lty_core_rt_eq lt) as Heq2.
+ apply pad_struct_lookup_Some_1 in Hlook as (n & ly & ? & [[_ Hlook] | [_ Huninit]]).
+ + eapply pzipl_lookup_inv in Hlook.
+ f_equiv => Hly. f_equiv. f_equiv.
+ { simpl. f_equiv. f_equiv. rewrite lty_core_syn_type_eq. done. }
+ unshelve rewrite IH; first last. { by eapply elem_of_list_lookup_2. }
+ 2: apply Heq2.
+ iApply lty_own_pre_rfn_eq'.
+ clear. simpl.
+ generalize (lty_core_rt_eq lt) as Heq3.
+ move : Heq2 r0. generalize (lty_rt lt) => T.
+ intros <- ? Heq3. rewrite (UIP_refl _ _ Heq3) //.
+ + injection Huninit as -> ->.
+ simpl. clear. f_equiv => Hly. f_equiv. f_equiv.
+ iApply lty_own_pre_rfn_eq'.
+ generalize (lty_core_rt_eq (UninitLty (UntypedSynType ly))) => Heq.
+ rewrite (UIP_refl _ _ Heq). done.
+ Qed.
+
+
+ Local Lemma ArrayLty_own_core_core_lift {rt} st ly (lts : list lty) (r' : list (place_rfn rt)) π l k :
+ (∀ lt : lty, lt ∈ lts → ∀ k π r (Heq : lty_rt (lty_core lt) = lty_rt lt) l, lty_own_pre true (lty_core lt) k π r l ≡ lty_own_pre true lt k π (transport_rfn Heq r) l) →
+ ([∗ list] i ↦ ty ∈ zip (fmap lty_core lts) r', ∃ Heq : lty_rt ty.1 = rt, ⌜lty_st ty.1 = st⌠∗ lty_own_pre true ty.1 k π (rew <- [place_rfn] Heq in ty.2) (l offset{ly}ₗ i)) ⊣⊢
+ ([∗ list] i ↦ ty ∈ zip lts r', ∃ Heq : lty_rt ty.1 = rt, ⌜lty_st ty.1 = st⌠∗ lty_own_pre true ty.1 k π (rew <- [place_rfn] Heq in ty.2) (l offset{ly}ₗ i)).
+ Proof.
+ intros IH.
+ rewrite zip_fmap_l big_sepL_fmap.
+ apply big_sepL_proper.
+ intros ? [lt r] Hlook.
+ apply lookup_zip in Hlook as [Hlook1 Hlook2].
+ assert (lty_rt (lty_core lt) = lty_rt lt) as Heq3. { rewrite lty_core_rt_eq. done. }
+ simpl in *. iSplit.
+ - iIntros "(%Heq & %Hst & Hb)". assert (Heq2 : lty_rt lt = rt). { rewrite -lty_core_rt_eq. done. }
+ iExists Heq2. rewrite lty_core_syn_type_eq in Hst. iSplitR; first done.
+ apply elem_of_list_lookup_2 in Hlook1.
+ unshelve rewrite IH; [done | | done].
+ clear. subst rt. cbn.
+ move: Heq2 Heq3 r. intros <-. intros Heq. rewrite (UIP_refl _ _ Heq). eauto.
+ - iIntros "(%Heq & %Hst & Hb)". assert (Heq2 : lty_rt (lty_core lt) = rt).
+ { rewrite lty_core_rt_eq. done. }
+ iExists Heq2. rewrite lty_core_syn_type_eq. iSplitR; first done.
+ apply elem_of_list_lookup_2 in Hlook1. unshelve rewrite IH; [done | | done].
+ clear. subst rt. cbn.
+ move: Heq2 Heq3 r. intros ->. intros Heq. rewrite (UIP_refl _ _ Heq). eauto.
+ Qed.
+
+ Lemma OfTyLty_core_id {rt} (ty : type rt) :
+ lty_core (OfTyLty ty) = OfTyLty ty.
+ Proof. done. Qed.
+
+ Lemma lty_own_core_core (lt : lty) k π r r' Heq l :
+ r' = (transport_rfn Heq r) →
+ lty_own_pre true (lty_core lt) k π r l ≡ lty_own_pre true lt k π r' l.
+ Proof.
+ intros ->. rewrite /lty_own_core.
+ induction lt as [ | | | | lt IH κ | lt IH κ | lt IH | lt ls IH | lts IH sls | rt def len lts IH | | | ] using lty_induction in k, π, r, l, Heq |-*; simpl in *.
+ - simp lty_own_pre. rewrite (UIP_refl _ _ Heq). done.
+ - simp lty_own_pre. rewrite (UIP_refl _ _ Heq). done.
+ - rewrite (UIP_refl _ _ Heq). done.
+ - rewrite (UIP_refl _ _ Heq). done.
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2.
+ move: r Heq Heq2 IH.
+ generalize (lty_core lt) as lt' => lt'.
+ intros r Heq Heq2 IH.
+ f_equiv.
+ all: unshelve setoid_rewrite IH; [done.. | ].
+ all: revert r Heq Heq2.
+ all: generalize (lty_rt lt') => ?.
+ all: intros r ? ->.
+ all: solve [ done | rewrite (UIP_refl _ _ Heq) //].
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2.
+ move: r Heq Heq2 IH.
+ generalize (lty_core lt) as lt' => lt'.
+ intros r Heq Heq2 IH.
+ f_equiv.
+ all: unshelve setoid_rewrite IH; [done.. | ].
+ all: revert r Heq Heq2.
+ all: generalize (lty_rt lt') => ?.
+ all: intros r ? ->.
+ all: solve [ done | rewrite (UIP_refl _ _ Heq) //].
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_syn_type_eq lt) as Hst.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2 Hst.
+ move: r Heq Heq2 IH Hst.
+ generalize (lty_core lt) as lt' => lt'.
+ intros r Heq Heq2 IH Hst.
+ f_equiv.
+ all: unshelve setoid_rewrite IH; [done.. | ].
+ all: revert r Heq Heq2.
+ all: generalize (lty_rt lt') => ?.
+ all: intros r ? ->.
+ all: try rewrite Hst.
+ all: first [ done | rewrite (UIP_refl _ _ Heq) // | idtac].
+
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_syn_type_eq lt) as Hst.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2 Hst.
+ move: r Heq Heq2 IH Hst.
+ generalize (lty_core lt) as lt' => lt'.
+ intros r Heq Heq2 IH Hst.
+ f_equiv.
+ all: unshelve setoid_rewrite IH; [done.. | ].
+ all: revert r Heq Heq2.
+ all: generalize (lty_rt lt') => ?.
+ all: intros r ? ->.
+ all: try rewrite Hst.
+ all: first [ done | rewrite (UIP_refl _ _ Heq) // | idtac].
+ - simp lty_own_pre. fold lty_rt.
+ do 5 f_equiv.
+ { rewrite map_length. done. }
+ do 2 f_equiv.
+ all: setoid_rewrite big_sepL_P_eq.
+ all: simpl.
+ 3: do 3 f_equiv;
+ [move : r; simpl; rewrite <-Heq; done | do 2 f_equiv].
+ 1: f_equiv.
+ all: iSplit.
+ all: iIntros "(%r' & Hrfn & Hb)".
+ all: first [iExists (rew [id] Heq in r') | iExists (rew <-[id] Heq in r')].
+ all: iSplitL "Hrfn";
+ [ clear; try move: r'; try move: r; rewrite <-Heq; done| ].
+ all: unshelve rewrite StructLty_own_core_core_lift;
+ [ apply Heq| | done].
+ all: rewrite ?rew_invert'; done.
+ - simp lty_own_pre.
+ do 6 f_equiv.
+ (*{ rewrite Forall_fmap. simpl.*)
+ (*iPureIntro. eapply Forall_iff. intros []; done. }*)
+ fold lty_rt. simpl.
+ rewrite (UIP_refl _ _ Heq). clear Heq.
+ f_equiv.
+ all: repeat f_equiv; try done.
+ all: rewrite !big_sepL_P_eq.
+ all: rewrite -OfTyLty_core_id.
+ all: rewrite interpret_iml_fmap.
+ all: eapply ArrayLty_own_core_core_lift.
+ all: intros ? [-> | []]%elem_of_interpret_iml_inv; simpl.
+ all: intros ??? Heq; try rewrite (UIP_refl _ _ Heq); eauto.
+ - simp lty_own_pre. rewrite (UIP_refl _ _ Heq). done.
+ - simp lty_own_pre.
+ - simp lty_own_pre.
+ Qed.
+ Lemma lty_own_core_core' (lt : lty) k π r Heq l :
+ lty_own_pre true (lty_core lt) k π r l ≡ lty_own_pre true lt k π (transport_rfn Heq r) l.
+ Proof.
+ rewrite lty_own_core_core; first done. done.
+ Qed.
+
+ Local Lemma StructLty_own_core_equiv_lift (sl : struct_layout) (lts : list lty) r (r' : plist (λ lt, place_rfn (lty_rt lt)) (fmap lty_core lts)) (Heq : plist (λ lt : lty, place_rfn (lty_rt lt)) (fmap lty_core lts) = plist (λ lt : lty, place_rfn (lty_rt lt)) lts) π l k (core : bool) :
+ (∀ (lt : lty), lt ∈ lts → ∀ k π r (Heq : lty_rt lt = lty_rt (lty_core lt)) l, lty_own_pre true lt k π r l ≡ lty_own_pre core (lty_core lt) k π (transport_rfn Heq r) l) →
+ r = rew [id] Heq in r' →
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (pzipl lts r) (λ ly : layout, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre true (projT1 ty) k π (projT2 ty) (l +ₗ offset_of_idx (sl_members sl) i)) ⊣⊢
+ [∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (pzipl (fmap lty_core lts) r') (λ ly : layout, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre core (projT1 ty) k π (projT2 ty) (l +ₗ offset_of_idx (sl_members sl) i).
+ Proof.
+ intros IH.
+ rewrite pzipl_core_map_eq.
+ set (ps' := (λ ly : layout, pzipl_core_map_fun (existT (UninitLty (UntypedSynType ly)) (PlaceIn ())))).
+ rewrite (pad_struct_ext _ (pzipl_core_map_fun <$> _) _ ps'); first last.
+ { intros. unfold ps', pzipl_core_map_fun. simpl. f_equiv.
+ generalize (lty_core_rt_eq (UninitLty (UntypedSynType ly))) => Heq2.
+ rewrite (UIP_refl _ _ Heq2). done. }
+ intros ->.
+ rewrite pad_struct_fmap.
+ rewrite big_sepL_fmap.
+ iApply big_sepL_proper.
+ iIntros (? [lt r0] Hlook).
+ specialize (lty_core_rt_eq lt) as Heq2.
+ apply pad_struct_lookup_Some_1 in Hlook as (n & ly & ? & [[_ Hlook] | [_ Huninit]]).
+ + eapply pzipl_lookup_inv in Hlook.
+ f_equiv => ly'. f_equiv. f_equiv. { simpl. f_equiv. f_equiv. rewrite lty_core_syn_type_eq //. }
+ unshelve rewrite IH; first last. { by eapply elem_of_list_lookup_2. }
+ 2: { simpl. apply (eq_sym Heq2). }
+ simpl.
+ apply elem_of_list_lookup_2 in Hlook.
+ rewrite -!IH; done.
+ + injection Huninit as -> ->.
+ simpl. clear.
+ generalize (lty_core_rt_eq (UninitLty (UntypedSynType ly))) => Heq.
+ rewrite (UIP_refl _ _ Heq).
+ do 4 f_equiv.
+ destruct core.
+ * by iApply lty_own_pre_rfn_eq'.
+ * simp lty_own_pre; done.
+ Qed.
+
+ Local Lemma ArrayLty_own_core_equiv_lift {rt} core st ly (lts : list lty) (r' : list (place_rfn rt)) π l k :
+ (∀ lt : lty, lt ∈ lts → ∀ k π r (Heq : lty_rt lt = lty_rt (lty_core lt)) l, lty_own_pre true lt k π (r) l ≡ lty_own_pre core (lty_core lt) k π (transport_rfn Heq r) l) →
+ ([∗ list] i ↦ ty ∈ zip (fmap lty_core lts) r', ∃ Heq : lty_rt ty.1 = rt, ⌜lty_st ty.1 = st⌠∗ lty_own_pre core ty.1 k π (rew <- [place_rfn] Heq in ty.2) (l offset{ly}ₗ i)) ⊣⊢
+ ([∗ list] i ↦ ty ∈ zip lts r', ∃ Heq : lty_rt ty.1 = rt, ⌜lty_st ty.1 = st⌠∗ lty_own_pre true ty.1 k π (rew <- [place_rfn] Heq in ty.2) (l offset{ly}ₗ i)).
+ Proof.
+ intros IH.
+ rewrite zip_fmap_l big_sepL_fmap.
+ apply big_sepL_proper.
+ intros ? [lt r] Hlook.
+ apply lookup_zip in Hlook as [Hlook1 Hlook2].
+ assert (lty_rt (lty_core lt) = lty_rt lt) as Heq3. { rewrite lty_core_rt_eq. done. }
+ simpl in *. iSplit.
+ - iIntros "(%Heq & %Hst & Hb)". assert (Heq2 : lty_rt lt = rt). { rewrite -lty_core_rt_eq. done. }
+ iExists Heq2. rewrite lty_core_syn_type_eq in Hst. iSplitR; first done.
+ apply elem_of_list_lookup_2 in Hlook1.
+ unshelve rewrite IH; [ done | | done].
+ clear. subst rt. cbn.
+ move: Heq2 Heq3 r. intros ->. intros Heq. rewrite (UIP_refl _ _ Heq). eauto.
+ - iIntros "(%Heq & %Hst & Hb)". assert (Heq2 : lty_rt (lty_core lt) = rt).
+ { rewrite lty_core_rt_eq. done. }
+ iExists Heq2. rewrite lty_core_syn_type_eq. iSplitR; first done.
+ apply elem_of_list_lookup_2 in Hlook1. unshelve rewrite IH; [done | | done].
+ clear. subst rt. cbn.
+ move: Heq2 Heq3 r. intros <-. intros Heq. rewrite (UIP_refl _ _ Heq). eauto.
+ Qed.
+
+ Lemma lty_own_core_equiv (lt : lty) core k π r l Heq :
+ lty_own_pre true lt k π r l ≡ lty_own_pre core (lty_core lt) k π (transport_rfn Heq r) l.
+ Proof.
+ rewrite /lty_own_core /lty_own.
+ induction lt as [ | | | | lt IH κ | lt IH κ | lt IH | lt ls IH | lts IH sls | def len lts IH IH' | | | ] using lty_induction in k, π, r, l, Heq, core |-*; simpl in *.
+ - simp lty_own_pre. rewrite (UIP_refl _ _ Heq). done.
+ - simp lty_own_pre. rewrite (UIP_refl _ _ Heq). done.
+ - rewrite (UIP_refl _ _ Heq). simp lty_own_pre. done.
+ - rewrite (UIP_refl _ _ Heq). simp lty_own_pre. done.
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2.
+ f_equiv.
+ 3: unshelve setoid_rewrite (lty_own_core_core' lt); [ done | ].
+ all: unshelve setoid_rewrite (IH core); [done.. | ].
+ all: clear.
+ all: move: r Heq Heq2.
+ all: generalize (lty_rt lt) => ?.
+ all: intros r ? <-.
+ all: rewrite (UIP_refl _ _ Heq); simpl.
+ all: repeat f_equiv; done.
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2.
+ f_equiv.
+ all: unshelve setoid_rewrite (IH core); [done.. | ].
+ all: clear.
+ all: move: r Heq Heq2.
+ all: generalize (lty_rt lt) => ?.
+ all: intros r ? <-.
+ all: rewrite (UIP_refl _ _ Heq); simpl.
+ all: by repeat f_equiv.
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_syn_type_eq lt) as Hst.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2 Hst.
+ f_equiv.
+ 3: unshelve setoid_rewrite (lty_own_core_core' lt); [ done | ].
+ all: unshelve setoid_rewrite (IH core); [done.. | ].
+ all: clear -Hst.
+ all: move: r Heq Heq2.
+ all: generalize (lty_rt lt) => ?.
+ all: intros r ? <-.
+ all: rewrite (UIP_refl _ _ Heq); simpl.
+ all: try rewrite Hst.
+ all: by repeat f_equiv.
+ - simp lty_own_pre. fold lty_rt.
+ specialize (lty_core_syn_type_eq lt) as Hst.
+ specialize (lty_core_rt_eq lt) as Heq2.
+ do 5 f_equiv.
+ simpl. clear -IH Heq2 Hst.
+ f_equiv.
+ 3: unshelve setoid_rewrite (lty_own_core_core' lt); [ done | ].
+ all: unshelve setoid_rewrite (IH core); [done.. | ].
+ all: clear -Hst.
+ all: move: r Heq Heq2.
+ all: generalize (lty_rt lt) => ?.
+ all: intros r ? <-.
+ all: rewrite (UIP_refl _ _ Heq); simpl.
+ all: try rewrite Hst.
+ all: by repeat f_equiv.
+ - simp lty_own_pre. fold lty_rt.
+ do 5 f_equiv.
+ { rewrite map_length. done. }
+ do 2 f_equiv.
+ all: simpl.
+ all: setoid_rewrite big_sepL_P_eq.
+ 3: do 3 f_equiv;
+ [move : r; rewrite <-Heq; done | do 2 f_equiv].
+ 1: f_equiv.
+ all: iSplit.
+ all: iIntros "(%r' & Hrfn & Hb)".
+ all: first [iExists (rew [id] Heq in r') | iExists (rew <-[id] Heq in r')].
+ all: iSplitL "Hrfn";
+ [ clear; try move: r'; try move: r; rewrite <-Heq; done| ].
+ all: rewrite -(StructLty_own_core_equiv_lift _ _ _ _ (eq_sym Heq)); [done | intros; apply IH; done | ].
+ all: clear; move: r'; generalize (eq_sym Heq); move : Heq.
+ all: intros -> Heq; rewrite (UIP_refl _ _ Heq) //.
+ - simp lty_own_pre. fold lty_rt.
+ do 6 f_equiv.
+ (*{ iPureIntro. rewrite Forall_fmap. eapply Forall_iff. intros []; done. }*)
+ simpl.
+ rewrite (UIP_refl _ _ Heq). clear Heq. simpl.
+ f_equiv.
+ all: repeat f_equiv; try done.
+ all: rewrite !big_sepL_P_eq.
+ all: rewrite -OfTyLty_core_id.
+ all: rewrite interpret_iml_fmap ArrayLty_own_core_equiv_lift; first done.
+ all: intros ? [-> | []]%elem_of_interpret_iml_inv; simpl; intros ??? Heq ?.
+ all: try rewrite (UIP_refl _ _ Heq); simpl.
+ all: try by (eapply IH').
+ all: simp lty_own_pre; done.
+ - rewrite (UIP_refl _ _ Heq). simp lty_own_pre. done.
+ - simp lty_own_pre.
+ - simp lty_own_pre.
+ Qed.
+
+ Local Lemma place_rfn_interp_shared_transport_eq {rt rt'} (r : place_rfn rt) (r' : rt) (Heq : rt = rt') :
+ place_rfn_interp_shared r r' -∗
+ place_rfn_interp_shared (transport_rfn Heq r) (rew [id] Heq in r').
+ Proof.
+ subst. auto.
+ Qed.
+
+ Lemma lty_own_shared_to_core lt κ0 π r l Heq :
+ lty_own lt (Shared κ0) π r l -∗ lty_own (lty_core lt) (Shared κ0) π (transport_rfn Heq r) l.
+ Proof.
+ rewrite /lty_own_core /lty_own.
+ induction lt as [ | | | | lt IH κ | lt IH κ | lt IH | lt ls IH | lts IH sls | rt def len lts IH | | | ???? IH1 IH2] using lty_induction in κ0, π, r, l, Heq |-*; simpl in *.
+ - simp lty_own_pre. iIntros "(% & _ & _ & _ & _ & [])".
+ - simp lty_own_pre. iIntros "(% & _ & _ & _ & _ & % & _ & [])".
+ - rewrite (UIP_refl _ _ Heq). auto.
+ - rewrite (UIP_refl _ _ Heq). auto.
+ - simp lty_own_pre. fold lty_rt.
+ iIntros "(%ly & %Halg & %Hly & Hlb & %r' & %γ & Ha & #Hl)".
+ iExists ly. iR. iR. iFrame.
+ set (Heq' := lty_core_rt_eq lt).
+ iExists (rew <-[place_rfn] Heq' in r'), γ.
+ iSplitL "Ha".
+ { iClear "Hl". clear -Heq'.
+ move: Heq' Heq r r'.
+ simpl. generalize (lty_rt lt) => ?? Heq *. subst.
+ rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hl" as "(%li & Hf & Hl)". iModIntro. iExists li. iFrame.
+ iApply IH. done.
+ - simp lty_own_pre. fold lty_rt.
+ iIntros "(%ly & %Halg & %Hly & Hlb & %r' & Ha & #Hl)".
+ iExists ly. iR. iR. iFrame.
+ set (Heq' := lty_core_rt_eq lt).
+ iExists (rew <-[place_rfn] Heq' in r').
+ iSplitL "Ha".
+ { iClear "Hl". clear -Heq'.
+ move: Heq' Heq r r'.
+ simpl. generalize (lty_rt lt) => ?? Heq *. subst.
+ rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hl" as "(%li & Hf & Hl)". iModIntro. iExists li. iFrame.
+ iApply IH. done.
+ - simp lty_own_pre. fold lty_rt.
+ iIntros "(%ly & %Halg & %Hly & Hlb & %r' & Ha & #Hl)".
+ iExists ly. iR. iR. iFrame.
+ set (Heq' := lty_core_rt_eq lt).
+ iExists (rew <-[place_rfn] Heq' in r').
+ iSplitL "Ha".
+ { iClear "Hl". clear -Heq'.
+ move: Heq' Heq r r'.
+ simpl. fold lty_rt.
+ generalize (lty_rt lt) => ?? Heq *. subst.
+ rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hl" as "(%li & Hf & Hl)". iModIntro. iExists li. iFrame.
+ iApply IH. done.
+ - simp lty_own_pre. fold lty_rt.
+ iIntros "(%ly & %Halg & %Hly & Hlb & %r' & %li & Ha & #Hl)".
+ iExists ly. iR. iR. iFrame.
+ set (Heq' := lty_core_rt_eq lt).
+ iExists (rew <-[place_rfn] Heq' in r'), li.
+ iSplitL "Ha".
+ { iClear "Hl". clear -Heq'.
+ move: Heq' Heq r r'.
+ simpl. fold lty_rt.
+ generalize (lty_rt lt) => ?? Heq *. subst.
+ rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hl" as "(Hf & Hl)". iModIntro. iFrame.
+ iApply IH. done.
+ - simp lty_own_pre. fold lty_rt.
+ iIntros "(%sl & %Halg & %Hlen & %Hly & Hlb & %r' & Ha & #Hl)".
+ rewrite big_sepL_P_eq.
+ iExists sl. iR.
+ rewrite fmap_length. iR. iR. iFrame.
+ (*set (Heq' := lty_core_rt_eq ).*)
+ simpl in r'.
+ simpl.
+ iExists (rew [id]Heq in r').
+ iSplitL "Ha".
+ { by iApply place_rfn_interp_shared_transport_eq. }
+ iModIntro. iMod "Hl". iModIntro.
+ rewrite big_sepL_P_eq.
+ clear.
+ rewrite pzipl_core_map_eq; first done; intros ?.
+ (*rewrite pad_struct_fmap. *)
+ (* TODO *)
+ admit.
+ - simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hsz & %Hly & Hlb & %r' & Ha & %Hlen & #Hl)".
+ rewrite big_sepL_P_eq.
+ iExists ly. iR. iR. iR. iFrame.
+ (*set (Heq' := lty_core_rt_eq ).*)
+ iExists (rew [id]Heq in r').
+ iSplitL "Ha". { by iApply place_rfn_interp_shared_transport_eq. }
+ iSplitR. { rewrite -Hlen. iPureIntro. clear. rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hl". iModIntro.
+ rewrite big_sepL_P_eq.
+ (* TODO *)
+ admit.
+ - simp lty_own_pre.
+ iIntros "(%ly & % & % & ? & % & % & [])".
+ - simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & Hlb & Hown)".
+ clear. rewrite -lty_own_core_equiv. done.
+ - simp lty_own_pre.
+ iIntros "(%Heq_cur & %Hst & Ha & Hb)".
+ iApply (IH2 with "Hb").
+ Admitted.
+
+ (** ** We define derived versions on top that expose the refinement type as an index.
+ This is the variant that will be actually used by the type system. *)
+ Record ltype (rt : Type) := mk_ltype {
+ ltype_lty : lty;
+ ltype_rt_agree : lty_rt ltype_lty = rt;
+ ltype_lty_wf : lty_wf ltype_lty;
+ }.
+ Arguments ltype_lty {_}.
+ Arguments ltype_rt_agree {_}.
+ Arguments ltype_rt_agree : simpl never.
+
+ (* uses PI *)
+ Lemma mk_ltype_irrel {rt} lt Heq1 Heq2 Hwf1 Hwf2 :
+ mk_ltype rt lt Heq1 Hwf1 = mk_ltype rt lt Heq2 Hwf2.
+ Proof.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+
+ Program Definition OfTy {rt} (ty : type rt) : ltype rt := {|
+ ltype_lty := OfTyLty ty;
+ |}.
+ Next Obligation. done. Qed.
+ Next Obligation. done. Qed.
+ Arguments OfTy : simpl never.
+
+ Program Definition AliasLtype (rt : Type) (st : syn_type) (l : loc) : ltype rt := {|
+ ltype_lty := AliasLty rt st l;
+ |}.
+ Next Obligation. done. Qed.
+ Next Obligation. done. Qed.
+
+ Program Definition BlockedLtype {rt} (ty : type rt) (κ : lft) : ltype rt := {|
+ ltype_lty := BlockedLty ty κ;
+ |}.
+ Next Obligation. done. Qed.
+ Next Obligation. done. Qed.
+
+ Program Definition ShrBlockedLtype {rt} (ty : type rt) (κ : lft) : ltype rt := {|
+ ltype_lty := ShrBlockedLty ty κ;
+ |}.
+ Next Obligation. done. Qed.
+ Next Obligation. done. Qed.
+
+
+ Program Definition BoxLtype {rt} (lt : ltype rt) : ltype (place_rfn rt) := {|
+ ltype_lty := BoxLty (lt.(ltype_lty));
+ |}.
+ Next Obligation.
+ by intros rt [lty <-].
+ Qed.
+ Next Obligation.
+ by intros rt [lty <- Hwf].
+ Qed.
+ Arguments BoxLtype : simpl never.
+
+ Program Definition OwnedPtrLtype {rt} (lt : ltype rt) (ls : bool) : ltype (place_rfn rt * loc) := {|
+ ltype_lty := OwnedPtrLty (lt.(ltype_lty)) ls;
+ |}.
+ Next Obligation.
+ by intros rt [lty <-].
+ Qed.
+ Next Obligation.
+ by intros rt [lty <- Hwf].
+ Qed.
+ Arguments OwnedPtrLtype : simpl never.
+
+ Program Definition MutLtype {rt} (lt : ltype rt) (κ : lft) : ltype (place_rfn rt * gname) := {|
+ ltype_lty := MutLty (lt.(ltype_lty)) κ;
+ |}.
+ Next Obligation.
+ by intros rt [lty <-].
+ Qed.
+ Next Obligation.
+ by intros rt [lty <- Hwf].
+ Qed.
+ Arguments MutLtype : simpl never.
+
+ Program Definition ShrLtype {rt} (lt : ltype rt) (κ : lft) : ltype (place_rfn rt) := {|
+ ltype_lty := ShrLty (lt.(ltype_lty)) κ;
+ |}.
+ Next Obligation.
+ by intros rt [lty <-].
+ Qed.
+ Next Obligation.
+ by intros rt [lty <- Hwf].
+ Qed.
+ Arguments ShrLtype : simpl never.
+
+ #[universes(polymorphic)]
+ Program Definition StructLtype {rts : list Type} (lts : hlist ltype rts) (sls : struct_layout_spec) : ltype (plist place_rfn rts) := {|
+ ltype_lty := StructLty (hcmap (@ltype_lty) lts) sls;
+ |}.
+ Next Obligation.
+ intros rts lts sls.
+ induction rts as [ | rt rts IH]; simpl.
+ - inv_hlist lts. done.
+ - inv_hlist lts. intros [lt <-] lts'.
+ simpl. f_equiv. apply IH.
+ Qed.
+ Next Obligation.
+ intros rts lts sls. simpl.
+ induction rts as [ | rt rts IH]; inv_hlist lts; simpl; first done.
+ intros [lt <- Hwf] lts. split; first done. apply IH.
+ Qed.
+ Arguments StructLtype : simpl never.
+
+ Program Definition ArrayLtype {rt : Type} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) : ltype (list (place_rfn rt)) := {|
+ ltype_lty := @ArrayLty rt def len (map (λ '(i, lt), (i, lt.(ltype_lty))) lts);
+ |}.
+ Next Obligation.
+ intros rt def len lts. simpl. done.
+ Qed.
+ Next Obligation.
+ intros rt def len lts. simpl.
+ induction lts as [ | [i lt] lts IH]; simpl; first done.
+ split; last done. split_and!; [ apply ltype_lty_wf | rewrite !ltype_rt_agree// ].
+ Qed.
+
+ Program Definition OpenedLtype {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ) : ltype rt_cur := {|
+ ltype_lty := OpenedLty (ltype_lty lt_cur) (ltype_lty lt_inner) (ltype_lty lt_full) Cpre Cpost;
+ |}.
+ Next Obligation.
+ intros rt_cur rt_inner rt_full lt_cur lt_inner lt_full Cpre Cpost. simpl.
+ rewrite ltype_rt_agree; done.
+ Qed.
+ Next Obligation.
+ intros rt_cur rt_inner rt_full [lt_cur <- Hcur] [lt_inner <- Hinner] [lt_full <- Hfull] Cpre Cpost; simpl.
+ eauto.
+ Qed.
+
+ Program Definition CoreableLtype {rt_full} (κs : list lft) (lt_full : ltype rt_full) : ltype rt_full := {|
+ ltype_lty := CoreableLty κs (ltype_lty lt_full);
+ |}.
+ Next Obligation.
+ intros rt_full κ lt_full. simpl. apply ltype_rt_agree.
+ Qed.
+ Next Obligation.
+ intros rt_full κ [lt_full <- ?]. simpl. eauto.
+ Qed.
+
+ Program Definition ShadowedLtype {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full) : ltype rt_full := {|
+ ltype_lty := ShadowedLty (ltype_lty lt_cur) r_cur (ltype_lty lt_full);
+ |}.
+ Next Obligation.
+ intros rt_cur rt_full lt_cur r_cur lt_full. simpl. apply ltype_rt_agree.
+ Qed.
+ Next Obligation.
+ intros rt_cur rt_full lt_cur r_cur lt_full. split_and!; [apply ltype_lty_wf.. | ].
+ apply ltype_rt_agree.
+ Qed.
+
+ Import EqNotations.
+ Definition ltype_own_pre (core : bool) {rt} (lt : ltype rt) : bor_kind → thread_id → place_rfn rt → loc → iProp Σ :=
+ λ k π r l, lty_own_pre core lt.(ltype_lty) k π (rew <- lt.(ltype_rt_agree) in r) l.
+
+ Local Definition ltype_own_core_def := @ltype_own_pre true.
+ Local Definition ltype_own_core_aux : seal (@ltype_own_core_def). Proof. by eexists. Qed.
+ Definition ltype_own_core := ltype_own_core_aux.(unseal).
+ Lemma ltype_own_core_unseal : @ltype_own_core = ltype_own_core_def.
+ Proof. rewrite -ltype_own_core_aux.(seal_eq) //. Qed.
+ Global Arguments ltype_own_core {_}.
+
+ Local Definition ltype_own_def := @ltype_own_pre false.
+ Local Definition ltype_own_aux : seal (@ltype_own_def). Proof. by eexists. Qed.
+ Definition ltype_own := ltype_own_aux.(unseal).
+ Lemma ltype_own_unseal : @ltype_own = ltype_own_def.
+ Proof. rewrite -ltype_own_aux.(seal_eq) //. Qed.
+ Global Arguments ltype_own {_}.
+
+ Definition ltype_st {rt} (lt : ltype rt) : syn_type := lty_st lt.(ltype_lty).
+ Global Arguments ltype_st : simpl never.
+
+ Program Definition ltype_core {rt} (lt : ltype rt) : ltype rt := {|
+ ltype_lty := lty_core lt.(ltype_lty);
+ |}.
+ Next Obligation.
+ intros rt lt. rewrite lty_core_rt_eq. apply ltype_rt_agree.
+ Qed.
+ Next Obligation.
+ intros rt [lt <- Hwf]; simpl. by apply lty_core_wf.
+ Qed.
+ Global Arguments ltype_core : simpl never.
+
+
+ Section induction.
+ Local Fixpoint make_ltype_hlist (lts : list lty) : Forall_cb lty_wf lts → hlist ltype (fmap lty_rt lts) :=
+ match lts as lts' return Forall_cb lty_wf lts' → hlist ltype (fmap lty_rt lts') with
+ | [] => λ _, +[]
+ | lt :: lts => λ Hwf,
+ (mk_ltype _ lt eq_refl (proj1 Hwf)) +:: make_ltype_hlist lts (proj2 Hwf)
+ end.
+ Local Lemma make_ltype_hlist_lift lts (Hwf : Forall_cb lty_wf lts) (P : ∀ rt, ltype rt → Prop) :
+ (∀ (lt : lty) (Helt : lt ∈ lts) (Hwf : lty_wf lt), P (lty_rt lt) (mk_ltype _ lt eq_refl Hwf)) →
+ (∀ lt0, lt0 ∈ hzipl _ (make_ltype_hlist lts Hwf) → P (projT1 lt0) (projT2 lt0)).
+ Proof.
+ induction lts as [ | lt lts IH]; simpl; intros Ha.
+ - intros ? []%elem_of_nil.
+ - intros [rt lt0]. rewrite elem_of_cons.
+ intros [[= -> ->] | Hel].
+ { apply Ha. apply elem_of_cons; eauto. }
+ eapply IH; last done.
+ intros. eapply Ha. apply elem_of_cons; eauto.
+ Qed.
+ Local Lemma make_ltype_hlist_map_proj_eq lts Hwf :
+ (@ltype_lty +c<$> make_ltype_hlist lts Hwf) = lts.
+ Proof.
+ induction lts as [ | lt lts IH]; first done.
+ simpl. by rewrite IH.
+ Qed.
+
+ Local Fixpoint make_ltype_list {rt} (lts : list (nat * lty)) : Forall_cb (λ '(i, lt), lty_wf lt ∧ lty_rt lt = rt) lts → list (nat * ltype rt) :=
+ match lts as lts' return Forall_cb (λ '(i, lt), lty_wf lt ∧ lty_rt lt = rt) lts' → list (nat * ltype rt) with
+ | [] => λ _, []
+ | (i, lt) :: lts => λ Hwf,
+ (i, mk_ltype _ lt (proj2 (proj1 Hwf)) (proj1 (proj1 Hwf))) :: make_ltype_list lts (proj2 Hwf)
+ end.
+ Local Lemma make_ltype_list_lift {rt} lts (Hwf : Forall_cb (λ '(i, lt), lty_wf lt ∧ lty_rt lt = rt) lts) (P : ∀ rt, ltype rt → Prop) :
+ (∀ rt (lt : lty) Heq1 Heq2 Hwf1 Hwf2, P rt (mk_ltype rt lt Heq1 Hwf1) → P rt (mk_ltype rt lt Heq2 Hwf2)) →
+ (∀ (i : nat) (lt : lty) (Helt : (i, lt) ∈ lts) (Hwf : lty_wf lt), P (lty_rt lt) (mk_ltype _ lt eq_refl Hwf)) →
+ (∀ i lt0, (i, lt0) ∈ make_ltype_list lts Hwf → P _ lt0).
+ Proof.
+ intros P_irrel Ha. induction lts as [ | [i lt] lts IH]; simpl.
+ - intros ? ? []%elem_of_nil.
+ - intros i0 lt0. rewrite elem_of_cons. intros [[= -> ->] | Hel]; first last.
+ { eapply IH; last done. intros. eapply Ha. apply elem_of_cons; by right. }
+ destruct Hwf as [[Hwf Heq] ?].
+ clear IH.
+ unshelve efeed pose proof (Ha i lt) as Ha.
+ { done. } { apply elem_of_cons; by left. }
+ subst rt. eapply P_irrel; done.
+ Qed.
+ Local Lemma make_ltype_list_map_proj_eq {rt} lts Hwf :
+ (map (λ '(i, lt), (i, ltype_lty lt)) (make_ltype_list (rt:=rt) lts Hwf)) = lts.
+ Proof.
+ induction lts as [ | [i lt] lts IH]; simpl; first done.
+ f_equiv. apply IH.
+ Qed.
+
+ Lemma ltype_induction (P : ∀ rt, ltype rt → Prop) :
+ (∀ (rt : Type) (t : type rt) κ, P _ (BlockedLtype t κ)) →
+ (∀ (rt : Type) (t : type rt) κ, P _ (ShrBlockedLtype t κ)) →
+ (∀ (rt : Type) (t : type rt), P _ (OfTy t)) →
+ (∀ (rt : Type) (st : syn_type) (l : loc), P _ (AliasLtype rt st l)) →
+ (∀ (rt : Type) (lt : ltype rt), P _ lt → ∀ κ, P _ (MutLtype lt κ)) →
+ (∀ (rt : Type) (lt : ltype rt), P _ lt → ∀ κ, P _ (ShrLtype lt κ)) →
+ (∀ (rt : Type) (lt : ltype rt), P _ lt → P _ (BoxLtype lt)) →
+ (∀ (rt : Type) (lt : ltype rt) (ls : bool), P _ lt → P _ (OwnedPtrLtype lt ls)) →
+ (∀ (rts : list Type) (lts : hlist ltype rts),
+ (∀ lt, lt ∈ hzipl rts lts → P _ (projT2 lt)) →
+ ∀ sls : struct_layout_spec, P _ (StructLtype lts sls)) →
+ (∀ (rt : Type) (def : type rt) (len : nat) (lts : list (nat * ltype rt)),
+ (∀ i lt, (i, lt) ∈ lts → P _ lt) →
+ P _ (ArrayLtype def len lts)) →
+ (∀ (rt_cur rt_inner rt_full : Type) (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ),
+ P _ lt_cur → P _ lt_inner → P _ lt_full →
+ P _ (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost)) →
+ (∀ (rt_full : Type) κs (lt_full : ltype rt_full), P _ lt_full → P _ (CoreableLtype κs lt_full)) →
+ (∀ (rt_cur rt_full : Type) (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full),
+ P _ lt_cur → P _ lt_full → P _ (ShadowedLtype lt_cur r_cur lt_full)) →
+ ∀ (rt : Type) (lt : ltype rt), P _ lt.
+ Proof.
+ intros Hblocked Hshrblocked Hofty Halias Hmut Hshr Hbox Hptr Hstruct Harr Hopened Hcoreable Hshadow.
+
+ assert (P_irrel:
+ ∀ rt (lt : lty) Heq1 Heq2 Hwf1 Hwf2, P rt (mk_ltype rt lt Heq1 Hwf1) → P rt (mk_ltype rt lt Heq2 Hwf2)).
+ { intros rt lt <- Heq2. rewrite (UIP_refl _ _ Heq2).
+ intros Hwf1 Hwf2. rewrite (proof_irrelevance _ Hwf1 Hwf2). done. }
+
+ intros rt [lt <- Hwf].
+ induction lt as [ | | | | lt IH κ | lt IH κ | lt IH | lt ls IH | lts IH sls | rt def len lts IH | rt_inner rt_full lt_cur lt_inner lt_full Cpre Cpost IH_cur IH_inner IH_full | κ lt_full IH | rt_cur lt_cur r_cur lt_full IH_cur IH_full] using lty_induction; simpl.
+ - eapply P_irrel. apply Hblocked.
+ - eapply P_irrel. apply Hshrblocked.
+ - eapply P_irrel. apply Hofty.
+ - eapply P_irrel. apply Halias.
+ - specialize (Hmut _ _ (IH Hwf)). eapply P_irrel. apply Hmut.
+ - specialize (Hshr _ _ (IH Hwf)). eapply P_irrel. apply Hshr.
+ - specialize (Hbox _ _ (IH Hwf)). eapply P_irrel. apply Hbox.
+ - specialize (Hptr _ _ ls (IH Hwf)). eapply P_irrel. apply Hptr.
+ - specialize (make_ltype_hlist_lift lts Hwf P IH) as IH'.
+ specialize (Hstruct _ _ IH' sls). clear -Hstruct P_irrel.
+ move: Hstruct. unfold StructLtype.
+ generalize (StructLtype_obligation_2 (lty_rt <$> lts) (make_ltype_hlist lts Hwf) sls) as Hwf'.
+ generalize (StructLtype_obligation_1 (lty_rt <$> lts) (make_ltype_hlist lts Hwf) sls) as Heq.
+ rewrite make_ltype_hlist_map_proj_eq.
+ simpl. intros <- Hwf'.
+ eapply P_irrel.
+ - simpl in Hwf.
+ specialize (make_ltype_list_lift lts Hwf P P_irrel IH) as IH2.
+ specialize (Harr _ def len _ IH2).
+ move: Harr. rewrite /ArrayLtype.
+ generalize (ArrayLtype_obligation_2 _ def len (make_ltype_list lts Hwf)).
+ generalize (ArrayLtype_obligation_1 _ def len (make_ltype_list lts Hwf)).
+ rewrite make_ltype_list_map_proj_eq.
+ simpl. intros <- Hwf'. eapply P_irrel.
+ - destruct Hwf as (Heq1 & Heq2 & Hwf_cur & Hwf_inner & Hwf_full); subst.
+ specialize (Hopened _ _ _ _ _ _ Cpre Cpost (IH_cur Hwf_cur) (IH_inner Hwf_inner) (IH_full Hwf_full)).
+ eapply P_irrel. eapply Hopened.
+ - specialize (Hcoreable _ κ _ (IH Hwf)).
+ eapply P_irrel. eapply Hcoreable.
+ - destruct Hwf as (Hwf_cur & Hwf_full & <-).
+ specialize (Hshadow _ _ _ r_cur _ (IH_cur Hwf_cur) (IH_full Hwf_full)).
+ eapply P_irrel. eapply Hshadow.
+ Qed.
+ End induction.
+
+ (** Unfolding equations for [ltype] *)
+ Definition ltype_own_type := ∀ rt, ltype rt → bor_kind → thread_id → place_rfn rt → loc → iProp Σ.
+
+ Definition UninitLtype st := OfTy (uninit st).
+
+ Definition box_ltype_own
+ (rec : ltype_own_type)
+ (rec_core : ltype_own_type)
+ {rt} (lt : ltype rt) (k : bor_kind) (π : thread_id) (r : place_rfn (place_rfn rt)) (l : loc) : iProp Σ :=
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ (* the placement of the pointsto below the later let's us get the unfoldings equation without timelessness *)
+ ∃ r' : place_rfn rt, place_rfn_interp_owned r r' ∗ ▷?wl|={lftE}=>
+ ∃ (l' : loc) (ly' : layout), l ↦ l' ∗
+ ⌜syn_type_has_layout (ltype_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ freeable_nz l' ly'.(ly_size) 1 HeapAlloc ∗
+ rec _ lt (Owned true) π r' l'
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ (* TODO can we remove the update here? *)
+ |={lftE}=> &pin{κ}
+ [∃ (r' : place_rfn rt),
+ gvar_auth γ r' ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (l' : loc) (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (ltype_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ (freeable_nz l' ly'.(ly_size) 1 HeapAlloc) ∗
+ rec_core _ lt (Owned true) π r' l'
+ ]
+ (∃ (r' : place_rfn rt),
+ gvar_auth γ r' ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (l' : loc) (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (ltype_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ (freeable_nz l' ly'.(ly_size) 1 HeapAlloc) ∗
+ rec _ lt (Owned true) π r' l')
+ | Shared κ =>
+ (∃ r', place_rfn_interp_shared r r' ∗
+ □ |={lftE}=> ∃ li : loc,
+ &frac{κ}(λ q', l ↦{q'} li) ∗
+ ▷ rec _ lt (Shared κ) π r' li)%I
+ end)%I.
+
+ Definition owned_ptr_ltype_own
+ (rec : ltype_own_type)
+ (rec_core : ltype_own_type)
+ {rt} (lt : ltype rt) (ls : bool) (k : bor_kind) (π : thread_id) (r : place_rfn (place_rfn rt * loc)) (l : loc) : iProp Σ :=
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ (* the placement of the pointsto below the later let's us get the unfoldings equation without timelessness *)
+ ∃ (r' : place_rfn rt) (l' : loc), place_rfn_interp_owned r (r', l') ∗ ▷?wl|={lftE}=>
+ ∃ (ly' : layout), l ↦ l' ∗
+ ⌜syn_type_has_layout (ltype_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ rec _ lt (Owned ls) π r' l'
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ |={lftE}=> &pin{κ}
+ [∃ (r' : place_rfn rt) (l' : loc),
+ gvar_auth γ (r', l') ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (ltype_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ rec_core _ lt (Owned ls) π r' l'
+ ]
+ (∃ (r' : place_rfn rt) (l' : loc),
+ gvar_auth γ (r', l') ∗
+ (* the update here is needed to eliminate ltype_eq, which has an update/except0 in the Owned case *)
+ |={lftE}=>
+ ∃ (ly' : layout),
+ l ↦ l' ∗
+ ⌜syn_type_has_layout (ltype_st lt) ly'⌠∗
+ ⌜l' `has_layout_loc` ly'⌠∗
+ rec _ lt (Owned ls) π r' l')
+ | Shared κ =>
+ (∃ r' li, place_rfn_interp_shared r (r', li) ∗
+ â–¡ |={lftE}=>
+ &frac{κ}(λ q', l ↦{q'} li) ∗
+ ▷ rec _ lt (Shared κ) π r' li)%I
+ end)%I.
+
+ Definition shr_ltype_own
+ (rec : ltype_own_type)
+ (rec_core : ltype_own_type)
+ {rt} (lt : ltype rt) κ k π (r : place_rfn (place_rfn rt)) l :=
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ ∃ (r' : place_rfn rt), place_rfn_interp_owned r r' ∗
+ ▷?wl|={lftE}=> ∃ (l' : loc), l ↦ l' ∗
+ rec _ lt (Shared κ) π r' l'
+ | Uniq κ' γ' =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ' ∗
+ |={lftE}=> &pin{κ'}(∃ (r' : place_rfn rt), gvar_auth γ' r' ∗ |={lftE}=> ∃ (l' : loc), l ↦ l' ∗ rec _ lt (Shared κ) π r' l')
+ | Shared κ' =>
+ ∃ (r' : place_rfn rt),
+ place_rfn_interp_shared r r' ∗
+ (* the update is also over the fractional borrow to deal with timelessness *)
+ □ |={lftE}=> ∃ (l' : loc),
+ &frac{κ'} (λ q, l ↦{q} l') ∗
+ (* no intersection here, as we also don't do that for the type interpretation *)
+ ▷ rec _ lt (Shared κ) π r' l'
+ end)%I.
+
+ Definition mut_ltype_own
+ (rec : ltype_own_type)
+ (rec_core : ltype_own_type)
+ {rt} (lt : ltype rt) (κ : lft) (k : bor_kind) (π : thread_id) (r : place_rfn (place_rfn rt * gname)) (l : loc) : iProp Σ :=
+ (∃ ly : layout, ⌜syn_type_has_layout PtrSynType ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ (* it's fine to existentially quantify here over the gvar_obs, since
+ the outer can actually tell us about it. Keep in mind that the gvar here can actually
+ change if we write under nested places. *)
+ ∃ (γ : gname) (r' : place_rfn rt) ,
+ place_rfn_interp_owned r (r', γ) ∗
+ (* TODO layout requirements on l' here? *)
+ ▷?wl|={lftE}=> ∃ l' : loc , l ↦ l' ∗ (rec _ lt (Uniq κ γ) π r' l')
+ | Uniq κ' γ' =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ' ∗
+ |={lftE}=> &pin{κ'}
+ [∃ (r' : (place_rfn rt) * gname),
+ gvar_auth γ' r' ∗
+ (* update here to be compatible with ofty *)
+ |={lftE}=>
+ ∃ (l' : loc), l ↦ l' ∗
+ rec_core _ lt (Uniq κ r'.2) π r'.1 l'
+ ]
+ (∃ (r' : (place_rfn rt) * gname),
+ gvar_auth γ' r' ∗
+ (* update here to be compatible with ofty *)
+ |={lftE}=>
+ ∃ (l' : loc), l ↦ l' ∗
+ rec _ lt (Uniq κ r'.2) π r'.1 l')
+ | Shared κ' =>
+ (∃ r' γ, place_rfn_interp_shared r (r', γ) ∗
+ (* the update is also over the fractional borrow to deal with timelessness *)
+ □ |={lftE}=> ∃ (li : loc),
+ &frac{κ'}(λ q', l ↦{q'} li) ∗
+ (* later is for contractiveness, the update for timelessness *)
+ ▷ rec _ lt (Shared (κ⊓κ')) π r' li)%I
+ end)%I.
+
+ Definition struct_ltype_own
+ (rec : ltype_own_type)
+ (rec_core : ltype_own_type)
+ {rts : list Type}
+ (lts : hlist ltype rts) (sls : struct_layout_spec)
+ (k : bor_kind) (π : thread_id) (r : place_rfn (plist place_rfn rts)) (l : loc) : iProp Σ :=
+ ∃ sl : struct_layout,
+ ⌜use_struct_layout_alg sls = Some sl⌠∗
+ ⌜length (sls_fields sls) = length rts⌠∗
+ ⌜l `has_layout_loc` sl⌠∗
+ loc_in_bounds l 0 (sl.(ly_size)) ∗
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ ∃ r' : plist place_rfn rts, place_rfn_interp_owned r r' ∗ ▷?wl |={lftE}=>
+ [∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (hpzipl rts lts r') (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn tt))%type,
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ rec _ (projT2 ty).1 (Owned false) π (projT2 ty).2 (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i))
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ (* We change the ownership to Owned false, because we can't push the borrow down in this formulation of products.
+ The cost of this is that we need an update here (to get congruence rules for ltype_eq),
+ which propagates to all the other Uniq cases of other ltypes. *)
+ |={lftE}=> &pin{κ}
+ [∃ (r' : plist place_rfn rts),
+ gvar_auth γ r' ∗ |={lftE}=>
+ [∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (hpzipl rts lts r') (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn tt)),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ rec_core _ (projT2 ty).1 (Owned false) π (projT2 ty).2 (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i))
+ ]
+ (∃ (r' : plist place_rfn rts),
+ gvar_auth γ r' ∗ |={lftE}=>
+ [∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (hpzipl rts lts r') (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn tt)),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ rec _ (projT2 ty).1 (Owned false) π (projT2 ty).2 (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i))
+ )
+ | Shared κ =>
+ (∃ r', place_rfn_interp_shared r r' ∗
+ (* update needed to make the unfolding equation work *)
+ â–¡ |={lftE}=>
+ [∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (hpzipl rts lts r') (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn tt)),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ rec _ (projT2 ty).1 (Shared κ) π (projT2 ty).2 (l +ₗ Z.of_nat (offset_of_idx sl.(sl_members) i)))%I
+ end.
+
+ Definition array_ltype_own
+ (rec : ltype_own_type)
+ (rec_core : ltype_own_type)
+ (rt : Type) (def : type rt) (len : nat) (lts : list (nat * ltype rt))
+ (k : bor_kind) (π : thread_id) (r : place_rfn (list (place_rfn rt))) (l : loc) : iProp Σ :=
+ ∃ ly,
+ ⌜syn_type_has_layout (ty_syn_type def) ly⌠∗
+ ⌜(ly_size ly * len ≤ max_int isize_t)%Z⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly.(ly_size) * len) ∗
+ (*⌜Forall (λ '(i, _), i < len) lts⌠∗*)
+ match k with
+ | Owned wl =>
+ maybe_creds wl ∗
+ ∃ r' : list (place_rfn rt), place_rfn_interp_owned r r' ∗
+ ⌜length r' = len⌠∗
+ â–·?wl |={lftE}=>
+ [∗ list] i ↦ lt; r0 ∈ (interpret_iml (OfTy def) len lts); r',
+ ⌜ltype_st lt = ty_syn_type def⌠∗ rec _ lt (Owned false) π r0 (offset_loc l ly i)
+ | Uniq κ γ =>
+ £ num_cred ∗ atime 1 ∗
+ place_rfn_interp_mut r γ ∗
+ |={lftE}=> &pin{κ}
+ [∃ r' : list (place_rfn rt), gvar_auth γ r' ∗ ⌜length r' = len⌠∗ |={lftE}=>
+ [∗ list] i ↦ lt; r0 ∈ interpret_iml (OfTy def) len lts; r',
+ ⌜ltype_st lt = ty_syn_type def⌠∗ rec_core _ lt (Owned false) π r0 (offset_loc l ly i)]
+ (∃ r' : list (place_rfn rt), gvar_auth γ r' ∗ ⌜length r' = len⌠∗ |={lftE}=>
+ [∗ list] i ↦ lt; r0 ∈ interpret_iml (OfTy def) len lts; r',
+ ⌜ltype_st lt = ty_syn_type def⌠∗ rec _ lt (Owned false) π r0 (offset_loc l ly i))
+ | Shared κ =>
+ ∃ r', place_rfn_interp_shared r r' ∗ ⌜length r' = len⌠∗
+ □ |={lftE}=> [∗ list] i ↦ lt; r0 ∈ interpret_iml (OfTy def) len lts; r',
+ ⌜ltype_st lt = ty_syn_type def⌠∗ rec _ lt (Shared κ) π r0 (offset_loc l ly i)
+ end.
+
+ Definition opened_ltype_own
+ (rec : ltype_own_type) (rec_core : ltype_own_type)
+ {rt_cur rt_inner rt_full : Type}
+ (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ)
+ (k : bor_kind) (π : thread_id) (r : place_rfn rt_cur) (l : loc) : iProp Σ :=
+ ∃ ly, ⌜use_layout_alg (ltype_st lt_cur) = Some ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly_size ly) ∗
+ ⌜ltype_st lt_cur = ltype_st lt_inner⌠∗
+ ⌜ltype_st lt_inner = ltype_st lt_full⌠∗
+
+ match k with
+ | Owned wl =>
+ ltype_own lt_cur (Owned false) π r l ∗
+ (* once we have restored to [lt_inner], we can fold to [lt_full] again *)
+ logical_step lftE
+ (∀ (r : rt_inner) (r' : rt_full) (κs : list lft),
+ (lft_dead_list κs ={lftE}=∗ Cpre r r') -∗
+ (* directly hand out Cpost. We don't need to wait to get tokens from closing borrows etc. *)
+ Cpost r r' ∗
+ (lft_dead_list κs -∗
+ ltype_own lt_inner (Owned false) π (PlaceIn r) l ={lftE}=∗
+ ltype_own_core lt_full (Owned wl) π (PlaceIn r') l))
+ | Uniq κ γ =>
+ ltype_own lt_cur (Owned false) π r l ∗
+ (* we will execute this VS when closing the invariant, after having already stratified [lt_cur].
+ At that point, we will know [lt_cur] is unblockable to [lt_inner] after the set of lifetimes [κs] is dead *)
+ logical_step lftE
+ (∀ (own_lt_cur' : thread_id → rt_inner → loc → iProp Σ) (κs : list lft) (r : rt_inner) (r' : rt_full),
+ (lft_dead_list κs ={lftE}=∗ Cpre r r') -∗
+ ([∗ list] κ' ∈ κs, κ' ⊑ κ) -∗
+ own_lt_cur' π r l -∗
+
+ (* the ownership of [lt_cur'] needs to be shiftable to the _core_ of [lt_inner];
+ this is required for closing the borrow and for proving that it can be unblocked to lt_full
+ (which is needed for showing the shift to Coreable) *)
+ (□ (lft_dead_list κs -∗ own_lt_cur' π r l ={lftE}=∗
+ ltype_own_core lt_inner (Owned false) π (PlaceIn r) l)) ={lftE}=∗
+
+ Cpost r r' ∗
+ gvar_obs γ r' ∗
+ (lft_dead_list κs -∗ gvar_obs γ r' ={lftE}=∗
+ ltype_own_core lt_full (Uniq κ γ) π (PlaceIn r') l))
+ | Shared κ =>
+ False
+ (*ltype_own lt_cur (Shared κ) π r l*)
+ end.
+
+ Definition coreable_ltype_own (rec : ltype_own_type) (rec_core : ltype_own_type)
+ {rt_full} (κs : list lft) (lt_full : ltype rt_full)
+ (k : bor_kind) (π : thread_id) (r : place_rfn rt_full) (l : loc) : iProp Σ :=
+ ∃ ly, ⌜syn_type_has_layout (ltype_st lt_full) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly_size ly) ∗
+ match k with
+ | Owned wl =>
+ lft_dead_list κs ={lftE}=∗ rec_core _ lt_full (Owned wl) π r l
+ | Uniq κ' γ =>
+ place_rfn_interp_mut r γ ∗
+ (lft_dead_list κs -∗ place_rfn_interp_mut r γ ={lftE}=∗ rec_core _ lt_full (Uniq κ' γ) π r l)
+ | Shared κ =>
+ rec_core _ lt_full (Shared κ) π r l
+ end.
+
+ Definition shadowed_ltype_own (rec : ltype_own_type) (rec_core : ltype_own_type)
+ {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full)
+ (k : bor_kind) (π : thread_id) (r : place_rfn rt_full) (l : loc) : iProp Σ :=
+ ⌜ltype_st lt_cur = ltype_st lt_full⌠∗
+ rec _ lt_cur k π (r_cur) l ∗
+ rec _ lt_full k π r l.
+
+ Lemma ltype_own_pre_ofty_unfold {rt} (ty : type rt) (core : bool) k π r l :
+ ltype_own_pre core (OfTy ty) k π r l ≡ lty_of_ty_own ty k π r l.
+ Proof.
+ rewrite /ltype_own_pre. simp lty_own_pre. rewrite /lty_of_ty_own.
+ move: r.
+ generalize (ltype_rt_agree (OfTy ty)). simpl.
+ intros Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. done.
+ Qed.
+ Lemma ltype_own_ofty_unfold {rt} (ty : type rt) k π r l :
+ ltype_own (OfTy ty) k π r l ≡ lty_of_ty_own ty k π r l.
+ Proof. rewrite ltype_own_unseal. apply ltype_own_pre_ofty_unfold. Qed.
+ Lemma ltype_own_core_ofty_unfold {rt} (ty : type rt) k π r l :
+ ltype_own_core (OfTy ty) k π r l ≡ lty_of_ty_own ty k π r l.
+ Proof. rewrite ltype_own_core_unseal. apply ltype_own_pre_ofty_unfold. Qed.
+
+ Lemma ltype_own_pre_alias_unfold (rt : Type) (st : syn_type) (p : loc) (core : bool) k π r l :
+ ltype_own_pre core (AliasLtype rt st p) k π r l ≡ alias_lty_own rt st p k π r l.
+ Proof.
+ rewrite /ltype_own_pre. simp lty_own_pre. rewrite /alias_lty_own.
+ destruct k; [ | done..].
+ done.
+ Qed.
+ Lemma ltype_own_alias_unfold (rt : Type) (st : syn_type) (p : loc) k π r l :
+ ltype_own (AliasLtype rt st p) k π r l ≡ alias_lty_own rt st p k π r l.
+ Proof. rewrite ltype_own_unseal. apply ltype_own_pre_alias_unfold. Qed.
+ Lemma ltype_own_core_alias_unfold (rt : Type) (st : syn_type) (p : loc) k π r l :
+ ltype_own_core (AliasLtype rt st p) k π r l ≡ alias_lty_own rt st p k π r l.
+ Proof. rewrite ltype_own_core_unseal. apply ltype_own_pre_alias_unfold. Qed.
+
+ Lemma ltype_own_blocked_unfold {rt} (ty : type rt) κ k π r l :
+ ltype_own (BlockedLtype ty κ) k π r l ≡ blocked_lty_own ty κ k π r l.
+ Proof.
+ rewrite ltype_own_unseal /ltype_own_def /ltype_own_pre. simp lty_own_pre.
+ rewrite /blocked_lty_own.
+ move: r.
+ generalize (ltype_rt_agree (BlockedLtype ty κ)). simpl.
+ intros Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. done.
+ Qed.
+ Lemma ltype_own_core_blocked_unfold {rt} (ty : type rt) κ k π r l :
+ ltype_own_core (BlockedLtype ty κ) k π r l ≡ lty_of_ty_own ty k π r l.
+ Proof.
+ rewrite ltype_own_core_unseal /ltype_own_core_def /ltype_own_pre. simp lty_own_pre.
+ rewrite /lty_of_ty_own.
+ move: r.
+ generalize (ltype_rt_agree (BlockedLtype ty κ)). simpl.
+ intros Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. done.
+ Qed.
+
+ Lemma ltype_own_shrblocked_unfold {rt} (ty : type rt) κ k π r l :
+ ltype_own (ShrBlockedLtype ty κ) k π r l ≡ shr_blocked_lty_own ty κ k π r l.
+ Proof.
+ rewrite ltype_own_unseal /ltype_own_def /ltype_own_pre. simp lty_own_pre.
+ rewrite /shr_blocked_lty_own.
+ move: r.
+ generalize (ltype_rt_agree (ShrBlockedLtype ty κ)). simpl.
+ intros Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. done.
+ Qed.
+ Lemma ltype_own_core_shrblocked_unfold {rt} (ty : type rt) κ k π r l :
+ ltype_own_core (ShrBlockedLtype ty κ) k π r l ≡ lty_of_ty_own ty k π r l.
+ Proof.
+ rewrite ltype_own_core_unseal /ltype_own_core_def /ltype_own_pre. simp lty_own_pre.
+ rewrite /shr_blocked_lty_own.
+ move: r.
+ generalize (ltype_rt_agree (ShrBlockedLtype ty κ)). simpl.
+ intros Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. done.
+ Qed.
+
+ Lemma ltype_own_pre_box_unfold {rt} (lt : ltype rt) (core : bool) k π r l :
+ ltype_own_pre core (BoxLtype lt) k π r l ≡ box_ltype_own (@ltype_own_pre core) (@ltype_own_core) lt k π r l.
+ Proof.
+ (* NOTE: pay attention to unfold also the core, otherwise we get into trouble with generalizing below *)
+ rewrite /box_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ move: r.
+ generalize (ltype_rt_agree (BoxLtype lt)).
+ generalize (ltype_rt_agree lt). simpl.
+ intros <- Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. repeat f_equiv; done.
+ Qed.
+ Lemma ltype_own_box_unfold {rt} (lt : ltype rt) k π r l :
+ ltype_own (BoxLtype lt) k π r l ≡ box_ltype_own (@ltype_own) (@ltype_own_core) lt k π r l.
+ Proof. rewrite ?ltype_own_unseal. apply ltype_own_pre_box_unfold. Qed.
+ Lemma ltype_own_core_box_unfold {rt} (lt : ltype rt) k π r l :
+ ltype_own_core (BoxLtype lt) k π r l ≡ box_ltype_own (@ltype_own_core) (@ltype_own_core) lt k π r l.
+ Proof. rewrite {1 2}ltype_own_core_unseal. apply ltype_own_pre_box_unfold. Qed.
+
+ Lemma ltype_own_pre_owned_ptr_unfold {rt} (lt : ltype rt) (ls : bool) (core : bool) k π r l :
+ ltype_own_pre core (OwnedPtrLtype lt ls) k π r l ≡ owned_ptr_ltype_own (@ltype_own_pre core) (@ltype_own_core) lt ls k π r l.
+ Proof.
+ (* NOTE: pay attention to unfold also the core, otherwise we get into trouble with generalizing below *)
+ rewrite /owned_ptr_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ move: r.
+ generalize (ltype_rt_agree (OwnedPtrLtype lt ls)).
+ generalize (ltype_rt_agree lt). simpl.
+ intros <- Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. repeat f_equiv; done.
+ Qed.
+ Lemma ltype_own_owned_ptr_unfold {rt} (lt : ltype rt) (ls : bool) k π r l :
+ ltype_own (OwnedPtrLtype lt ls) k π r l ≡ owned_ptr_ltype_own (@ltype_own) (@ltype_own_core) lt ls k π r l.
+ Proof. rewrite ?ltype_own_unseal. apply ltype_own_pre_owned_ptr_unfold. Qed.
+ Lemma ltype_own_core_owned_ptr_unfold {rt} (lt : ltype rt) (ls : bool) k π r l :
+ ltype_own_core (OwnedPtrLtype lt ls) k π r l ≡ owned_ptr_ltype_own (@ltype_own_core) (@ltype_own_core) lt ls k π r l.
+ Proof. rewrite {1 2}ltype_own_core_unseal. apply ltype_own_pre_owned_ptr_unfold. Qed.
+
+ Lemma ltype_own_pre_shr_ref_unfold {rt} (lt : ltype rt) (core : bool) κ k π r l :
+ ltype_own_pre core (ShrLtype lt κ) k π r l ≡ shr_ltype_own (@ltype_own_pre core) (@ltype_own_core) lt κ k π r l.
+ Proof.
+ (* NOTE: pay attention to unfold also the core, otherwise we get into trouble with generalizing below *)
+ rewrite /shr_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ move: r.
+ generalize (ltype_rt_agree (ShrLtype lt κ)).
+ generalize (ltype_rt_agree lt). simpl.
+ intros <- Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. repeat f_equiv; done.
+ Qed.
+ Lemma ltype_own_shr_ref_unfold {rt} (lt : ltype rt) κ k π r l :
+ ltype_own (ShrLtype lt κ) k π r l ≡ shr_ltype_own (@ltype_own) (@ltype_own_core) lt κ k π r l.
+ Proof. rewrite ?ltype_own_unseal. apply ltype_own_pre_shr_ref_unfold. Qed.
+ Lemma ltype_own_core_shr_ref_unfold {rt} (lt : ltype rt) κ k π r l :
+ ltype_own_core (ShrLtype lt κ) k π r l ≡ shr_ltype_own (@ltype_own_core) (@ltype_own_core) lt κ k π r l.
+ Proof. rewrite {1 2}ltype_own_core_unseal. apply ltype_own_pre_shr_ref_unfold. Qed.
+
+ Lemma ltype_own_pre_mut_ref_unfold {rt} (lt : ltype rt) (core : bool) κ k π r l :
+ ltype_own_pre core (MutLtype lt κ) k π r l ≡ mut_ltype_own (@ltype_own_pre core) (@ltype_own_core) lt κ k π r l.
+ Proof.
+ (* NOTE: pay attention to unfold also the core, otherwise we get into trouble with generalizing below *)
+ rewrite /mut_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ move: r.
+ generalize (ltype_rt_agree (MutLtype lt κ)).
+ generalize (ltype_rt_agree lt). simpl.
+ intros <- Heq. rewrite (UIP_refl _ _ Heq).
+ intros r. repeat f_equiv; done.
+ Qed.
+ Lemma ltype_own_mut_ref_unfold {rt} (lt : ltype rt) κ k π r l :
+ ltype_own (MutLtype lt κ) k π r l ≡ mut_ltype_own (@ltype_own) (@ltype_own_core) lt κ k π r l.
+ Proof. rewrite ?ltype_own_unseal. apply ltype_own_pre_mut_ref_unfold. Qed.
+ Lemma ltype_own_core_mut_ref_unfold {rt} (lt : ltype rt) κ k π r l :
+ ltype_own_core (MutLtype lt κ) k π r l ≡ mut_ltype_own (@ltype_own_core) (@ltype_own_core) lt κ k π r l.
+ Proof. rewrite {1 2}ltype_own_core_unseal. apply ltype_own_pre_mut_ref_unfold. Qed.
+
+ Lemma StructLtype_StructLty_rfn_eq (rts : list Type) (lts : hlist ltype rts) :
+ plist place_rfn rts = plist (λ lt : lty, place_rfn (lty_rt lt)) (@ltype_lty +c<$> lts).
+ Proof.
+ induction rts as [ | ?? IH]; inv_hlist lts; simpl; first done.
+ intros x xl'. f_equiv.
+ - rewrite (ltype_rt_agree x); done.
+ - apply IH.
+ Qed.
+ Section structlty.
+ (** The unfolding for StructLtype requires a bit of work. We first bring the big_sepL into a shape where we can use [big_sepL_fmap]. *)
+
+ Local Definition lty_own_pre_sig (core : bool) (lt : sigT (λ lt : lty, place_rfn (lty_rt lt))) (k : bor_kind) (π : thread_id) (l : loc) : iProp Σ :=
+ lty_own_pre core (projT1 lt) k π (projT2 lt) l.
+
+ Local Definition map_fun : sigT (λ rt : Type, (ltype rt * place_rfn rt)%type) → sigT (λ lt : lty, place_rfn (lty_rt lt)) :=
+ (λ x, existT (ltype_lty (projT2 x).1) (rew <- [place_rfn] ltype_rt_agree (projT2 x).1 in (projT2 x).2)).
+
+
+ Local Lemma StructLtype_fmap_eq {rts : list Type} (lts : hlist ltype rts) (r : plist place_rfn rts) (Heq: plist (λ lt : lty, place_rfn (lty_rt lt)) (@ltype_lty +c<$> lts) = plist place_rfn rts):
+ (pzipl (hcmap (@ltype_lty) lts) (rew <-[id] Heq in r)) = fmap map_fun (hpzipl rts lts r).
+ Proof.
+ induction rts as [ | rt rts IH] in lts, r, Heq |-*.
+ { inv_hlist lts. done. }
+ inv_hlist lts. intros lt lts Heq2.
+ simpl.
+ f_equiv.
+ - simpl. unfold map_fun. f_equiv.
+ simpl. generalize (ltype_rt_agree lt) as Heq3.
+ clear.
+ intros.
+ rewrite phd_rew_commute.
+ { rewrite Heq3 //. }
+ 2: { apply StructLtype_StructLty_rfn_eq. }
+ intros Heq4.
+ clear. move: Heq4 Heq3.
+ generalize (ltype_lty lt) as lt' => lt'.
+ intros ? <-. rewrite (UIP_refl _ _ Heq4) //.
+ - specialize (IH lts (ptl r)). unfold fmap in IH. rewrite -IH.
+ { rewrite -StructLtype_StructLty_rfn_eq. done. }
+ intros Heq3.
+ f_equiv.
+ destruct r as [r tl]. simpl.
+ rewrite ptl_rew_commute.
+ { rewrite -StructLtype_StructLty_rfn_eq. done. }
+ 2: { rewrite ltype_rt_agree. done. }
+ intros Heq4.
+ simpl. clear. move: tl Heq4 Heq3.
+ generalize (@ltype_lty +c<$> lts) as l => l.
+ intros tl. destruct Heq4.
+ intros Heq3. rewrite (UIP_refl _ _ Heq3). done.
+ Qed.
+
+ Local Lemma StructLtype_big_sepL_fmap' {rts : list Type} (sl : struct_layout) (lts : hlist ltype rts) (r : plist place_rfn rts) r'
+ (Heq2: plist (λ lt : lty, place_rfn (lty_rt lt)) (@ltype_lty +c<$> lts) = plist place_rfn rts)
+ (l : loc) (Ï€ : thread_id) k core :
+ r' = rew <-[id] Heq2 in r →
+ ([∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (pzipl (hcmap (@ltype_lty) lts) r')
+ (λ ly : layout, existT (UninitLty (UntypedSynType ly)) (PlaceIn ())),
+ (∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (lty_st (projT1 ty)) ly⌠∗
+ lty_own_pre core (projT1 ty) k π (projT2 ty) (l +ₗ offset_of_idx sl.(sl_members) i))) ⊣⊢
+
+ ([∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (hpzipl rts lts r)
+ (λ ly : layout, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn tt)),
+ ∃ ly, ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ lty_own_pre core (ltype_lty (projT2 ty).1) k π (rew <-[place_rfn] ltype_rt_agree (projT2 ty).1 in (projT2 ty).2) (l +ₗ offset_of_idx sl.(sl_members) i)).
+ Proof.
+ intros ->.
+ rewrite StructLtype_fmap_eq.
+ rewrite (pad_struct_ext _ _ _ (λ ly : layout, map_fun (existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())))).
+ 2: { intros. unfold map_fun. simpl. f_equiv.
+ generalize (ltype_rt_agree (UninitLtype (UntypedSynType ly))).
+ simpl. intros Heq3. rewrite (UIP_refl _ _ Heq3). done. }
+ rewrite (pad_struct_fmap _ _ _ (λ _, _)).
+ simpl. fold map_fun.
+ rewrite big_sepL_fmap. done.
+ Qed.
+ End structlty.
+
+ Lemma ltype_own_pre_struct_unfold {rts : list Type} (lts : hlist ltype rts) (sls : struct_layout_spec) (core : bool) k π r l :
+ ltype_own_pre core (StructLtype lts sls) k π r l ≡ struct_ltype_own (@ltype_own_pre core) (@ltype_own_core) lts sls k π r l.
+ Proof.
+ rewrite /struct_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre. fold (lty_rt).
+ generalize (ltype_rt_agree (StructLtype lts sls)) as Heq => Heq.
+ assert (Heq2 : plist (λ lt, place_rfn (lty_rt lt)) (hcmap (@ltype_lty) lts) = plist place_rfn rts).
+ { rewrite -Heq. done. }
+ repeat f_equiv.
+ { rewrite hcmap_length. done. }
+ (*{ rewrite fmap_hcmap. done. }*)
+ (* TODO deduplicate all this stuff *)
+ { setoid_rewrite big_sepL_P_eq.
+ iSplit.
+ - iIntros "(%r' & Hrfn & Hb)".
+ iExists (rew [id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2.
+ intros r'. rewrite (UIP_refl _ _ Heq). done. }
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | |]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done.
+ - iIntros "(%r' & Hrfn & Hb)".
+ iExists (rew <-[id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2.
+ intros r'. rewrite (UIP_refl _ _ Heq). done. }
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | | ]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done.
+ }
+ { setoid_rewrite big_sepL_P_eq.
+ iSplit.
+ - iIntros "(%r' & Hrfn & #Hb)".
+ iExists (rew [id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2.
+ intros r'. rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hb" as "Hb". iModIntro.
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | |]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done.
+ - iIntros "(%r' & Hrfn & #Hb)".
+ iExists (rew <-[id]Heq2 in r').
+ iSplitL "Hrfn".
+ { iClear "Hb". move: r'. destruct Heq2.
+ intros r'. rewrite (UIP_refl _ _ Heq). done. }
+ iModIntro. iMod "Hb" as "Hb". iModIntro.
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | | ]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done.
+ }
+ { move: r. destruct Heq. done. }
+ { setoid_rewrite big_sepL_P_eq.
+ iSplit.
+ - iIntros "(%r' & Hrfn & Hb)".
+ iExists (rew [id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2. done. }
+ iMod "Hb" as "Hb". iModIntro.
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | |]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done.
+ - iIntros "(%r' & Hrfn & Hb)".
+ iExists (rew <-[id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2. done. }
+ iMod "Hb" as "Hb". iModIntro.
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | | ]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done. }
+ { setoid_rewrite big_sepL_P_eq.
+ iSplit.
+ - iIntros "(%r' & Hrfn & Hb)".
+ iExists (rew [id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2. done. }
+ iMod "Hb" as "Hb". iModIntro.
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | |]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done.
+ - iIntros "(%r' & Hrfn & Hb)".
+ iExists (rew <-[id]Heq2 in r').
+ iSplitL "Hrfn".
+ { move: r'. destruct Heq2. done. }
+ iMod "Hb" as "Hb". iModIntro.
+ unshelve rewrite StructLtype_big_sepL_fmap'; [ | done | | ]. 2: {
+ iApply (big_sepL_mono with "Hb").
+ clear. iIntros (? (rt & lt & r'') ?). simpl. done. }
+ clear. destruct Heq2. done. }
+ Qed.
+
+ Lemma ltype_own_struct_unfold {rts : list Type} (lts : hlist ltype rts) (sls : struct_layout_spec) k π r l :
+ ltype_own (StructLtype lts sls) k π r l ≡ struct_ltype_own (@ltype_own) (@ltype_own_core) lts sls k π r l.
+ Proof. rewrite ?ltype_own_unseal. apply ltype_own_pre_struct_unfold. Qed.
+ Lemma ltype_own_core_struct_unfold {rts : list Type} (lts : hlist ltype rts) (sls : struct_layout_spec) k π r l :
+ ltype_own_core (StructLtype lts sls) k π r l ≡ struct_ltype_own (@ltype_own_core) (@ltype_own_core) lts sls k π r l.
+ Proof. rewrite {1 2} ltype_own_core_unseal. apply ltype_own_pre_struct_unfold. Qed.
+
+ Local Lemma ArrayLtype_big_sepL_fmap {rt} (lts : list (ltype rt)) (r : list (place_rfn rt)) core π k ly st l :
+ length lts = length r →
+ ([∗ list] i↦ ty ∈ zip (map ltype_lty lts) r,
+ ∃ Heq : lty_rt ty.1 = rt, ⌜lty_st ty.1 = st⌠∗
+ lty_own_pre core ty.1 k π (rew <- [place_rfn] Heq in ty.2) (l offset{ly}ₗ i)) ⊣⊢
+ ([∗ list] i↦ lt;r' ∈ lts;r, ⌜ltype_st lt = st⌠∗
+ lty_own_pre core (ltype_lty lt) k π (rew <- [place_rfn] ltype_rt_agree lt in r') (l offset{ly}ₗ i)).
+ Proof.
+ intros Hlen.
+ assert (⌜length lts = length lts⌠⊣⊢ (True : iProp Σ))%I as Heq.
+ { iSplit; eauto. }
+ rewrite big_sepL2_alt.
+ rewrite -Hlen. rewrite Heq. rewrite left_id.
+ rewrite zip_fmap_l big_sepL_fmap.
+ f_equiv. intros ? [lt r']. simpl.
+ iSplit.
+ { iIntros "(%Heq2 & $ & Hb)". generalize (ltype_rt_agree lt) => Heq3.
+ rewrite (UIP_t _ _ _ Heq2 Heq3). done.
+ }
+ { iIntros "($ & Hb)". iExists _. iFrame. }
+ Qed.
+ Local Lemma OfTy_ltype_lty {rt} (ty : type rt) :
+ ltype_lty (OfTy ty) = OfTyLty ty.
+ Proof. done. Qed.
+ Lemma ltype_own_pre_array_unfold {rt : Type} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) (core : bool) k π r l :
+ ltype_own_pre core (ArrayLtype def len lts) k π r l ≡ array_ltype_own (@ltype_own_pre core) (@ltype_own_core) rt def len lts k π r l.
+ Proof.
+ rewrite /array_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ generalize (ltype_rt_agree (ArrayLtype def len lts)).
+ fold lty_rt. simpl.
+ intros Heq1. rewrite (UIP_refl _ _ Heq1). cbn.
+ do 6 f_equiv.
+ (*f_equiv.*)
+ (*{ rewrite Forall_fmap. iPureIntro. apply Forall_iff. intros []; done. }*)
+ f_equiv.
+ - do 4 f_equiv.
+ apply sep_equiv_proper => Hlen.
+ repeat f_equiv. rewrite big_sepL_P_eq.
+ rewrite -OfTy_ltype_lty.
+ rewrite interpret_iml_fmap ArrayLtype_big_sepL_fmap //.
+ rewrite interpret_iml_length //.
+ - do 3 f_equiv. apply sep_equiv_proper => Hlen.
+ repeat f_equiv. rewrite big_sepL_P_eq.
+ rewrite -OfTy_ltype_lty interpret_iml_fmap ArrayLtype_big_sepL_fmap //.
+ rewrite interpret_iml_length//.
+ - do 8 f_equiv.
+ all: apply sep_equiv_proper => Hlen.
+ all: repeat f_equiv; rewrite big_sepL_P_eq.
+ all: rewrite -OfTy_ltype_lty interpret_iml_fmap ArrayLtype_big_sepL_fmap//.
+ all: rewrite interpret_iml_length//.
+ Qed.
+
+ Lemma ltype_own_array_unfold {rt : Type} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) k π r l :
+ ltype_own (ArrayLtype def len lts) k π r l ≡ array_ltype_own (@ltype_own) (@ltype_own_core) rt def len lts k π r l.
+ Proof. rewrite ?ltype_own_unseal. apply ltype_own_pre_array_unfold. Qed.
+ Lemma ltype_own_core_array_unfold {rt : Type} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) k π r l :
+ ltype_own_core (ArrayLtype def len lts) k π r l ≡ array_ltype_own (@ltype_own_core) (@ltype_own_core) rt def len lts k π r l.
+ Proof. rewrite {1 2} ltype_own_core_unseal. apply ltype_own_pre_array_unfold. Qed.
+
+ Lemma ltype_own_opened_unfold {rt_cur rt_inner rt_full : Type} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ) k π r l :
+ ltype_own (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) k π r l ≡ opened_ltype_own (@ltype_own) (@ltype_own_core) lt_cur lt_inner lt_full Cpre Cpost k π r l.
+ Proof.
+ rewrite /opened_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ generalize (ltype_rt_agree lt_cur).
+ generalize (ltype_rt_agree lt_full).
+ generalize (ltype_rt_agree lt_inner).
+ generalize (ltype_rt_agree (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost)).
+ simpl.
+ intros Heq1 Heq2 Heq3 Heq4. move : Cpre Cpost r.
+ move: Heq1 Heq2 Heq3 Heq4.
+ intros <- <- <-.
+ intros Heq Cpre Cpost r. specialize (UIP_refl _ _ Heq) => ->. clear Heq.
+ repeat f_equiv.
+ - done.
+ - done.
+ - iSplit.
+ + iIntros "(%Heq1 & %Heq2 & Ha)".
+ rewrite (UIP_refl _ _ Heq1) (UIP_refl _ _ Heq2). done.
+ + iIntros "Ha". iExists eq_refl, eq_refl. done.
+ - iSplit.
+ + iIntros "(%Heq1 & %Heq2 & Ha)".
+ rewrite (UIP_refl _ _ Heq1) (UIP_refl _ _ Heq2). done.
+ + iIntros "Ha". iExists eq_refl, eq_refl. done.
+ Qed.
+ Lemma ltype_own_core_opened_unfold {rt_cur rt_inner rt_full : Type} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre : rt_inner → rt_full → iProp Σ) (Cpost : rt_inner → rt_full → iProp Σ) k π r l :
+ ltype_own_core (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) k π r l ≡ opened_ltype_own (@ltype_own) (@ltype_own_core) lt_cur lt_inner lt_full Cpre Cpost k π r l.
+ Proof.
+ rewrite -ltype_own_opened_unfold.
+ rewrite ltype_own_core_unseal ltype_own_unseal /ltype_own_core_def /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre. done.
+ Qed.
+
+ Lemma ltype_own_coreable_unfold {rt_full} (κs : list lft) (lt_full : ltype rt_full) k π r l :
+ ltype_own (CoreableLtype κs lt_full) k π r l ≡ coreable_ltype_own (@ltype_own) (@ltype_own_core) κs lt_full k π r l.
+ Proof.
+ rewrite /coreable_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ generalize (ltype_rt_agree lt_full).
+ generalize (ltype_rt_agree (CoreableLtype κs lt_full)).
+ simpl. intros Heq1 Heq2. move: Heq1 Heq2 r.
+ intros <- Heq r. rewrite (UIP_refl _ _ Heq). clear Heq.
+ done.
+ Qed.
+ Lemma ltype_own_core_coreable_unfold {rt_full} (κs : list lft) (lt_full : ltype rt_full) k π r l :
+ ltype_own_core (CoreableLtype κs lt_full) k π r l ≡ ltype_own_core lt_full k π r l.
+ Proof.
+ rewrite /coreable_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ generalize (ltype_rt_agree lt_full).
+ generalize (ltype_rt_agree (CoreableLtype κs lt_full)).
+ simpl. intros Heq1 Heq2. move : Heq1 Heq2 r. intros <- Heq r.
+ rewrite (UIP_refl _ _ Heq). done.
+ Qed.
+
+ Lemma ltype_own_shadowed_unfold {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full) k π r l :
+ ltype_own (ShadowedLtype lt_cur r_cur lt_full) k π r l ≡ shadowed_ltype_own (@ltype_own) (@ltype_own_core) lt_cur r_cur lt_full k π r l.
+ Proof.
+ rewrite /shadowed_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ generalize (ltype_rt_agree lt_cur).
+ generalize (ltype_rt_agree lt_full).
+ generalize (ltype_rt_agree (ShadowedLtype lt_cur r_cur lt_full)).
+ simpl. intros Heq1 Heq2 Heq3. move: Heq1 Heq2 Heq3 r r_cur. intros <- Heq <-.
+ rewrite (UIP_refl _ _ Heq). cbn. intros ??.
+ iSplit.
+ - iIntros "(%Heq' & ?)". rewrite (UIP_refl _ _ Heq'). iFrame.
+ - iIntros "?". iExists eq_refl. done.
+ Qed.
+ Lemma ltype_own_core_shadowed_unfold {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full) k π r l :
+ ltype_own_core (ShadowedLtype lt_cur r_cur lt_full) k π r l ≡ ltype_own_core lt_full k π r l.
+ Proof.
+ rewrite /shadowed_ltype_own ?ltype_own_core_unseal /ltype_own_core_def ?ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ simp lty_own_pre.
+ generalize (ltype_rt_agree lt_full).
+ generalize (ltype_rt_agree (ShadowedLtype lt_cur r_cur lt_full)).
+ intros Heq1 Heq2. move: Heq1 Heq2 r. intros <- Heq. rewrite (UIP_refl _ _ Heq).
+ intros ?. done.
+ Qed.
+
+ (** Lifting basic lemmas to [ltype] *)
+
+ (* NOTE: This does not hold true for [OpenedLtype]! *)
+ Lemma ltype_own_pre_shr_pers core {rt} (lt : ltype rt) κ π r l :
+ (*match lt.(ltype_lty) with OpenedLty _ _ _ _ _ => False | _ => True end →*)
+ Persistent (ltype_own_pre core lt (Shared κ) π r l).
+ Proof. rewrite /ltype_own_pre. apply lty_own_pre_shr_pers. Qed.
+ Global Instance ltype_own_shr_pers {rt} (lt : ltype rt) κ π r l :
+ (*TCDone (match lt.(ltype_lty) with OpenedLty _ _ _ _ _ => False | _ => True end) →*)
+ Persistent (ltype_own lt (Shared κ) π r l).
+ Proof. rewrite ltype_own_unseal. apply ltype_own_pre_shr_pers. Qed.
+ Global Instance ltype_own_core_shr_pers {rt} (lt : ltype rt) κ π r l :
+ (*TCDone (match lt.(ltype_lty) with OpenedLty _ _ _ _ _ => False | _ => True end) →*)
+ Persistent (ltype_own_core lt (Shared κ) π r l).
+ Proof. rewrite ltype_own_core_unseal. apply ltype_own_pre_shr_pers. Qed.
+
+ Lemma ltype_core_idemp {rt} (lt : ltype rt) :
+ ltype_core (ltype_core lt) = ltype_core lt.
+ Proof.
+ destruct lt as [lt Heq Hwf].
+ rewrite /ltype_core /=.
+ specialize (lty_core_idemp lt) as Heq2.
+ match goal with
+ | |- context[ltype_core_obligation_1 ?H1 ?H2] => generalize (ltype_core_obligation_1 H1 H2) as Heq3
+ end.
+ simpl. intros Heq3.
+ match goal with
+ | |- context[ltype_core_obligation_1 ?H1 ?H2] => generalize (ltype_core_obligation_1 H1 H2) as Heq4
+ end. intros Heq4.
+ match goal with
+ | |- context[ltype_core_obligation_2 ?H1 ?H2] => generalize (ltype_core_obligation_2 H1 H2) as Hwf1
+ end; simpl.
+ intros Hwf1.
+ match goal with
+ | |- context[ltype_core_obligation_2 ?H1 ?H2] => generalize (ltype_core_obligation_2 H1 H2) as Hwf2
+ end; simpl.
+ intros Hwf2.
+ move: Hwf Heq2 Heq3 Heq4 Hwf1 Hwf2.
+ subst. simpl.
+ generalize (lty_core lt) as l => lt'.
+ intros _ -> Heq3 Heq4 Hwf1 Hwf2.
+ rewrite (UIP_t _ _ _ Heq3 Heq4).
+ (* TODO uses proof irrelevance, can we avoid that? *)
+ rewrite (proof_irrelevance _ Hwf1 Hwf2). done.
+ Qed.
+
+ Lemma ltype_own_has_layout {rt} (lt : ltype rt) k π r l :
+ ltype_own lt k Ï€ r l -∗ ∃ ly : layout, ⌜syn_type_has_layout (ltype_st lt) ly⌠∗ ⌜l `has_layout_loc` lyâŒ.
+ Proof.
+ rewrite ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ iIntros "Hown". iPoseProof lty_own_has_layout as "Ha".
+ by iApply "Ha".
+ Qed.
+
+ Lemma ltype_own_loc_in_bounds {rt} (lt : ltype rt) k π r l ly :
+ syn_type_has_layout (ltype_st lt) ly →
+ ltype_own lt k π r l -∗ loc_in_bounds l 0 ly.(ly_size).
+ Proof.
+ iIntros (?) "Hown".
+ rewrite ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ iPoseProof lty_own_loc_in_bounds as "Ha"; first done.
+ by iApply "Ha".
+ Qed.
+
+ Lemma ltype_core_syn_type_eq {rt} (lt : ltype rt) :
+ ltype_st (ltype_core lt) = ltype_st lt.
+ Proof.
+ rewrite /ltype_st /ltype_core /= lty_core_syn_type_eq //.
+ Qed.
+
+ Lemma ltype_own_shared_to_core {rt} (lt : ltype rt) κ0 π r l :
+ ltype_own lt (Shared κ0) π r l -∗ ltype_own (ltype_core lt) (Shared κ0) π (r) l.
+ Proof.
+ iIntros "Ha".
+ rewrite ltype_own_unseal /ltype_own_def /ltype_own_pre.
+ assert (Heq2 : lty_rt (ltype_lty lt) = lty_rt (lty_core (ltype_lty lt))).
+ { (rewrite lty_core_rt_eq//). }
+ unshelve iPoseProof (lty_own_shared_to_core _ _ _ _ _ with "Ha") as "Ha"; first done.
+ revert r Heq2.
+ generalize (lty_core_rt_eq (ltype_lty lt)).
+ generalize (ltype_rt_agree (ltype_core lt)).
+ generalize (ltype_rt_agree lt).
+ destruct lt; simpl.
+ intros Heq0. subst.
+ intros Heq _. destruct Heq. intros ? Heq2.
+ rewrite (UIP_refl _ _ Heq2).
+ rewrite (UIP_refl _ _ Heq0).
+ done.
+ Qed.
+
+ (** Rules for ltype_core *)
+ (** Since [ltype]s bundle equality proofs, [ltype_core] does not compute well, and we need equational lemmas instead. *)
+ Lemma ltype_core_ofty {rt} (ty : type rt) :
+ ltype_core (OfTy ty) = OfTy ty.
+ Proof.
+ rewrite /ltype_core /OfTy. simpl.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_alias (rt : Type) (st : syn_type) (p : loc) :
+ ltype_core (AliasLtype rt st p) = AliasLtype rt st p.
+ Proof.
+ rewrite /ltype_core /AliasLtype. simpl.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_blocked {rt} (ty : type rt) (κ : lft) :
+ ltype_core (BlockedLtype ty κ) = OfTy ty.
+ Proof.
+ rewrite /ltype_core /BlockedLtype /OfTy. simpl.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_shrblocked {rt} (ty : type rt) (κ : lft) :
+ ltype_core (ShrBlockedLtype ty κ) = OfTy ty.
+ Proof.
+ rewrite /ltype_core /ShrBlockedLtype /OfTy. simpl.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_box {rt} (lt : ltype rt) :
+ ltype_core (BoxLtype lt) = BoxLtype (ltype_core lt).
+ Proof.
+ rewrite /ltype_core /BoxLtype /=. f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_owned_ptr {rt} (lt : ltype rt) (ls : bool) :
+ ltype_core (OwnedPtrLtype lt ls) = OwnedPtrLtype (ltype_core lt) ls.
+ Proof.
+ rewrite /ltype_core /OwnedPtrLtype /=. f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_mut_ref {rt} (lt : ltype rt) (κ : lft) :
+ ltype_core (MutLtype lt κ) = MutLtype (ltype_core lt) κ.
+ Proof.
+ rewrite /ltype_core /MutLtype /=. f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_shr_ref {rt} (lt : ltype rt) (κ : lft) :
+ ltype_core (ShrLtype lt κ) = ShrLtype (ltype_core lt) κ.
+ Proof.
+ rewrite /ltype_core /ShrLtype /=. f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_struct {rts} (lts : hlist ltype rts) (sls : struct_layout_spec) :
+ ltype_core (StructLtype lts sls) = StructLtype (hmap (@ltype_core) lts) sls.
+ Proof.
+ rewrite /ltype_core /StructLtype /=.
+ match goal with
+ | |- mk_ltype _ ?lt1 ?H1 ?H3 = mk_ltype _ ?lt2 ?H2 ?H4 =>
+ generalize H1 as Heq1; generalize H2 as Heq2;
+ generalize H3 as Hwf1; generalize H4 as Hwf2
+ end; simpl.
+ intros Hwf1 Hwf2 <-. simpl.
+ move: Hwf1 Hwf2.
+ rewrite hcmap_hmap fmap_hcmap. simpl.
+ intros Hwf1 Hwf2 Heq. rewrite (UIP_refl _ _ Heq).
+ f_equiv. apply proof_irrelevance.
+ Qed.
+
+ Lemma ltype_lty_core {rt} (lt : ltype rt) :
+ ltype_lty (ltype_core lt) = lty_core (ltype_lty lt).
+ Proof. done. Qed.
+
+ Lemma ltype_core_array {rt} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) :
+ ltype_core (ArrayLtype def len lts) = ArrayLtype def len ((λ '(i, lt), (i, ltype_core lt)) <$> lts).
+ Proof.
+ rewrite /ltype_core /ArrayLtype /=.
+ match goal with
+ | |- mk_ltype _ ?lt1 ?H1 ?H3 = mk_ltype _ ?lt2 ?H2 ?H4 =>
+ generalize H1 as Heq1; generalize H2 as Heq2;
+ generalize H3 as Hwf1; generalize H4 as Hwf2
+ end; simpl.
+ intros Hwf1 Hwf2 <-. simpl.
+ move: Hwf1 Hwf2.
+ rewrite !map_map. simpl.
+
+ (*
+
+ (*fold @ltype_core.*)
+ simpl.
+ (*Search list_fmap map.*)
+ (*list_fmap*)
+ (*rewrite /map.*)
+ (*fmap*)
+ (*rewrite -(map_map (λ '(i, lt), (i, ltype_core lt)) (λ '(i, lt), (i, ltype_lty lt)) lts).*)
+ rewrite -ltype_lty_core.
+ specialize (map_map (λ '(i, lt), (i, ltype_lty lt)) (λ '(i, lt), (i, lty_core lt)) lts) as Ha.
+ simpl in Ha.
+ rewrite /fmap.
+ simpl.
+
+ rewrite -Ha.
+
+ intros Hwf1 Hwf2 Heq.
+ rewrite (UIP_refl _ _ Heq).
+ move: Hwf1 Hwf2 Heq.
+ rewrite map_map.
+ rewrite /fmap. simpl. f_equiv.
+
+ f_equiv. apply proof_irrelevance.
+ *)
+ (*Qed.*)
+ Admitted.
+ Lemma ltype_core_opened {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost :
+ ltype_core (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) = OpenedLtype lt_cur lt_inner lt_full Cpre Cpost.
+ Proof.
+ rewrite /ltype_core /OpenedLtype /=.
+ f_equiv; simpl.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_coreable {rt_full} (κs : list lft) (lt_full : ltype rt_full) :
+ ltype_core (CoreableLtype κs lt_full) = ltype_core lt_full.
+ Proof.
+ rewrite /ltype_core /CoreableLtype /=.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+ Lemma ltype_core_shadowed {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full) :
+ ltype_core (ShadowedLtype lt_cur r_cur lt_full) = ltype_core lt_full.
+ Proof.
+ rewrite /ltype_core /ShadowedLtype /=.
+ f_equiv.
+ - apply UIP_t.
+ - apply proof_irrelevance.
+ Qed.
+
+ (** Rules for ltype_st *)
+ Lemma ltype_st_ofty {rt} (ty : type rt) :
+ ltype_st (OfTy ty) = ty.(ty_syn_type).
+ Proof. done. Qed.
+ Lemma ltype_st_alias rt st p :
+ ltype_st (AliasLtype rt st p) = st.
+ Proof. done. Qed.
+ Lemma ltype_st_blocked {rt} (ty : type rt) (κ : lft) :
+ ltype_st (BlockedLtype ty κ) = ty.(ty_syn_type).
+ Proof. done. Qed.
+ Lemma ltype_st_shrblocked {rt} (ty : type rt) (κ : lft) :
+ ltype_st (ShrBlockedLtype ty κ) = ty.(ty_syn_type).
+ Proof. done. Qed.
+ Lemma ltype_st_box {rt} (lt : ltype rt) :
+ ltype_st (BoxLtype lt) = PtrSynType.
+ Proof. done. Qed.
+ Lemma ltype_st_owned_ptr {rt} (lt : ltype rt) (ls : bool) :
+ ltype_st (OwnedPtrLtype lt ls) = PtrSynType.
+ Proof. done. Qed.
+ Lemma ltype_st_mut_ref {rt} (lt : ltype rt) (κ : lft) :
+ ltype_st (MutLtype lt κ) = PtrSynType.
+ Proof. done. Qed.
+ Lemma ltype_st_shr_ref {rt} (lt : ltype rt) (κ : lft) :
+ ltype_st (ShrLtype lt κ) = PtrSynType.
+ Proof. done. Qed.
+ Lemma ltype_st_struct {rts} (lts : hlist ltype rts) (sls : struct_layout_spec) :
+ ltype_st (StructLtype lts sls) = sls.
+ Proof. done. Qed.
+ Lemma ltype_st_array {rt} (def : type rt) (len : nat) (lts : list (nat * ltype rt)) :
+ ltype_st (ArrayLtype def len lts) = ArraySynType (ty_syn_type def) len.
+ Proof. rewrite /ltype_st /= //. Qed.
+ Lemma ltype_st_opened {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost :
+ ltype_st (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) = ltype_st lt_cur.
+ Proof. done. Qed.
+ Lemma ltype_st_coreable {rt_full} κs (lt_full : ltype rt_full) :
+ ltype_st (CoreableLtype κs lt_full) = ltype_st lt_full.
+ Proof. done. Qed.
+ Lemma ltype_st_shadowed {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full) :
+ ltype_st (ShadowedLtype lt_cur r_cur lt_full) = ltype_st lt_full.
+ Proof. done. Qed.
+
+ (** Lifting the core equations to ltypes *)
+ Lemma ltype_own_core_equiv {rt} (lt : ltype rt) k π r l :
+ ltype_own_core lt k π r l ≡ ltype_own (ltype_core lt) k π r l.
+ Proof.
+ rewrite ltype_own_unseal ltype_own_core_unseal /ltype_own_core_def /ltype_own_def.
+ assert (Heq : lty_rt (ltype_lty lt) = lty_rt (lty_core (ltype_lty lt))).
+ { rewrite lty_core_rt_eq. done. }
+ unshelve rewrite /ltype_own_pre (lty_own_core_equiv _ false); first apply Heq.
+ simpl. iApply lty_own_pre_rfn_eq'.
+ move: Heq.
+ generalize (ltype_rt_agree lt) as Heq2.
+ generalize (ltype_rt_agree (ltype_core lt)) as Heq2.
+ simpl. rewrite lty_core_rt_eq.
+ intros Heq1 Heq2 Heq3. rewrite (UIP_t _ _ _ Heq1 Heq2).
+ rewrite (UIP_refl _ _ Heq3). done.
+ Qed.
+ Lemma ltype_own_core_core {rt} (lt : ltype rt) k π r l :
+ ltype_own_core (ltype_core lt) k π r l ≡ ltype_own_core lt k π r l.
+ Proof.
+ rewrite ltype_own_core_unseal /ltype_own_core_def.
+ assert (Heq : lty_rt (lty_core (ltype_lty lt)) = lty_rt (ltype_lty lt)).
+ { rewrite lty_core_rt_eq. done. }
+ unshelve rewrite /ltype_own_pre lty_own_core_core'; first apply Heq.
+ simpl. iApply lty_own_pre_rfn_eq'.
+ move: Heq.
+ generalize (ltype_rt_agree lt) as Heq2.
+ generalize (ltype_rt_agree (ltype_core lt)) as Heq2.
+ simpl. rewrite lty_core_rt_eq.
+ intros Heq1 Heq2 Heq3. rewrite (UIP_t _ _ _ Heq1 Heq2).
+ rewrite (UIP_refl _ _ Heq3). done.
+ Qed.
+
+
+ (** Compute the lifetimes at which there are blocked components of an lty. *)
+ Fixpoint lty_blocked_lfts (lt : lty) : list lft :=
+ match lt with
+ | OfTyLty ty => []
+ | AliasLty _ _ _ => []
+ | BlockedLty ty κ => [κ]
+ | ShrBlockedLty ty κ => [κ]
+ | BoxLty lt => lty_blocked_lfts lt
+ | OwnedPtrLty lt ls => lty_blocked_lfts lt
+ | MutLty lt κ => lty_blocked_lfts lt
+ | ShrLty lt κ => lty_blocked_lfts lt
+ | StructLty lts sls => concat (map lty_blocked_lfts lts)
+ | ArrayLty def len lts => concat (map (λ '(_, lt), lty_blocked_lfts lt) lts)
+ | OpenedLty _ _ _ _ _ => []
+ | CoreableLty κs _ => κs
+ | ShadowedLty lt_cur r_cur lt_full => lty_blocked_lfts lt_full
+ end.
+
+ Definition ltype_blocked_lfts {rt} (lt : ltype rt) : list lft :=
+ lty_blocked_lfts (lt.(ltype_lty)).
+
+ (** ** Deinitialization of ltypes *)
+ (** An ltype is deinitializable if [Owned] ownership of it allows us to extract a ghost-drop observation and transform it to an [â— uninit] place.
+ This is used when we overwrite a place or don't need it anymore.
+ *)
+ (*
+ Fixpoint lty_deinitializable (lt : lty) : Prop :=
+ match lt with
+ | BlockedLty _ _ => False
+ | ShrBlockedLty _ _ => False
+ | OfTyLty _ => True
+ | AliasLty _ _ _ => False
+ | MutLty _ _ => True
+ | ShrLty _ _ => True
+ | BoxLty _ =>
+ (* honestly, it is a bug to get into this case. We should not just drop a box, but the drop glue should be called. *)
+ False
+ | OwnedPtrLty _ _ => True
+ | StructLty lts sls =>
+ Forall_cb (λ lt, lty_deinitializable lt) lts
+ | ArrayLty def len lts =>
+ Forall_cb (λ '(_, lt), lty_deinitializable lt) lts
+ | OpenedLty _ _ _ _ _ => False
+ | CoreableLty _ _ => False
+ | ShadowedLty lt _ _ =>
+ lty_deinitializable lt
+ end.
+ Definition ltype_deinitializable {rt} (lt : ltype rt) :=
+ lty_deinitializable lt.(ltype_lty).
+
+ Definition lty_ghost_drop_own (π : thread_id) (lt : lty) : place_rfn (lty_rt lt) → iProp Σ.
+ Proof.
+ eapply (lty_recursor (λ lt, place_rfn (lty_rt lt) → iProp Σ)).
+ - intros ????. exact True%I.
+ - intros ????. exact True%I.
+ - intros rt ty r. exact (∃ r', place_rfn_interp_owned r r' ∗ ty_ghost_drop ty π r')%I.
+ - intros ????. exact True%I.
+ - intros lt' R ? r. exact (∃ r', place_rfn_interp_owned r r')%I.
+ - intros lt' R ? r. exact (∃ r', place_rfn_interp_owned r r')%I.
+ - intros lt' R r.
+ destruct r as [ r | γ ].
+ + refine (R r).
+ + refine (∃ r' : place_rfn (lty_rt lt'), place_rfn_interp_owned (PlaceGhost γ) r')%I.
+ - intros lt' ? R r.
+ destruct r as [ [r ?] | γ ].
+ + refine (R r).
+ + refine (∃ r' : (place_rfn (lty_rt lt') * loc), place_rfn_interp_owned (PlaceGhost γ) r')%I.
+ - intros lts R sls r.
+ destruct r as [ r | γ]; first last.
+ { refine (∃ r' : lty_rt (StructLty lts sls), place_rfn_interp_owned (PlaceGhost γ) r')%I. }
+ induction R as [ | ? Ha ? ? IH ].
+ + refine True%I.
+ + destruct r as [r0 r].
+ refine (Ha r0 ∗ IH r)%I.
+ - intros rt def len lts R r.
+ destruct r as [ r | γ ]; first last.
+ { refine (∃ r' : lty_rt (@ArrayLty _ def len lts), place_rfn_interp_owned (PlaceGhost γ) r')%I. }
+ (*
+ (* get all the observations from the components;
+ probably want to encapsulate that into some definition that we can reason symbolically about, since we cannot just compute this explicitly.
+ *)
+ induction lts as [ | lt' lts IH].
+ + refine True%I.
+ + inversion R as [ | ? Ha ? Hb]; subst.
+ destruct r as [ | r0 r]; first exact False%I.
+ refine (Ha r0 ∗ IH Hb r)%I.
+ *)
+ exact True%I. (* TODO *)
+ - intros ??????? IHcur ?? r. exact (IHcur r).
+ - intros ?? R r. exact (True)%I.
+ - intros ?? r_cur ? IHcur ? r.
+ exact True%I. (* TODO: this doesn't really work well rn, since this will not compute for symbolic lists. *)
+ (*exact (IHcur (PlaceIn r_cur)).*)
+ Defined.
+ Definition ltype_ghost_drop_own (π : thread_id) {rt} (lt : ltype rt) (r : place_rfn rt) : iProp Σ :=
+ lty_ghost_drop_own π lt.(ltype_lty) (rew <- lt.(ltype_rt_agree) in r).
+
+ Definition lty_ly (lt : lty) : layout := use_layout_alg' (lty_st lt).
+ Definition ltype_ly {rt} (lt : ltype rt) : layout := use_layout_alg' (ltype_st lt).
+
+ Lemma lty_own_ghost_drop_owned π F (lt : lty) wl r l :
+ lftE ⊆ F → lty_own lt (Owned wl) π r l ={F}=∗ lty_ghost_drop_own π lt r.
+ Proof.
+ intros ?.
+ induction lt using lty_induction in wl, r, l |-*; simpl.
+ - eauto.
+ - eauto.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & ? & Hcred & %r' & Hrfn & Hl)".
+ iMod (maybe_use_credit with "Hcred Hl") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%v & Hl & Hv)".
+ iModIntro. eauto with iFrame.
+ (* ... *)
+ - eauto.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & Hlb & Hcred & %γ & %r' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%l' & Hl & Hb)".
+ iModIntro. eauto with iFrame.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & %r' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%l' & Hl & Hb)".
+ iModIntro. eauto with iFrame.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & %r' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%l' & %ly' & Hl & %Hst' & %Hly' & Hfree & Hb)".
+ (* in practice, we should never run into this, because the box should first get dropped *)
+ destruct r as [ | ]; first last. { simpl. iModIntro. iExists _. iFrame. }
+ iDestruct "Hrfn" as "<-". iApply (IHlt with "Hb").
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & %r' & %l' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%ly' & Hl & %Hst' & %Hly' & Hb)".
+ destruct r as [ [] | ]; first last. { simpl. iModIntro. iExists _. iFrame. }
+ iDestruct "Hrfn" as "%Heq". injection Heq as <- <-. iApply (IHlt with "Hb").
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%sl & %Halg & %Hlen & %Hly & ? & Hcred & %r' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ rewrite big_sepL_P_eq. destruct r; first last. { simpl. iModIntro. eauto with iFrame. }
+ Admitted.
+
+ Lemma lty_own_deinit_ghost_drop_owned π F (lt : lty) wl r l :
+ lftE ⊆ F →
+ lty_deinitializable lt →
+ lty_own lt (Owned wl) π r l ={F}=∗
+ lty_ghost_drop_own lt r ∗ l ↦|lty_ly lt|.
+ Proof.
+ intros ? Hdeinit.
+ induction lt using lty_induction; simpl; try done.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & ? & Hcred & %r' & Hrfn & Hl)".
+ iMod (maybe_use_credit with "Hcred Hl") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%v & Hl & Hv)".
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hvly"; first done.
+ iModIntro. iSplitL "Hrfn". { eauto with iFrame. }
+ iExists _. iFrame. rewrite /lty_ly /= /use_layout_alg' Halg /= //.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & Hlb & Hcred & %γ & %r' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%l' & Hl & Hb)".
+ iModIntro. iSplitL "Hrfn". { eauto with iFrame. }
+ iExists _. iFrame. iR. simpl.
+ apply syn_type_has_layout_ptr_inv in Halg. subst. done.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & %r' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%l' & Hl & Hb)".
+ iModIntro. iSplitL "Hrfn". { eauto with iFrame. }
+ iExists _. iFrame. iR. simpl.
+ apply syn_type_has_layout_ptr_inv in Halg. subst. done.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & %r' & %l' & Hrfn & Hb)".
+ iMod (maybe_use_credit with "Hcred Hb") as "(_ & _ & Hl)"; first done.
+ iDestruct "Hl" as "(%ly' & Hl & %Hst' & %Hly' & Hb)".
+ iSplitR "Hl"; first last. {
+ iModIntro. iExists _. iFrame. iR. apply syn_type_has_layout_ptr_inv in Halg. subst. done. }
+ destruct r as [ [] | ]; first last. { simpl. iModIntro. iExists _. iFrame. }
+ iDestruct "Hrfn" as "%Heq". injection Heq as <- <-.
+ by iApply (lty_own_ghost_drop_owned with "Hb").
+ -
+ Admitted.
+
+ Lemma ltype_own_deinit_ghost_drop_owned {rt} π F (lt : ltype rt) r l wl :
+ lftE ⊆ F →
+ ltype_deinitializable lt →
+ ltype_own lt (Owned wl) π r l ={F}=∗
+ ltype_ghost_drop_own lt r ∗ l ↦|ltype_ly lt|.
+ Proof.
+ intros ? Hdeinit. rewrite ltype_own_unseal.
+ by iApply lty_own_deinit_ghost_drop_owned.
+ Qed.
+ *)
+
+
+ (* Q for products:
+ - when one of the components is blocked, I also shouldn't be able to get the pointsto.
+ But in principle I could get the observatoin.
+ So what to do in that case?
+
+ l â—â‚— StructLtype [Blocked (int i32); int i32]
+ In this case: don't get a pointsto, and don't get an observation (the value that flows back is irrelevant)
+ We should anyways never deinit in such a case.
+ l â—â‚— BoxLtype (StructLtype [Blocked (int i32); int i32])
+ In this case: do get a pointsto.
+ In addition, we leak the memory owned by the box. Really, it should be deallocated properly somewhere.
+ Effectively, we should never deinit such a place, because the drop function should require full ownership of the box.
+ If the blocked is still ongoing, this would already be prohibited by the rust type system.
+ l â—â‚— StructLtype [Blocked (int i32); MutLtype ..]
+ In this case: don't get a pointsto, but get an observation from the reference
+ But: We should anyways never deinit in such a case, because it can't be overwritten.
+
+ Is it true that when we deinit, we can assume that there is no directly blocked thing?
+ - Yes. Otherwise, we'd not be able to write to the place anymore.
+ - below mut_ref, there may be blocked things (reborrows).
+ - below boxes, there are none in practice (we would leak memory), but in our logic it would be fine.
+
+ Do we need ghost_drop for anything apart from deinit?
+ - Yes. When returning, we may want to collect a ghost_drop from a MutLty, even if there are Blocked (reborrow) below
+
+ So: we need two operations
+ - one that yields ghost_drop and works for any ltype
+ => used when overwriting a location. e.g. imagine a write to a partially blocked place.
+ But I guess even then I need to be able to go to uninit, otherwise I cannot perform the write afterwards.
+ - one that has a deinitializability condition, and produces ghost drop + a pointsto
+ =>
+
+ Why not just have some subtyping operations to â— uninit?
+ -> because we need a logical step? But I guess I could also just use the credits I have without restoring them.
+
+ On writes, generally require to subtype the place to uninit? in the process of the subtyping, we could then extract the ghost thing.
+
+
+ ty_ghost_drop ty r -∗ T
+ --------------------------------------------------
+ weak_subltype (Owned false) (â— ty) (â— uninit st) T
+ (wrong! currently needs an lstep!)
+
+
+ weak_subltype (Owned wl) (StructLtype sls lts) (â— struct_t sls (replicate uninit)) T
+ -----------------------------------------------------------------
+ weak_subltype (Owned wl) (StructLtype sls lts) (â— uninit st) T
+
+
+ (extract observation from lt) -∗ T
+ -----------------------------------------------------------
+ weak_subltype (Owned wl) (MutLtype lt κ) (◠uninit st) T
+
+
+ So, for the latter, I really need a separate operation for extracting observations from ltypes at Uniq κ γ?
+
+
+
+ Any disadvantages of all of this?
+ - in my current semantic model, I need a logical step to ghost-drop.
+ This is because I might go below boxes.
+ However, in practice they would anyways be deallocated in time.
+ So maybe ghostdrop for box shoudl be True?
+ - might I ever need this in the future, when having a better model for refinements of mutref?
+ e.g. might I need to descend below other mutrefs? (where I cannot use up the credits)
+ -> better keep this avenue open.
+ - So, ideally, this ghost drop thing for ltypes would give us a logical step.
+
+ Have a separate judgment for this?
+ Basically, subtype to uninit in a logical step
+ -> owned_subltype_step?
+
+ ty_ghost_drop ty r -∗ T
+ --------------------------------------------------
+ owned_subltype_step (â— ty) (â— uninit st) T
+ (wrong! currently needs an lstep!)
+
+
+ owned_subltype_step (StructLtype sls lts) (â— struct_t sls (replicate uninit)) T
+ -----------------------------------------------------------------
+ owned_subltype_step (StructLtype sls lts) (â— uninit st) T
+
+
+ lty_uniq_deinitializable ∗ (extract observation from lt) -∗ T
+ -----------------------------------------------------------
+ owned_subltype_step (MutLtype lt κ) (◠uninit st) T
+ *)
+
+ Fixpoint lty_uniq_deinitializable (lt : lty) : Prop :=
+ match lt with
+ | BlockedLty _ _ => False
+ | ShrBlockedLty _ _ => False
+ | OfTyLty _ => True
+ | AliasLty _ _ _ => False
+ | MutLty _ _ => True
+ | ShrLty _ _ => True
+ | BoxLty _ =>
+ (* honestly, it is a bug to get into this case. We should not just drop a box, but the drop glue should be called. *)
+ False
+ | OwnedPtrLty _ _ => True
+ | StructLty lts sls =>
+ True
+ | ArrayLty def len lts =>
+ True
+ | OpenedLty _ _ _ _ _ => False
+ | CoreableLty _ _ => True
+ | ShadowedLty lt _ _ =>
+ False
+ end.
+ Definition ltype_uniq_deinitializable {rt} (lt : ltype rt) :=
+ lty_uniq_deinitializable lt.(ltype_lty).
+
+ Lemma lty_own_deinit_ghost_drop_uniq π F (lt : lty) κ γ r l :
+ lftE ⊆ F →
+ lty_uniq_deinitializable lt →
+ lty_own lt (Uniq κ γ) π r l ={F}=∗
+ place_rfn_interp_mut r γ.
+ Proof.
+ intros ? Hdeinit.
+ induction lt using lty_induction; simpl; try done.
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & %Hly & ? & ? & Hcred & ? & $ & Hl)".
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & %Hly & Hlb & Hcred & ? & $ & Hb)".
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & $ & Hb)".
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & $ & Hb)".
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & ? & $ & Hb)".
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & ? & $ & Hb)".
+ - rewrite /lty_own. simp lty_own_pre.
+ by iIntros "(%ly & %Halg & ? & ? & $ & _)".
+ Qed.
+ Lemma ltype_own_deinit_ghost_drop_uniq π F {rt} (lt : ltype rt) κ γ r l :
+ lftE ⊆ F →
+ ltype_uniq_deinitializable lt →
+ ltype_own lt (Uniq κ γ) π r l ={F}=∗
+ place_rfn_interp_mut r γ.
+ Proof.
+ iIntros (??) "Hown".
+ iPoseProof (lty_own_deinit_ghost_drop_uniq _ _ (lt.(ltype_lty)) with "[Hown]") as "Ha";
+ [done | done | ..].
+ { rewrite ltype_own_unseal. done. }
+ destruct lt; subst; eauto.
+ Qed.
+
+ Fixpoint lty_uniq_extractable (lt : lty) : option (option lft) :=
+ match lt with
+ | BlockedLty _ κ => Some (Some κ)
+ | ShrBlockedLty _ _ => Some None
+ | OfTyLty _ => Some (None)
+ | AliasLty _ _ _ => None
+ | MutLty _ _ => Some None
+ | ShrLty _ _ => Some None
+ | BoxLty _ =>
+ (* TODO honestly, it is a bug to get into this case. We should not just drop a box, but the drop glue should be called. *)
+ Some None
+ | OwnedPtrLty _ _ => Some None
+ | StructLty lts sls =>
+ Some None
+ | ArrayLty def len lts =>
+ Some None
+ | OpenedLty _ _ _ _ _ => None
+ | CoreableLty _ _ => Some None
+ | ShadowedLty lt _ _ =>
+ None
+ end.
+ Definition ltype_uniq_extractable {rt} (lt : ltype rt) : option (option lft) :=
+ lty_uniq_extractable lt.(ltype_lty).
+
+
+ Inductive inherit_ghost := InheritGhost.
+ Lemma lty_own_extract_ghost_drop_uniq π F (lt : lty) κ κm γ r l :
+ lftE ⊆ F →
+ lty_uniq_extractable lt = Some κm →
+ lty_own lt (Uniq κ γ) π r l ={F}=∗
+ (MaybeInherit (κm) InheritGhost (place_rfn_interp_mut r γ)).
+ Proof.
+ intros ? Hdeinit.
+ rewrite /MaybeInherit/Inherit.
+ induction lt using lty_induction; simpl; simpl in Hdeinit; try done.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-. simpl.
+ iIntros "(%ly & %Halg & %Hly & ? & ? & Hinh & Hcred & Hl)".
+ iModIntro. iIntros (??) "Ha".
+ iMod (fupd_mask_mono with "(Hinh Ha)") as "($ & _)"; first done.
+ done.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hlb & (%r' & -> & Hobs & Hb))". injection Hdeinit as <-.
+ iModIntro. iIntros (??). simpl. by iFrame.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & ? & Hr & Hb)".
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & ? & Hb)". injection Hdeinit as <-.
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & ? & Hb)". injection Hdeinit as <-.
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-.
+ iIntros "(%ly & %Halg & %Hly & ? & Hcred & ? & ? & Hb)".
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-.
+ iIntros "(%ly & %Halg & ? & ? & ? & ? & ? & _)".
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-.
+ iIntros "(%ly & %Halg & ? & ? & ? & ? & ? & ? & _)".
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-.
+ iIntros "(%ly & %Halg & ? & ? & ? & ? & ? & ? & _)".
+ iModIntro. iIntros (??). by iFrame.
+ - rewrite /lty_own. simp lty_own_pre. injection Hdeinit as <-.
+ iIntros "(%ly & %Halg & ? & ? & ? & _)".
+ iModIntro. iIntros (??). by iFrame.
+ Qed.
+ Lemma ltype_own_extract_ghost_drop_uniq π F {rt} (lt : ltype rt) κ κm γ r l :
+ lftE ⊆ F →
+ ltype_uniq_extractable lt = Some κm →
+ ltype_own lt (Uniq κ γ) π r l ={F}=∗
+ MaybeInherit κm InheritGhost (place_rfn_interp_mut r γ).
+ Proof.
+ iIntros (??) "Hown".
+ iPoseProof (lty_own_extract_ghost_drop_uniq _ _ (lt.(ltype_lty)) with "[Hown]") as "Ha";
+ [done | done | ..].
+ { rewrite ltype_own_unseal. done. }
+ destruct lt; subst; eauto.
+ Qed.
+End ltype_def.
+
+Notation "# x" := (PlaceIn x) (at level 9) : stdpp_scope.
+Notation "👻 γ" := (PlaceGhost γ) (at level 9) : stdpp_scope.
+Notation "â— ty" := (OfTy ty) (at level 15) : bi_scope.
+
+Notation "l â—â‚—[ Ï€ , k ] r @ ty" := (ltype_own ty k Ï€ r l) (at level 15) : bi_scope.
+Notation "l â—â‚—[ Ï€ , k ] .@ ty" := (ltype_own ty k Ï€ (PlaceIn ()) l) (at level 15) : bi_scope.
+
+(** Ltac for simplifying some of the Ltac functions that don't compute *)
+Ltac simp_ltype_core Heq :=
+ cbn in Heq;
+ repeat lazymatch type of Heq with
+ | _ = ltype_core (ltype_core _) =>
+ rewrite ltype_core_idemp in Heq
+ | _ = ltype_core (OfTy _) =>
+ rewrite ltype_core_ofty in Heq
+ | _ = ltype_core (AliasLtype _ _ _) =>
+ rewrite ltype_core_alias in Heq
+ | _ = ltype_core (BlockedLtype _ _) =>
+ rewrite ltype_core_blocked in Heq
+ | _ = ltype_core (ShrBlockedLtype _ _) =>
+ rewrite (ltype_core_shrblocked) in Heq
+ | _ = ltype_core (BoxLtype _) =>
+ rewrite (ltype_core_box) in Heq
+ | _ = ltype_core (OwnedPtrLtype _ _) =>
+ rewrite (ltype_core_owned_ptr) in Heq
+ | _ = ltype_core (MutLtype _ _) =>
+ rewrite (ltype_core_mut_ref) in Heq
+ | _ = ltype_core (ShrLtype _ _) =>
+ rewrite (ltype_core_shr_ref) in Heq
+ | _ = ltype_core (StructLtype _ _) =>
+ rewrite (ltype_core_struct) in Heq
+ | _ = ltype_core (ArrayLtype _ _ _) =>
+ rewrite (ltype_core_array) in Heq
+ | _ = ltype_core (OpenedLtype _ _ _ _ _) =>
+ rewrite (ltype_core_opened) in Heq
+ | _ = ltype_core (CoreableLtype _ _) =>
+ rewrite (ltype_core_coreable) in Heq
+ | _ = ltype_core (ShadowedLtype _ _ _) =>
+ rewrite (ltype_core_shadowed _ _ _) in Heq
+ end.
+Ltac simp_ltype_st Heq :=
+ cbn in Heq;
+ repeat lazymatch type of Heq with
+ | _ = ltype_st (ltype_core _) =>
+ rewrite ltype_core_syn_type_eq in Heq
+ | _ = ltype_st (OfTy _) =>
+ rewrite ltype_st_ofty in Heq
+ | _ = ltype_st (AliasLtype _ _ _) =>
+ rewrite ltype_st_alias in Heq
+ | _ = ltype_st (BlockedLtype _ _) =>
+ rewrite ltype_st_blocked in Heq
+ | _ = ltype_st (ShrBlockedLtype _ _) =>
+ rewrite (ltype_st_shrblocked) in Heq
+ | _ = ltype_st (OwnedPtrLtype _ _) =>
+ rewrite (ltype_st_owned_ptr) in Heq
+ | _ = ltype_st (MutLtype _ _) =>
+ rewrite (ltype_st_mut_ref) in Heq
+ | _ = ltype_st (ShrLtype _ _) =>
+ rewrite (ltype_st_shr_ref) in Heq
+ | _ = ltype_st (StructLtype _ _) =>
+ rewrite (ltype_st_struct) in Heq; simpl in Heq
+ | _ = ltype_st (ArrayLtype _ _ _) =>
+ rewrite (ltype_st_array) in Heq; simpl in Heq
+ | _ = ltype_st (OpenedLtype _ _ _ _ _) =>
+ rewrite (ltype_st_opened) in Heq
+ | _ = ltype_st (CoreableLtype _ _) =>
+ rewrite (ltype_st_coreable) in Heq
+ | _ = ltype_st (ShadowedLtype _ _ _) =>
+ rewrite (ltype_st_shadowed _ _ _) in Heq
+ end.
+
+Ltac simp_ltype :=
+ match goal with
+ | |- context[ltype_core ?lt] =>
+ assert_fails (is_var lt);
+ let ltc := fresh "ltc" in
+ let Heq := fresh "Heq_lt" in
+ remember (ltype_core lt) as ltc eqn:Heq;
+ simp_ltype_core Heq;
+ subst ltc
+ | |- context[ltype_st ?lt] =>
+ assert_fails (is_var lt);
+ let ltc := fresh "ltc" in
+ let Heq := fresh "Heq_lt" in
+ remember (ltype_st lt) as ltc eqn:Heq;
+ simp_ltype_st Heq;
+ subst ltc
+ end.
+Ltac simp_ltypes := repeat simp_ltype.
+
+Tactic Notation "simp_ltype" "in" hyp(H) :=
+ match type of H with
+ | context[ltype_core ?lt] =>
+ assert_fails (is_var lt);
+ let ltc := fresh "ltc" in
+ let Heq := fresh "Heq_lt" in
+ remember (ltype_core lt) as ltc eqn:Heq in H;
+ simp_ltype_core Heq;
+ subst ltc
+ | context[ltype_st ?lt] =>
+ assert_fails (is_var lt);
+ let ltc := fresh "ltc" in
+ let Heq := fresh "Heq_lt" in
+ remember (ltype_st lt) as ltc eqn:Heq in H;
+ simp_ltype_st Heq;
+ subst ltc
+ end.
+Tactic Notation "simp_ltypes" "in" hyp(H) := repeat simp_ltype in H.
+
+(** ** Ltype subtyping *)
+Definition ltype_incl' `{!typeGS Σ} {rt1 rt2 : Type} (b : bor_kind) r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : iProp Σ :=
+ (â–¡
+ match b with
+ | Owned wl =>
+ ∀ π l, ltype_own lt1 (Owned wl) π r1 l ={lftE}=∗ ltype_own lt2 (Owned wl) π r2 l
+ | Uniq κ γ =>
+ ∀ π l, ltype_own lt1 (Uniq κ γ) π r1 l -∗ ltype_own lt2 (Uniq κ γ) π r2 l
+ | Shared κ =>
+ ∀ π l, ltype_own lt1 (Shared κ) π r1 l -∗ ltype_own lt2 (Shared κ) π r2 l
+ end).
+
+Definition ltype_incl `{!typeGS Σ} {rt1 rt2 : Type} (b : bor_kind) r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : iProp Σ :=
+ (â–¡ (* same layout *)
+ (⌜ltype_st lt1 = ltype_st lt2⌠∗
+ ltype_incl' b r1 r2 lt1 lt2 ∗
+ ltype_incl' b r1 r2 (ltype_core lt1) (ltype_core lt2)
+ )).
+Global Instance ltype_incl_persistent `{!typeGS Σ} {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : Persistent (ltype_incl b r1 r2 lt1 lt2) := _.
+
+Definition ltype_eq `{!typeGS Σ} {rt1 rt2 : Type} (b : bor_kind) r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : iProp Σ :=
+ ltype_incl b r1 r2 lt1 lt2 ∗ ltype_incl b r2 r1 lt2 lt1.
+Global Instance ltype_eq_persistent `{!typeGS Σ} {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : Persistent (ltype_eq b r1 r2 lt1 lt2) := _.
+
+(** Heterogeneous ltype equality *)
+Definition eqltype `{!typeGS Σ} (E : elctx) (L : llctx) {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ (rrust_ctx -∗ elctx_interp E -∗ ltype_eq b r1 r2 lt1 lt2).
+#[export]
+Instance: Params (@eqltype) 6 := {}.
+
+(** Homogeneous ltype equality, disregarding the refinement and borkind *)
+Definition full_eqltype `{!typeGS Σ} (E : elctx) (L : llctx) {rt} (lt1 : ltype rt) (lt2 : ltype rt) : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ rrust_ctx -∗ elctx_interp E -∗ ∀ b r, ltype_eq b r r lt1 lt2.
+#[export]
+Instance: Params (@full_eqltype) 5 := {}.
+
+(** Heterogeneous ltype subtyping *)
+Definition subltype `{!typeGS Σ} (E : elctx) (L : llctx) {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ rrust_ctx -∗ (elctx_interp E -∗ ltype_incl b r1 r2 lt1 lt2).
+#[export]
+Instance: Params (@subltype) 6 := {}.
+
+(** Homogeneous ltype subtyping, disregarding the refinement and borkind *)
+Definition full_subltype `{!typeGS Σ} (E : elctx) (L : llctx) {rt} (lt1 : ltype rt) (lt2 : ltype rt) : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ rrust_ctx -∗ elctx_interp E -∗ ∀ b r, ltype_incl b r r lt1 lt2.
+#[export]
+Instance: Params (@full_subltype) 5 := {}.
+
+Section eqltype.
+ Context `{!typeGS Σ}.
+
+ (** *** [ltype_incl]/[ltype_eq] *)
+ Lemma ltype_incl_eq {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ ltype_incl b r1 r2 lt1 lt2 -∗ ltype_incl b r2 r1 lt2 lt1 -∗ ltype_eq b r1 r2 lt1 lt2.
+ Proof.
+ iIntros "H1 H2". iSplit; done.
+ Qed.
+
+ Lemma ltype_incl'_refl {rt} b r (lt : ltype rt) : ⊢ ltype_incl' b r r lt lt.
+ Proof.
+ iModIntro. destruct b; iIntros; try destruct wl; eauto.
+ Qed.
+ Lemma ltype_incl_refl {rt} b r (lt : ltype rt) : ⊢ ltype_incl b r r lt lt.
+ Proof.
+ iIntros "!>". iSplit; first done. iSplit; iApply ltype_incl'_refl.
+ Qed.
+ Lemma ltype_incl_trans {rt1 rt2 rt3} b r1 r2 r3 (lt1 : ltype rt1) (lt2 : ltype rt2) (lt3 : ltype rt3) :
+ ltype_incl b r1 r2 lt1 lt2 -∗ ltype_incl b r2 r3 lt2 lt3 -∗ ltype_incl b r1 r3 lt1 lt3.
+ Proof.
+ iIntros "(%Hly1 & #Hi1 & #Hc1) (%Hly2 & #Hi2 & #Hc2)".
+ iModIntro.
+ iSplit. { rewrite Hly1 Hly2. done. }
+ iSplit.
+ - iModIntro. destruct b.
+ + iIntros (??) "Ha". iMod ("Hi1" with "Ha") as "Ha". by iApply "Hi2".
+ + iIntros (??) "Ha". iPoseProof ("Hi1" with "Ha") as "Ha". by iApply "Hi2".
+ + iIntros (??) "Ha". iApply "Hi2". iApply "Hi1". done.
+ - iModIntro. destruct b.
+ + iIntros (??) "Ha". iMod ("Hc1" with "Ha") as "Ha". iApply ("Hc2" with "Ha").
+ + iIntros (??) "Ha". iApply "Hc2". iApply "Hc1". done.
+ + iIntros (??) "Ha". iApply "Hc2". iApply "Hc1". done.
+ Qed.
+
+ Lemma ltype_eq_refl {rt} b r (lt : ltype rt) : ⊢ ltype_eq b r r lt lt.
+ Proof.
+ iSplit; iApply ltype_incl_refl.
+ Qed.
+ Lemma ltype_eq_sym {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : ltype_eq b r1 r2 lt1 lt2 -∗ ltype_eq b r2 r1 lt2 lt1.
+ Proof.
+ iIntros "[H1 H2]". iSplit; done.
+ Qed.
+ Lemma ltype_eq_trans {rt1 rt2 rt3} b r1 r2 r3 (lt1 : ltype rt1) (lt2 : ltype rt2) (lt3 : ltype rt3) :
+ ltype_eq b r1 r2 lt1 lt2 -∗ ltype_eq b r2 r3 lt2 lt3 -∗ ltype_eq b r1 r3 lt1 lt3.
+ Proof.
+ iIntros "(Hi1 & Hi2) (Hj1 & Hj2)". iSplit.
+ - iApply (ltype_incl_trans with "Hi1 Hj1").
+ - iApply (ltype_incl_trans with "Hj2 Hi2").
+ Qed.
+
+ Lemma ltype_eq_syn_type {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ ltype_eq b r1 r2 lt1 lt2 -∗
+ ⌜ltype_st lt1 = ltype_st lt2âŒ.
+ Proof.
+ iIntros "((#$ & _) & _)".
+ Qed.
+ Lemma ltype_eq_core {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ ltype_eq b r1 r2 lt1 lt2 -∗ ltype_eq b r1 r2 (ltype_core lt1) (ltype_core lt2).
+ Proof.
+ iIntros "((%Hly_eq & #Hi & #Hc) & (_ & #Hi2 & #Hc2))".
+ iSplit; iModIntro.
+ - iSplit. { by rewrite !ltype_core_syn_type_eq. }
+ rewrite !ltype_core_idemp. iSplit; done.
+ - iSplit. { by rewrite !ltype_core_syn_type_eq. }
+ rewrite !ltype_core_idemp. iSplit; done.
+ Qed.
+
+ (** *** [eqltype] / [subltype] / [full_eqltype] / [full_subltype] *)
+ Lemma full_eqltype_alt E L {rt} (lt1 lt2 : ltype rt) :
+ full_eqltype E L lt1 lt2 ↔ (∀ b r, eqltype E L b r r lt1 lt2).
+ Proof.
+ split.
+ - iIntros (Heq b r qL) "HL CTX HE". iApply (Heq with "HL CTX HE").
+ - iIntros (Heq qL) "HL CTX HE". iIntros (b r). iApply (Heq with "HL CTX HE").
+ Qed.
+ Lemma full_subltype_alt E L {rt} (lt1 lt2 : ltype rt) :
+ full_subltype E L lt1 lt2 ↔ (∀ b r, subltype E L b r r lt1 lt2).
+ Proof.
+ split.
+ - iIntros (Hsub b r qL) "HL CTX HE". iApply (Hsub with "HL CTX HE").
+ - iIntros (Hsub qL) "HL CTX HE". iIntros (b r). iApply (Hsub with "HL CTX HE").
+ Qed.
+
+ Global Instance eqltype_refl E L {rt} b r : Reflexive (eqltype E L b (rt1:=rt) (rt2:=rt) r r).
+ Proof. iIntros (??) "? ? ?". iApply ltype_eq_refl. Qed.
+ Lemma eqltype_symm E L {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ eqltype E L b r1 r2 lt1 lt2 → eqltype E L b r2 r1 lt2 lt1.
+ Proof.
+ intros Heq.
+ iIntros (?) "HL CTX HE". iDestruct (Heq with "HL CTX HE") as "#Heq".
+ by iApply ltype_eq_sym.
+ Qed.
+ Lemma eqltype_trans E L {rt1 rt2 rt3} b r1 r2 r3 (lt1 : ltype rt1) (lt2 : ltype rt2) (lt3 : ltype rt3) :
+ eqltype E L b r1 r2 lt1 lt2 → eqltype E L b r2 r3 lt2 lt3 → eqltype E L b r1 r3 lt1 lt3.
+ Proof.
+ intros H1 H2.
+ iIntros (?) "HL #CTX #HE". iDestruct (H1 with "HL CTX HE") as "#Heq1".
+ iDestruct (H2 with "HL CTX HE") as "#Heq2".
+ iApply ltype_eq_trans; done.
+ Qed.
+
+ Global Instance full_eqltype_equivalence E L {rt}:
+ Equivalence (full_eqltype E L (rt:=rt)).
+ Proof.
+ split.
+ - intros ?. apply full_eqltype_alt => ??. apply eqltype_refl.
+ - intros ??. rewrite !full_eqltype_alt => ? ??. by apply eqltype_symm.
+ - intros ???. rewrite !full_eqltype_alt => H1 H2 ??. eapply eqltype_trans; [apply H1 | apply H2].
+ Qed.
+
+ Global Instance subltype_refl E L {rt} b r : Reflexive (subltype E L (rt1:=rt) (rt2:=rt) b r r).
+ Proof.
+ iIntros (lt ?) "HL CTX HE !>".
+ iSplitR; first done.
+ iSplit; iApply ltype_incl'_refl.
+ Qed.
+ Lemma subltype_trans E L {rt1 rt2 rt3} b r1 r2 r3 (lt1 : ltype rt1) (lt2 : ltype rt2) (lt3 : ltype rt3) :
+ subltype E L b r1 r2 lt1 lt2 → subltype E L b r2 r3 lt2 lt3 → subltype E L b r1 r3 lt1 lt3.
+ Proof.
+ iIntros (Hsub12 Hsub23). iIntros (?) "HL #CTX #HE".
+ iPoseProof (Hsub12 with "HL CTX HE") as "#Hsub12".
+ iPoseProof (Hsub23 with "HL CTX HE") as "#Hsub23".
+ iApply (ltype_incl_trans with "Hsub12 Hsub23").
+ Qed.
+ Global Instance full_subltype_preorder E L {rt} : PreOrder (full_subltype E L (rt := rt)).
+ Proof.
+ split.
+ - intros ?. apply full_subltype_alt. intros ??. apply subltype_refl.
+ - intros ???. rewrite !full_subltype_alt. intros H1 H2 ??. eapply subltype_trans; [apply H1 | apply H2].
+ Qed.
+
+ Lemma all_subltype_alt E L {rt} b (lt1 lt2 : ltype rt) :
+ (∀ r, subltype E L b r r lt1 lt2) ↔
+ (∀ qL, llctx_interp_noend L qL -∗ rrust_ctx -∗ elctx_interp E -∗ ∀ r, ltype_incl b r r lt1 lt2).
+ Proof.
+ split.
+ - intros Ha qL. iIntros "HL CTX HE" (r).
+ by iPoseProof (Ha r with "HL CTX HE") as "Ha".
+ - intros Ha r. iIntros (qL) "HL CTX HE".
+ iApply (Ha with "HL CTX HE").
+ Qed.
+ Lemma all_eqltype_alt E L {rt} b (lt1 lt2 : ltype rt) :
+ (∀ r, eqltype E L b r r lt1 lt2) ↔
+ (∀ qL, llctx_interp_noend L qL -∗ rrust_ctx -∗ elctx_interp E -∗ ∀ r, ltype_eq b r r lt1 lt2).
+ Proof.
+ split.
+ - intros Ha qL. iIntros "HL CTX HE" (r).
+ by iPoseProof (Ha r with "HL CTX HE") as "Ha".
+ - intros Ha r. iIntros (qL) "HL CTX HE".
+ iApply (Ha with "HL CTX HE").
+ Qed.
+
+ Lemma subltype_eqltype E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) b r1 r2 :
+ subltype E L b r1 r2 lt1 lt2 → subltype E L b r2 r1 lt2 lt1 → eqltype E L b r1 r2 lt1 lt2.
+ Proof.
+ intros Ha Hb. iIntros (?) "HL #CTX #HE".
+ iPoseProof (Ha with "HL CTX HE") as "#Ha". iPoseProof (Hb with "HL CTX HE") as "#Hb".
+ iSplit; done.
+ Qed.
+ Lemma full_subltype_eqltype E L {rt} (lt1 lt2 : ltype rt) :
+ full_subltype E L lt1 lt2 → full_subltype E L lt2 lt1 → full_eqltype E L lt1 lt2.
+ Proof.
+ rewrite !full_subltype_alt !full_eqltype_alt.
+ intros Ha Hb b r. eapply subltype_eqltype; done.
+ Qed.
+
+ (** ** Compatibilty of [OfTy] with subtyping *)
+ Lemma type_ltype_incl_shared_in {rt1 rt2} r1 r2 κ (ty1 : type rt1) (ty2 : type rt2) :
+ type_incl r1 r2 ty1 ty2 -∗
+ ltype_incl (Shared κ) #r1 #r2 (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros "Hsub".
+ iDestruct ("Hsub") as "(%Hst & #Hsceq & #Hown & #Hshr)".
+ iSplitR; first done; iModIntro; simpl.
+ simpl. simp_ltypes. rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (Ï€ l) "Hb". rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & Hst & ? & Hsc & ? & %r' & -> & #Hb)".
+ iExists ly. rewrite Hst. iFrame.
+ iSplitL "Hsc"; first by iApply "Hsceq".
+ iExists r2. iSplitR; first done. iModIntro. iMod "Hb". iModIntro. by iApply "Hshr".
+ Qed.
+ Lemma subtype_subltype_shared_in E L {rt1 rt2} r1 r2 κ (ty1 : type rt1) (ty2 : type rt2) :
+ subtype E L r1 r2 ty1 ty2 →
+ subltype E L (Shared κ) (PlaceIn r1) (PlaceIn r2) (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros (Hsub qL) "HL #CTX #HE". iPoseProof (Hsub with "HL HE") as "#Hsub".
+ by iApply (type_ltype_incl_shared_in).
+ Qed.
+
+ Lemma type_ltype_incl_shared {rt} `{!Inhabited rt} κ (ty1 : type rt) (ty2 : type rt) :
+ (∀ r, type_incl r r ty1 ty2) -∗
+ ∀ r, ltype_incl (Shared κ) r r (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros "#Hsub". iIntros (r).
+ iPoseProof ("Hsub" $! inhabitant) as "(%Hst & #Hsceq & _)".
+ iSplitR; first done. iModIntro.
+ simp_ltypes. rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (Ï€ l) "Hb". rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & Hst & ? & Hsc & ? & %r' & Hrfn & #Hb)".
+ iExists ly. rewrite Hst. iFrame.
+ iSplitL "Hsc"; first by iApply "Hsceq".
+ iExists r'. iFrame. iModIntro. iMod "Hb". iModIntro.
+ iDestruct ("Hsub" $! r') as "(_ & _ & _ & Hshr)".
+ by iApply "Hshr".
+ Qed.
+ Lemma subtype_subltype_shared E L {rt} `{!Inhabited rt} κ (ty1 : type rt) (ty2 : type rt) :
+ (∀ r, subtype E L r r ty1 ty2) →
+ ∀ r, subltype E L (Shared κ) r r (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros (Hsub r qL) "HL #CTX #HE".
+ rewrite all_subtype_alt in Hsub.
+ iPoseProof (Hsub with "HL HE") as "#Hsub".
+ iApply (type_ltype_incl_shared with "Hsub").
+ Qed.
+
+ Lemma type_ltype_incl_owned_in_strong {rt1 rt2} π r1 r2 wl (ty1 : type rt1) (ty2 : type rt2) :
+ ty1.(ty_syn_type) = ty2.(ty_syn_type) →
+ (∀ v, v â—áµ¥{Ï€} r1 @ ty1 -∗ v â—áµ¥{Ï€} r2 @ ty2) -∗
+ (ty1.(ty_sidecond) -∗ ty2.(ty_sidecond)) -∗
+ ∀ l, l â—â‚—[Ï€, Owned wl] #r1 @ (â— ty1) -∗ l â—â‚—[Ï€, Owned wl] #r2 @ (â— ty2)%I.
+ Proof.
+ iIntros (Hst) "Hsub Hsceq".
+ iIntros (l) "Hb".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & Hst & ? & Hsc & ? & ? & %r' & Hrfn & Hb)".
+ iExists ly. rewrite Hst. iFrame.
+ iSplitL "Hsceq Hsc". { by iApply "Hsceq". }
+ iExists r2. iSplitR; first done. iNext. iMod "Hb" as "(% & ? & Hv)". iExists _. iFrame.
+ iModIntro. iDestruct "Hrfn" as "->". by iApply "Hsub".
+ Qed.
+ Lemma type_ltype_incl_owned_in {rt1 rt2} r1 r2 wl (ty1 : type rt1) (ty2 : type rt2) :
+ type_incl r1 r2 ty1 ty2 -∗ ltype_incl (Owned wl) #r1 #r2 (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros "Hsub".
+ iDestruct ("Hsub") as "(%Hst & #Hsceq & #Hown & #Hshr)".
+ iSplitR; first done; iModIntro; simpl.
+ simpl. simp_ltypes. rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (Ï€ l) "Hb".
+ iApply (type_ltype_incl_owned_in_strong with "Hown"); [done.. | ].
+ done.
+ Qed.
+ Lemma subtype_subltype_owned_in E L {rt1 rt2} r1 r2 wl (ty1 : type rt1) (ty2 : type rt2) :
+ subtype E L r1 r2 ty1 ty2 → subltype E L (Owned wl) #r1 #r2 (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros (Hsub qL) "HL #CTX #HE". iPoseProof (Hsub with "HL HE") as "#Hsub".
+ by iApply (type_ltype_incl_owned_in).
+ Qed.
+
+ Lemma type_ltype_incl_owned {rt} `{!Inhabited rt} wl (ty1 : type rt) (ty2 : type rt) :
+ (∀ r, type_incl r r ty1 ty2) -∗ ∀ r, ltype_incl (Owned wl) r r (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros "#Hsub" (r).
+ iPoseProof ("Hsub" $! inhabitant) as "(%Hst & #Hsceq & _)".
+ iSplitR; first done; iModIntro; simpl.
+ simpl. simp_ltypes. rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (Ï€ l) "Hb".
+ iModIntro.
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & Hst & ? & Hsc & ? & ? & %r' & Hrfn & Hb)".
+ iDestruct ("Hsub" $! r') as "(_ & _ & #Hown & #Hshr)".
+ iExists ly. rewrite Hst. iFrame.
+ iSplitL "Hsc"; first by iApply "Hsceq".
+ iExists r'. iFrame. iNext. iMod "Hb" as "(% & ? & Hv)". iExists _. iFrame.
+ iModIntro. by iApply "Hown".
+ Qed.
+ Lemma subtype_subltype_owned E L {rt} `{!Inhabited rt} wl (ty1 : type rt) (ty2 : type rt) :
+ (∀ r, subtype E L r r ty1 ty2) → ∀ r, subltype E L (Owned wl) r r (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros (Hsub r qL) "HL #CTX #HE". rewrite all_subtype_alt in Hsub.
+ iPoseProof (Hsub with "HL HE") as "#Hsub".
+ iApply (type_ltype_incl_owned with "Hsub").
+ Qed.
+
+ (* NOTE: We do not get a direct heterogeneous subtyping lemma in the Uniq, because we cannot update the ghost variables in general.
+ (I think we could get a lemma looking roughly like what we want, but it would work by reborrowing and thus require later credits, and might also need a proof of liveness depending on how the atomic accessor works.) *)
+ Lemma eqtype_subltype_homo_uniq_strong E L {rt} κ γ r1 r2 (ty1 : type rt) (ty2 : type rt) :
+ eqtype E L r1 r2 ty1 ty2 → subltype E L (Uniq κ γ) (PlaceIn r1) (PlaceIn r2) (◠ty1)%I (◠ty2)%I.
+ Proof.
+ (* even this does not work, because we'd either:
+ - need to update the ghost variable (TODO maybe this works with an atomic accessor)
+ - or need to reborrow the whole thing, which would need a credit, see the comment above
+ *)
+ Abort.
+
+ Lemma type_eq_ltype_incl_uniq {rt} `{!Inhabited rt} κ γ (ty1 : type rt) (ty2 : type rt) :
+ (∀ r, type_incl r r ty1 ty2) -∗ (∀ r, type_incl r r ty2 ty1) -∗ ∀ r, ltype_incl (Uniq κ γ) r r (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros "#Hsub1 #Hsub2" (r).
+ iPoseProof ("Hsub1" $! inhabitant) as "(%Hst & #Hsceq & _)".
+ iSplitR; first done; iModIntro; simpl.
+ simpl. simp_ltypes. rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (Ï€ l) "Hb".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly & Hst & ? & Hsc & Hlb & ? & ? & Hrfn & Hb)".
+ iExists ly. iFrame. rewrite Hst. iFrame.
+ iSplitL "Hsc"; first by iApply "Hsceq".
+
+ iMod "Hb". iModIntro.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hrfn & Hb)". iExists _. iFrame.
+ iMod "Hb". iModIntro.
+ iDestruct "Hb" as "(%v & Hl & Hv)". iExists _. iFrame.
+ iDestruct ("Hsub1" $! r') as "(_ & _ & Hown & _)".
+ by iApply "Hown".
+ * iIntros "(%r' & Hrfn & Hb)". iExists _. iFrame.
+ iMod "Hb". iModIntro.
+ iDestruct "Hb" as "(%v & Hl & Hv)". iExists _. iFrame.
+ iDestruct ("Hsub2" $! r') as "(_ & _ & Hown & _)".
+ by iApply "Hown".
+ Qed.
+ Lemma eqtype_subltype_uniq E L {rt} `{!Inhabited rt} κ γ (ty1 : type rt) (ty2 : type rt) :
+ (∀ r, eqtype E L r r ty1 ty2) → ∀ r, subltype E L (Uniq κ γ) r r (◠ty1)%I (◠ty2)%I.
+ Proof.
+ iIntros (Hsub r qL) "HL #CTX #HE". apply all_eqtype_alt in Hsub as [Hsub1 Hsub2].
+ iPoseProof (Hsub1 with "HL HE") as "#Hsub1".
+ iPoseProof (Hsub2 with "HL HE") as "#Hsub2".
+ iApply (type_eq_ltype_incl_uniq with "Hsub1 Hsub2").
+ Qed.
+
+ Lemma full_eqtype_subltype E L {rt} `{!Inhabited rt} (ty1 : type rt) (ty2 : type rt) :
+ (full_eqtype E L ty1 ty2) → full_subltype E L (◠ty1)%I (◠ty2)%I.
+ Proof.
+ intros Heq. apply full_subltype_alt => b r.
+ destruct b.
+ - eapply subtype_subltype_owned; [done | ].
+ intros. eapply Heq.
+ - eapply subtype_subltype_shared; [done | ].
+ intros. eapply Heq.
+ - eapply eqtype_subltype_uniq; [done | ]. done.
+ Qed.
+
+ Lemma full_eqtype_eqltype E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt):
+ (full_eqtype E L ty1 ty2) → full_eqltype E L (◠ty1)%I (◠ty2)%I.
+ Proof.
+ intros Ha. apply full_subltype_eqltype; apply full_eqtype_subltype; last symmetry; done.
+ Qed.
+
+ Lemma full_eqltype_subltype_l E L {rt} (lt1 lt2 : ltype rt) :
+ full_eqltype E L lt1 lt2 → full_subltype E L lt1 lt2.
+ Proof.
+ iIntros (Heq ?) "HL #CTX #HE". iIntros (??).
+ iDestruct (Heq with "HL CTX HE") as "Ha".
+ iDestruct ("Ha" $! _ _) as "($ & _)".
+ Qed.
+ Lemma full_eqltype_subltype_r E L {rt} (lt1 lt2 : ltype rt) :
+ full_eqltype E L lt1 lt2 → full_subltype E L lt2 lt1.
+ Proof.
+ iIntros (Heq ?) "HL #CTX #HE". iIntros (??).
+ iDestruct (Heq with "HL CTX HE") as "Ha".
+ iDestruct ("Ha" $! _ _) as "(_ & $)".
+ Qed.
+End eqltype.
+
+Section ghost_variables.
+ Context `{typeGS Σ}.
+ Context {T : Type}.
+ Implicit Types (γ : gname) (t : T).
+
+ Definition GRel2 κ (γ1 γ2 : gname) (R : T → T → Prop) : iProp Σ :=
+ [†κ] ={lftE}=∗ Rel2 γ1 γ2 R.
+
+ Lemma GRel2_use_pobs κ γ1 γ2 R v1 :
+ [†κ] -∗ gvar_pobs γ1 v1 -∗ GRel2 κ γ1 γ2 R ={lftE}=∗ ∃ v2, gvar_obs γ2 v2 ∗ ⌜R v1 v2âŒ.
+ Proof.
+ iIntros "Hdead Hobs Hr". iMod ("Hr" with "Hdead") as "Hr".
+ iModIntro. iApply (Rel2_use_pobs with "Hobs Hr").
+ Qed.
+
+ Lemma GRel2_use_obs κ γ1 γ2 R v1 :
+ [†κ] -∗ gvar_obs γ1 v1 -∗ GRel2 κ γ1 γ2 R ={lftE}=∗ ∃ v2, gvar_obs γ2 v2 ∗ gvar_obs γ1 v1 ∗ gvar_auth γ1 v1 ∗ ⌜R v1 v2âŒ.
+ Proof.
+ iIntros "Hdead Hobs Hr". iMod ("Hr" with "Hdead") as "Hr".
+ iModIntro. iApply (Rel2_use_obs with "Hobs Hr").
+ Qed.
+
+ Lemma GRel2_use_trivial κ γ1 γ2 R :
+ [†κ] -∗ GRel2 κ γ1 γ2 R ={lftE}=∗ ∃ v2 : T, gvar_obs γ2 v2.
+ Proof.
+ iIntros "Hdead Hr". iMod ("Hr" with "Hdead") as "Hr".
+ iModIntro. iApply (Rel2_use_trivial with "Hr").
+ Qed.
+End ghost_variables.
+
+Section blocked.
+ Context `{typeGS Σ}.
+
+ Section unblockable.
+ Context {rt rti : Type}.
+
+ (** Implicit unblocking by the lifetime logic, saying that we can go back to the core of an ltype [lt] after [κs] has ended.
+ Crucially, these shifts need to work without assuming anything about liveness of lifetimes and
+ without updating any refinements.
+ Moreover, we rely on later credits here in order to do this without laters by prepaying inheritance viewshifts (in particular to get the congruence lemma for products).
+ *)
+ Definition imp_unblockable (κs : list lft) (lt : ltype rt) : iProp Σ :=
+ â–¡
+ (** Uniq *)
+ ((∀ κ' γ' π r l,
+ lft_dead_list κs -∗
+ (ltype_own lt (Uniq κ' γ') π r l ={lftE}=∗ ltype_own_core lt (Uniq κ' γ') π r l)) ∗
+ (** Owned. *)
+ (∀ π r l wl,
+ lft_dead_list κs -∗ ltype_own lt (Owned wl) π r l ={lftE}=∗ ltype_own_core lt (Owned wl) π r l)
+ (** We don't have a requirement on Shared, as we should not have blocked things below shared ownership anyways. *)
+ ).
+
+ Global Instance imp_unblockable_persistent κ lt : Persistent (imp_unblockable κ lt).
+ Proof. apply _. Qed.
+
+ Lemma imp_unblockable_shorten κs κs' lt :
+ □ (lft_dead_list κs ={lftE}=∗ lft_dead_list κs') -∗
+ imp_unblockable κs' lt -∗ imp_unblockable κs lt.
+ Proof.
+ iIntros "#Hincl #(Ha1 & Ha2) !>".
+ iSplitL.
+ - iIntros (?????) "#Hdead Hb".
+ iMod ("Hincl" with "Hdead") as "Hdead'".
+ iApply ("Ha1" with "Hdead' Hb").
+ - iIntros (????) "Hdead Hb".
+ iMod ("Hincl" with "Hdead") as "Hdead'".
+ iApply ("Ha2" with "Hdead' Hb").
+ Qed.
+
+ Lemma imp_unblockable_shorten' κ κ' lt :
+ κ' ⊑ κ -∗ imp_unblockable [κ'] lt -∗ imp_unblockable [κ] lt.
+ Proof.
+ iIntros "#Hincl". iApply imp_unblockable_shorten.
+ iIntros "!> (Hdead & _)".
+ iMod (lft_incl_dead with "Hincl Hdead") as "Hdead'"; first done.
+ iApply big_sepL_singleton. done.
+ Qed.
+ End unblockable.
+
+ (** Ofty is trivially unblockable *)
+ Lemma ofty_imp_unblockable {rt} (ty : type rt) κs :
+ ⊢ imp_unblockable κs (◠ty).
+ Proof.
+ iModIntro. iSplitR.
+ - iIntros "*". rewrite ltype_own_core_equiv. simp_ltypes. eauto.
+ - iIntros "*". rewrite ltype_own_core_equiv. simp_ltypes. eauto.
+ Qed.
+
+ (** Blocked is unblockable *)
+ Lemma blocked_imp_unblockable {rt} (ty : type rt) κ :
+ ⊢ imp_unblockable [κ] (BlockedLtype ty κ).
+ Proof.
+ iModIntro. iSplitR.
+ - iIntros (κ' γ' π r l) "(#Hdead & _) Hb/=".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite ltype_own_blocked_unfold ltype_own_ofty_unfold.
+ iDestruct "Hb" as "(%ly & %Hst & %Hly & Hsc & Hlb & Hb & Hcred & Hat)".
+ iExists ly. iSplitR; first done. iSplitR; first done. iFrame "Hsc Hlb Hcred Hat".
+ iMod ("Hb" with "Hdead") as "($ & Hb)". iApply "Hb".
+ - iIntros (Ï€ r l wl) "(#Hdead & _)".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite ltype_own_blocked_unfold ltype_own_ofty_unfold.
+ iIntros "(%ly & %Hst & %Hly & Hsc & Hlb & Hinh & Hcred)".
+ iMod ("Hinh" with "Hdead") as "Hv".
+ iDestruct "Hv" as "(%r' & Hrfn & >(%v & Hl & Hv))".
+ iModIntro. iExists ly. iSplitR; first done. iSplitR; first done. iFrame "Hsc Hlb Hcred".
+ iExists r'. iFrame "Hrfn". iModIntro. iExists v. iFrame. done.
+ Qed.
+
+ (** Shr Blocked is unblockable *)
+ Lemma shr_blocked_imp_unblockable {rt} (ty : type rt) κ :
+ ⊢ imp_unblockable [κ] (ShrBlockedLtype ty κ).
+ Proof.
+ iModIntro. iSplitR.
+ - iIntros (κ' γ' π r l) "(#Hdead & _) Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite ltype_own_shrblocked_unfold ltype_own_ofty_unfold.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & %r' & -> & ? & Hshr & Hinh & Hcred & Hat)".
+ iExists ly. iFrame.
+ iMod ("Hinh" with "Hdead") as "$". done.
+ - iIntros (Ï€ r l wl) "(#Hdead & _) Hblocked".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite ltype_own_shrblocked_unfold ltype_own_ofty_unfold.
+ iDestruct "Hblocked" as "(%ly & ? & ? & ? & ? & %r' & -> & Hshr & Hunblock & Hcred)".
+ iMod ("Hunblock" with "Hdead") as "Hl".
+ iDestruct "Hl" as "(%v & Hl & Hv)".
+ iModIntro. iExists ly. iFrame. iExists r'.
+ iSplitR; first done. iNext. eauto with iFrame.
+ Qed.
+
+ Lemma mut_ltype_imp_unblockable {rt} κs κ' (lt : ltype rt) :
+ imp_unblockable κs lt -∗
+ imp_unblockable κs (MutLtype lt κ').
+ Proof.
+ iIntros "#(Hub_mut & Hub_own)". iModIntro. iSplitL.
+ - iIntros (κ0 γ' π r l) "#Hdead Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite !ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame.
+ iMod "Hb". iModIntro. iModIntro.
+ (*rewrite ltype_core_syn_type_eq.*)
+ setoid_rewrite ltype_own_core_core.
+ iApply (pinned_bor_impl with "[] Hb").
+ iNext. iModIntro. iSplit; first last.
+ { setoid_rewrite ltype_own_core_equiv. eauto. }
+ iIntros "(%r' & Hauth & Hb)". iExists _. iFrame "Hauth".
+ iMod "Hb". iDestruct "Hb" as "(%l' & Hl & Hb)".
+ iMod ("Hub_mut" with "Hdead Hb") as "Hb"; first last.
+ { iModIntro. rewrite ltype_own_core_equiv. eauto with iFrame. }
+ - iIntros (Ï€ r l wl) "#Hdead Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite !ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & %γ & %r' & Hrfn & Hb)".
+ iExists ly. iFrame.
+ iModIntro. iExists _, _. iFrame "Hrfn". iNext.
+ iMod "Hb" as "(%l' & Hl & Hb)".
+ iExists _. iFrame. rewrite -ltype_own_core_equiv.
+ iApply ("Hub_mut" with "Hdead Hb").
+ Qed.
+
+ Lemma shr_ltype_imp_unblockable {rt} κs κ' (lt : ltype rt) :
+ imp_unblockable κs lt -∗
+ imp_unblockable κs (ShrLtype lt κ').
+ Proof.
+ iIntros "#(Hub_mut & Hub_own)". iModIntro. iSplitL.
+ - iIntros (κ0 γ' π r l) "#Hdead Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame.
+ iMod "Hb". iModIntro. iModIntro.
+ (*rewrite ltype_core_syn_type_eq.*)
+ (* TODO will require changing the def a bit to actually use the pinned field.
+ setoid_rewrite ltype_own_core_core.
+ iApply (pinned_bor_impl with "[] Hb").
+ iNext. iModIntro. iSplit; first last.
+ { setoid_rewrite ltype_own_core_equiv. eauto. }
+ iIntros "(%r' & Hauth & Hb)". iExists _. iFrame "Hauth".
+ iMod "Hb". iDestruct "Hb" as "(%l' & Hl & Hb)".
+ iMod (lft_incl_dead with "Hincl Hdead") as "Hdead'"; first done.
+ iMod ("Hub_mut" with "Hincl Hdead Hb") as "Hb"; first last.
+ { iModIntro. rewrite ltype_own_core_equiv. eauto with iFrame. }
+ - iIntros (Ï€ r l wl) "#Hdead Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite !ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & %γ & %r' & Hrfn & Hb)".
+ iExists ly. iFrame.
+ iModIntro. iExists _, _. iFrame "Hrfn". iNext.
+ iMod "Hb" as "(%l' & Hl & Hb)".
+ iExists _. iFrame. rewrite -ltype_own_core_equiv.
+ iApply ("Hub_mut" with "[] Hdead Hb").
+ iApply lft_incl_refl.
+ *)
+ Admitted.
+
+ Lemma box_ltype_imp_unblockable {rt} κs (lt : ltype rt) :
+ imp_unblockable κs lt -∗
+ imp_unblockable κs (BoxLtype lt).
+ Proof.
+ iIntros "#(Hub_mut & Hub_own)". iModIntro. iSplitL.
+ - iIntros (κ' γ' π r l) "#Hdead Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite !ltype_own_box_unfold /box_ltype_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame.
+ iMod "Hb". iModIntro. rewrite ltype_core_syn_type_eq.
+ setoid_rewrite ltype_own_core_core.
+ iApply (pinned_bor_impl with "[] Hb").
+ iNext. iModIntro. iSplit; first last.
+ { setoid_rewrite ltype_own_core_equiv. eauto. }
+ iIntros "(%r' & Hauth & Hb)". iExists _. iFrame "Hauth".
+ iMod "Hb". iDestruct "Hb" as "(%l' & %ly' & Hl & ? & ? & Hf & Hb)".
+ iMod ("Hub_own" with "Hdead Hb") as "Hb".
+ iModIntro. rewrite ltype_own_core_equiv. eauto with iFrame.
+ - iIntros (Ï€ r l wl) "#Hdead Hb".
+ rewrite ltype_own_core_equiv /=. simp_ltypes.
+ rewrite !ltype_own_box_unfold /box_ltype_own.
+ iDestruct "Hb" as "(%ly & ? & ? & ? & ? & %r' & Hrfn & Hb)".
+ iExists ly. iFrame.
+ iModIntro. iExists _. iFrame "Hrfn". iNext.
+ iMod "Hb" as "(%l' & %ly' & Hl & ? & ? & ? & Hb)".
+ iExists _, _. iFrame. rewrite ltype_core_syn_type_eq. iFrame.
+ rewrite -ltype_own_core_equiv. iApply "Hub_own"; done.
+ Qed.
+
+ Lemma owned_ptr_ltype_imp_unblockable {rt} κs (lt : ltype rt) ls :
+ imp_unblockable κs lt -∗
+ imp_unblockable κs (OwnedPtrLtype lt ls).
+ Proof.
+ Admitted.
+
+ Lemma struct_ltype_imp_unblockable {rts} κ (lts : hlist ltype rts) sls :
+ ([∗ list] lt ∈ hzipl rts lts, imp_unblockable κ (projT2 lt)) ⊢
+ imp_unblockable κ (StructLtype lts sls).
+ Proof.
+ Admitted.
+
+ Lemma array_ltype_imp_unblockable {rt} κs (def : type rt) len (lts : list (nat * ltype rt)) :
+ ([∗ list] lt ∈ (interpret_iml (◠def) len lts), imp_unblockable κs lt) -∗
+ imp_unblockable κs (ArrayLtype def len lts).
+ Proof.
+ Admitted.
+
+ (* Unblocking is trivial for OpenedLtype, since the core is trivial.
+ However, that also doesn't buy us much, since we will anyways never have OpenedLtype below an intact mutable reference.
+ *)
+ Lemma opened_ltype_imp_unblockable {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost κs :
+ ⊢ imp_unblockable κs (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost).
+ Proof.
+ iModIntro. iSplitL.
+ - iIntros (κ' ????). rewrite ltype_own_core_equiv ltype_core_opened. eauto.
+ - iIntros (????). rewrite ltype_own_core_equiv ltype_core_opened. eauto.
+ Qed.
+
+ Lemma coreable_ltype_imp_unblockable {rt_full} (lt_full : ltype rt_full) κs :
+ ⊢ imp_unblockable κs (CoreableLtype κs lt_full).
+ Proof.
+ iModIntro. iSplitL.
+ - iIntros (κ' γ π r l) "#Hdead Hb".
+ rewrite ltype_own_core_coreable_unfold ltype_own_coreable_unfold /coreable_ltype_own.
+ iDestruct "Hb" as "(%ly & _ & _ & _ & Hrfn & Hvs)".
+ iApply ("Hvs" with "Hdead Hrfn").
+ - iIntros (Ï€ r l wl) "Hdead Ha".
+ rewrite ltype_own_core_coreable_unfold ltype_own_coreable_unfold /coreable_ltype_own.
+ iDestruct "Ha" as "(%ly & _ & _ & _ & Ha)".
+ iApply ("Ha" with "Hdead").
+ Qed.
+
+ Lemma alias_ltype_imp_unblockable rt st l κs :
+ ⊢ imp_unblockable κs (AliasLtype rt st l).
+ Proof.
+ iModIntro. iSplitL.
+ - iIntros (?????). rewrite ltype_own_core_equiv ltype_core_alias. eauto.
+ - iIntros (????). rewrite ltype_own_core_equiv ltype_core_alias. eauto.
+ Qed.
+
+ Lemma shadowed_ltype_imp_unblockable {rt_cur rt_full} (lt_cur : ltype rt_cur) (r_cur : place_rfn rt_cur) (lt_full : ltype rt_full) κs :
+ imp_unblockable κs lt_full -∗ imp_unblockable κs (ShadowedLtype lt_cur r_cur lt_full).
+ Proof.
+ iIntros "#(Ha1 & Ha2)".
+ iModIntro. iSplitL.
+ - iIntros (?????). rewrite ltype_own_core_equiv ltype_own_shadowed_unfold. simp_ltypes.
+ iIntros "Hdead (_ & _ & Hb)".
+ rewrite -ltype_own_core_equiv. iApply ("Ha1" with "Hdead Hb").
+ - iIntros (????). rewrite ltype_own_core_equiv ltype_own_shadowed_unfold. simp_ltypes.
+ iIntros "Hdead (_ & _ & Hb)".
+ rewrite -ltype_own_core_equiv. iApply ("Ha2" with "Hdead Hb").
+ Qed.
+
+ (* TODO: move *)
+ Lemma lft_dead_list_nil :
+ lft_dead_list [] ⊣⊢ True.
+ Proof. done. Qed.
+ Lemma lft_dead_list_cons κ κs :
+ lft_dead_list (κ :: κs) ⊣⊢ [†κ] ∗ lft_dead_list κs.
+ Proof. done. Qed.
+ Lemma lft_dead_list_app κs1 κs2 :
+ lft_dead_list (κs1 ++ κs2) ⊣⊢ lft_dead_list κs1 ∗ lft_dead_list κs2.
+ Proof.
+ induction κs1 as [ | κ κs1 IH]; simpl.
+ { rewrite lft_dead_list_nil left_id. eauto. }
+ rewrite lft_dead_list_cons IH. rewrite bi.sep_assoc //.
+ Qed.
+
+ (** Once all the blocked lifetimes are dead, every ltype is unblockable to its core. *)
+ Lemma imp_unblockable_blocked_dead {rt} (lt : ltype rt) :
+ ⊢ imp_unblockable (ltype_blocked_lfts lt) lt.
+ Proof.
+ (* TODO is there a way to use this dependent induction principle directly with iInduction or induction? *)
+ move: rt lt. eapply ltype_induction.
+ - iIntros (rt ty κ). cbn. iApply blocked_imp_unblockable.
+ - iIntros (rt ty κ). iApply shr_blocked_imp_unblockable.
+ - iIntros (rt ty). iApply ofty_imp_unblockable.
+ - iIntros (rt st l). iApply alias_ltype_imp_unblockable.
+ - iIntros (rt lt IH κ). iApply mut_ltype_imp_unblockable. by iApply IH.
+ - iIntros (rt lt IH κ). iApply shr_ltype_imp_unblockable. by iApply IH.
+ - iIntros (rt lt IH). iApply box_ltype_imp_unblockable. by iApply IH.
+ - iIntros (rt lt ls IH). iApply owned_ptr_ltype_imp_unblockable. by iApply IH.
+ - iIntros (rts lts IH sls).
+ iApply (struct_ltype_imp_unblockable _ lts sls).
+ iApply big_sepL_intro. iModIntro. iIntros (k [rt lt] Hlook).
+ iApply imp_unblockable_shorten; first last.
+ { iApply IH. by eapply elem_of_list_lookup_2. }
+ simpl. clear -Hlook.
+ unfold ltype_blocked_lfts. simpl.
+ iModIntro. rewrite /lft_dead_list.
+ iInduction lts as [ | X Xl lt' lts ] "IH" forall (k Hlook); simpl; first done.
+ destruct k as [ | k]; simpl in Hlook.
+ + injection Hlook as Heq Heq2; subst. apply existT_inj in Heq2 as ->.
+ rewrite big_sepL_app. by iIntros "($ & _)".
+ + iIntros "Ha". iApply "IH"; first done.
+ rewrite big_sepL_app. iDestruct "Ha" as "(_ & $)".
+ - iIntros (rt def len lts IH ).
+ iApply array_ltype_imp_unblockable.
+ iApply big_sepL_intro. iModIntro. iIntros (k lt Hlook).
+ apply lookup_interpret_iml_Some_inv in Hlook as (? & [-> | Hel]).
+ + iApply ofty_imp_unblockable.
+ + iApply imp_unblockable_shorten; first last.
+ { iApply IH. done. }
+ simpl. rewrite /ltype_blocked_lfts /=. iModIntro.
+ iIntros "Hdead". clear -Hel.
+ iInduction lts as [ | lt' lts ] "IH" forall (k Hel).
+ { by apply elem_of_nil in Hel. }
+ apply elem_of_cons in Hel as [<- | Hel].
+ * simpl. rewrite lft_dead_list_app. by iDestruct "Hdead" as "($ & _)".
+ * simpl. rewrite lft_dead_list_app. iDestruct "Hdead" as "(_ & Hdead)".
+ by iApply "IH".
+ - iIntros (rt_cur rt_inner rt_full lt_cur lt_inner ty_full Cpre R Cpost IH1 IH2).
+ iApply opened_ltype_imp_unblockable.
+ - iIntros (rt_full κ' lt_full Hdead). iApply coreable_ltype_imp_unblockable.
+ - iIntros (rt_cur rt_full lt_cur r_cur lt_full _ Hub).
+ iApply shadowed_ltype_imp_unblockable. done.
+ Qed.
+
+ (** We can essentiallly rewrite with [ltype_eq] when proving [imp_unblockable]. *)
+ Lemma ltype_eq_imp_unblockable {rt} κs (lt1 lt2 : ltype rt) :
+ (∀ b r, ltype_eq b r r lt1 lt2) -∗
+ imp_unblockable κs lt1 -∗
+ imp_unblockable κs lt2.
+ Proof.
+ (*iIntros "((% & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2)) (#Hub1 & #Hub2)". *)
+ iIntros "#Heq (#Hub1 & #Hub2)".
+ iSplitL; iModIntro.
+ - iIntros (κ' γ' π r l) "#Hdead Hb".
+ iDestruct ("Heq" $! (Uniq κ' γ') r) as "((% & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2))".
+ iDestruct ("Hub1" with "Hdead") as "#Hub1'".
+ iApply ltype_own_core_equiv. iApply "Hc1". iApply ltype_own_core_equiv.
+ iApply "Hub1'". by iApply "Hi2".
+ - iIntros (Ï€ r l wl) "#Hdead Hb".
+ iDestruct ("Heq" $! (Owned wl) r) as "((% & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2))".
+ iMod ("Hi2" with "Hb") as "Hb".
+ iMod ("Hub2" with "Hdead Hb") as "Hb".
+ rewrite !ltype_own_core_equiv. by iApply "Hc1".
+ Qed.
+ (** A particular instance: when we unfold a type to an ltype, this should always be unblockable. *)
+ Lemma ltype_eq_imp_unblockable_ofty {rt} κs ty (lt : ltype rt) :
+ (∀ b r, ltype_eq b r r (◠ty)%I lt) -∗
+ imp_unblockable κs lt.
+ Proof.
+ iIntros "Heq". iApply (ltype_eq_imp_unblockable with "Heq").
+ iApply ofty_imp_unblockable.
+ Qed.
+
+ Lemma unblock_blocked {rt} E κ π l b (ty : type rt) r :
+ lftE ⊆ E →
+ [†κ] -∗
+ l â—â‚—[Ï€, b] r @ (BlockedLtype ty κ) ={E}=∗ l â—â‚—[Ï€, b] r @ (â— ty)%I.
+ Proof.
+ iIntros (?) "Hdead Hl".
+ iPoseProof (blocked_imp_unblockable ty κ) as "#(Ha1 & Ha2)".
+ destruct b.
+ - iMod (fupd_mask_subseteq lftE) as "Hcl"; first done.
+ iMod ("Ha2" with "[$Hdead //] Hl") as "Hl".
+ rewrite ltype_own_core_equiv. simp_ltypes. iMod "Hcl". simpl. done.
+ - rewrite ltype_own_blocked_unfold /blocked_lty_own.
+ iDestruct "Hl" as "(% & _ & _ & _ & _ & [])".
+ - iPoseProof ("Ha1" with "[$Hdead //] Hl") as "Hl".
+ rewrite ltype_own_core_equiv. simp_ltypes.
+ iApply (fupd_mask_mono with "Hl"). done.
+ Qed.
+ Lemma unblock_shrblocked {rt} E κ π l b (ty : type rt) r :
+ lftE ⊆ E →
+ [†κ] -∗
+ l â—â‚—[Ï€, b] r @ (ShrBlockedLtype ty κ) ={E}=∗ l â—â‚—[Ï€, b] r @ (â— ty)%I.
+ Proof.
+ iIntros (?) "Hdead Hl".
+ iPoseProof (shr_blocked_imp_unblockable ty κ) as "#(Ha1 & Ha2)".
+ destruct b.
+ - iMod (fupd_mask_subseteq lftE) as "Hcl"; first done.
+ iMod ("Ha2" with "[$Hdead //] Hl") as "Hl".
+ rewrite ltype_own_core_equiv. simp_ltypes. iMod "Hcl". simpl. done.
+ - rewrite ltype_own_shrblocked_unfold /shr_blocked_lty_own.
+ iDestruct "Hl" as "(% & _ & _ & _ & _ & % & _ & [])".
+ - iPoseProof ("Ha1" with "[$Hdead //] Hl") as "Hl".
+ rewrite ltype_own_core_equiv. simp_ltypes.
+ iApply (fupd_mask_mono with "Hl"). done.
+ Qed.
+ Lemma unblock_coreable {rt} F π (lt_full : ltype rt) r κs l b :
+ lftE ⊆ F →
+ lft_dead_list κs -∗
+ l â—â‚—[Ï€, b] r @ CoreableLtype κs lt_full ={F}=∗
+ l â—â‚—[Ï€, b] r @ ltype_core lt_full.
+ Proof.
+ iIntros (?) "#Hdead Hl".
+ rewrite ltype_own_coreable_unfold /coreable_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & #Hlb & Hl)".
+ destruct b.
+ - iMod (fupd_mask_mono with "(Hl Hdead)") as "Hb"; first done.
+ rewrite ltype_own_core_equiv. done.
+ - rewrite ltype_own_core_equiv. done.
+ - iDestruct "Hl" as "(Hrfn & Hl)".
+ iMod (fupd_mask_mono with "(Hl Hdead Hrfn)") as "Hb"; first done.
+ rewrite ltype_own_core_equiv. done.
+ Qed.
+End blocked.
diff --git a/theories/rust_typing/maybe_uninit.v b/theories/rust_typing/maybe_uninit.v
new file mode 100644
index 0000000000000000000000000000000000000000..8316eaea60128250dd5c62252dc99d0b16e0366c
--- /dev/null
+++ b/theories/rust_typing/maybe_uninit.v
@@ -0,0 +1,294 @@
+From refinedrust Require Export type ltypes programs .
+ (*program_rules.*)
+(*From refinedrust Require Import ltype_rules.*)
+From refinedrust Require Import uninit.
+From iris Require Import options.
+
+(** * A type modelled after Rust's MaybeUninit *)
+(** We do not represent this directly with a union abstraction for simplicity, but rather directly define what the Rust memory representation of [MaybeUninit] is. *)
+
+Section type.
+ Context `{!typeGS Σ}.
+
+ (** We refine by [option (place_rfn rt)] in order to borrow the optional contents.
+ Note that this really makes it isomorphic to [MaybeUninit<T>] in our model,
+ which is a struct and thus would also get the place wrapper. *)
+ Program Definition maybe_uninit {rt} (T : type rt) : type (option (place_rfn rt)) := {|
+ ty_own_val π r v :=
+ match r with
+ | Some r' => ∃ r'', place_rfn_interp_owned r' r'' ∗ T.(ty_own_val) π r'' v
+ | None => (uninit T.(ty_syn_type)).(ty_own_val) π () v
+ end%I;
+ ty_syn_type := T.(ty_syn_type); (* TODO: but every value is valid! - so in principle, this should be Untyped *)
+ ty_has_op_type ot mt := ∃ ly, syn_type_has_layout T.(ty_syn_type) ly ∧ ot = UntypedOp ly;
+ ty_shr κ π r l :=
+ match r with
+ | Some r' => ∃ r'', place_rfn_interp_shared r' r'' ∗ T.(ty_shr) κ π r'' l
+ | None => (uninit T.(ty_syn_type)).(ty_shr) κ π () l
+ end%I;
+ ty_sidecond := True;
+ ty_ghost_drop π r := True%I; (* TODO ? *)
+ ty_lfts := T.(ty_lfts);
+ ty_wf_E := T.(ty_wf_E);
+ |}.
+ Next Obligation.
+ iIntros (rt T π r v) "Hv". destruct r as [r | ].
+ - iDestruct "Hv" as "(%r'' & Hrfn & Hv)".
+ iApply (ty_has_layout with "Hv").
+ - iApply (ty_has_layout with "Hv").
+ Qed.
+ Next Obligation.
+ simpl; iIntros (rt T ot mt Hot).
+ destruct Hot as (ly & Hot & ->). done.
+ Qed.
+ Next Obligation.
+ iIntros (rt T π r v) "_". done.
+ Qed.
+ Next Obligation.
+ iIntros (rt T κ π l r) "Hl". destruct r as [r | ].
+ - iDestruct "Hl" as "(%r'' & Hrfn & Hl)". iApply (ty_shr_aligned with "Hl").
+ - iApply (ty_shr_aligned with "Hl").
+ Qed.
+ Next Obligation.
+ iIntros (rt T E κ l ly π [r | ] ? ?) "#CTX Htok %Hst %Hly #Hlb Hb".
+ -
+ iAssert (&{κ} (∃ r', place_rfn_interp_owned r r' ∗ ∃ v : val, l ↦ v ∗ v â—áµ¥{Ï€} r' @ T))%I with "[Hb]" as "Hb".
+ { iApply (bor_iff with "[] Hb"). iNext. iModIntro. iSplit.
+ - iIntros "(%v & ? & %r' & ? & ?)". eauto with iFrame.
+ - iIntros "(%r' & ? & %v & ? & ?)". eauto with iFrame. }
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply fupd_logical_step.
+ rewrite -lft_tok_sep. iDestruct "Htok" as "(Htok1 & Htok2)".
+ iMod (bor_exists_tok with "LFT Hb Htok1") as "(%r' & Hb & Htok1)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hrfn & Hb)"; first done.
+ iMod (place_rfn_interp_owned_share with "LFT Hrfn Htok1") as "(Hrfn & Htok1)"; first done.
+ iCombine ("Htok1 Htok2") as "Htok". rewrite lft_tok_sep.
+ iPoseProof (ty_share _ E with "[$LFT $TIME $LLCTX] Htok [//] [//] Hlb Hb") as "Hstep"; first done.
+ iApply (logical_step_wand with "Hstep").
+ iIntros "!> (Hl & $)". eauto with iFrame.
+ - rewrite -lft_tok_sep. iDestruct "Htok" as "[Htok1 Htok2]".
+ (*iAssert (&{κ} (ty_sidecond T ∗ ∃ v : val, l ↦ v ∗ v â—áµ¥{Ï€} .@ uninit (ty_syn_type T)))%I with "[Hb]" as "Hb".*)
+ (*{ iApply (bor_iff with "[] Hb"). iNext. iModIntro. iSplit.*)
+ (*- iIntros "(%v & ? & ? & ?)". eauto with iFrame.*)
+ (*- iIntros "($ & ?)". done. }*)
+ (*iDestruct "CTX" as "(LFT & TIME & LLCTX)".*)
+ (*iApply fupd_logical_step. iMod (bor_sep with "LFT Hb") as "(_ & Hb)"; first done.*)
+ iPoseProof ((uninit _).(ty_share) with "CTX [Htok1] [] [//] [//] Hb") as "Ha"; simpl; first done.
+ { rewrite right_id. done. }
+ { done. }
+ iApply (logical_step_wand with "Ha"). iIntros "($ & Htok1)".
+ rewrite right_id. iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (rt T κ κ' π r l) "#Hincl Ha".
+ destruct r as [r | ]; last by iApply ty_shr_mono.
+ iDestruct "Ha" as "(%r'' & ? & Hv)".
+ iExists _. iFrame. by iApply ty_shr_mono.
+ Qed.
+ Next Obligation.
+ iIntros (rt T π r v F ?) "?". iApply logical_step_intro. done.
+ Qed.
+ Next Obligation.
+ iIntros (rt T ot mt st π r v (ly & Hst & ->)) "Ha".
+ destruct mt; [done | | done].
+ destruct r as [r | ]; simpl; done.
+ Qed.
+End type.
+
+Global Typeclasses Opaque maybe_uninit.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ (** Subtyping *)
+ Lemma type_incl_maybe_uninit_Some {rt} (ty : type rt) (x : rt) :
+ ⊢ type_incl x (Some (#x)) ty (maybe_uninit ty).
+ Proof.
+ iSplitR; first done. iSplitR; first iModIntro. { simpl. eauto. }
+ iSplit; iModIntro.
+ - iIntros (Ï€ v) "Hv". iExists x. eauto with iFrame.
+ - iIntros (κ π l) "Hl". iExists x. eauto with iFrame.
+ Qed.
+
+ Lemma type_incl_Some_maybe_uninit {rt} (ty : type rt) (x : rt) :
+ ty_sidecond ty -∗
+ type_incl (Some (#x)) x (maybe_uninit ty) ty.
+ Proof.
+ iIntros "#Hsc". iSplitR; first done. iSplitR; first iModIntro. { simpl; eauto. }
+ iSplit; iModIntro.
+ - rewrite {1}/ty_own_val/=. iIntros (Ï€ v) "(% & <- & Hv)". done.
+ - rewrite {1}/ty_shr/=. iIntros (κ π v) "(% & <- & Hl)". done.
+ Qed.
+
+ Lemma type_incl_maybe_uninit_None {rt} (ty : type rt) :
+ ⊢ type_incl () None (uninit (ty.(ty_syn_type))) (maybe_uninit ty).
+ Proof.
+ iSplitR; first done. iSplitR; first iModIntro. { simpl. eauto. }
+ iSplit; iModIntro.
+ - iIntros (Ï€ v) "Hv". done.
+ - iIntros (κ π l) "Hl". done.
+ Qed.
+
+ Lemma type_incl_None_maybe_uninit {rt} (ty : type rt) :
+ ⊢ type_incl None () (maybe_uninit ty) (uninit (ty.(ty_syn_type))).
+ Proof.
+ iSplitR; first done. iSplitR; first iModIntro. { simpl. eauto. }
+ iSplit; iModIntro.
+ - iIntros (Ï€ v) "Hv". done.
+ - iIntros (κ π l) "Hl". done.
+ Qed.
+
+End subtype.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ (** subtyping rules: *)
+
+ Lemma weak_subtype_None_maybe_uninit E L {rt} (ty : type rt) (r2 : unit) T :
+ ⌜r2 = tt⌠∗ T ⊢ weak_subtype E L None r2 (maybe_uninit ty) (uninit ty.(ty_syn_type)) T.
+ Proof.
+ iIntros "(-> & HT)" (??) "#CTX #HE HL". iFrame. by iApply type_incl_None_maybe_uninit.
+ Qed.
+ Global Instance weak_subtype_None_maybe_uninit_None_inst E L {rt} (ty : type rt) r2 :
+ Subtype E L None r2 (maybe_uninit ty) (uninit (ty.(ty_syn_type))) := λ T, i2p (weak_subtype_None_maybe_uninit E L ty r2 T).
+
+ Lemma weak_subtype_maybe_uninit_None E L {rt} (ty : type rt) r2 T :
+ ⌜r2 = None⌠∗ T ⊢ weak_subtype E L () r2 (uninit ty.(ty_syn_type)) (maybe_uninit ty) T.
+ Proof.
+ iIntros "(-> & HT)" (??) "#CTX #HE HL". iFrame. by iApply type_incl_maybe_uninit_None.
+ Qed.
+ Global Instance weak_subtype_maybe_uninit_None_inst E L {rt} (ty : type rt) r2 :
+ Subtype E L () r2 (uninit (ty.(ty_syn_type))) (maybe_uninit ty) := λ T, i2p (weak_subtype_maybe_uninit_None E L ty r2 T).
+
+ Lemma weak_subtype_Some_maybe_uninit E L {rt} (ty : type rt) (x : place_rfn rt) r2 T :
+ (∃ x', ⌜x = #x'⌠∗ ⌜r2 = x'⌠∗ ty_sidecond ty ∗ T) ⊢ weak_subtype E L (Some x) r2 (maybe_uninit ty) ty T.
+ Proof.
+ iIntros "(%x' & -> & -> & Hsc & HT)" (??) "#CTX #HE HL". iFrame. by iApply type_incl_Some_maybe_uninit.
+ Qed.
+ Global Instance weak_subtype_Some_maybe_uninit_inst E L {rt} (ty : type rt) (x : place_rfn rt) r2 :
+ Subtype E L (Some x) r2 (maybe_uninit ty) ty := λ T, i2p (weak_subtype_Some_maybe_uninit E L ty x r2 T).
+
+ Lemma weak_subtype_maybe_uninit_Some E L {rt} (ty : type rt) (x : rt) r2 T :
+ ⌜r2 = Some #x⌠∗ T ⊢ weak_subtype E L x r2 ty (maybe_uninit ty) T.
+ Proof.
+ iIntros "(-> & HT)" (??) "#CTX #HE HL". iFrame. iApply type_incl_maybe_uninit_Some.
+ Qed.
+ Global Instance weak_subtype_maybe_uninit_Some_inst E L {rt} (ty : type rt) (x : rt) r2 :
+ Subtype E L x r2 ty (maybe_uninit ty) := λ T, i2p (weak_subtype_maybe_uninit_Some E L ty x r2 T).
+
+ Lemma weak_subltype_maybe_uninit_ghost E L {rt} (ty : type rt) γ r2 T :
+ ⌜r2 = #(Some (👻 γ))⌠∗ T
+ ⊢ weak_subltype E L (Owned false) (👻 γ) r2 (◠ty) (◠(maybe_uninit ty)) T.
+ Proof.
+ iIntros "(-> & HT)".
+ iIntros (??) "#CTX #HE HL". iFrame. iModIntro.
+ iSplitR; first done.
+ iModIntro. simp_ltypes.
+ rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (Ï€ l) "Hl".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Hst & %Hly & Hsc & Hlb & Hcreds & %r' & Hrfn & Hl)".
+ iMod "Hl" as "(%v & Hl & Hv)".
+ iModIntro. iExists ly. iR. iR. iSplitR. { rewrite /maybe_uninit. done. }
+ iFrame. iExists (Some (👻 γ)). iR. iModIntro.
+ iExists v. iFrame. rewrite {2}/ty_own_val/=.
+ eauto with iFrame.
+ Qed.
+ Global Instance weak_subltype_maybe_uninit_ghost_inst E L {rt} (ty : type rt) γ r2 :
+ SubLtype E L (Owned false) (👻 γ) r2 (◠ty)%I (◠(maybe_uninit ty))%I | 40 :=
+ λ T, i2p (weak_subltype_maybe_uninit_ghost E L ty γ r2 T).
+
+ Lemma owned_subtype_uninit_maybe_uninit π E L pers {rt} (ty : type rt) (st : syn_type) T :
+ li_tactic (compute_layout_goal st) (λ ly1,
+ li_tactic (compute_layout_goal (ty_syn_type ty)) (λ ly2,
+ ⌜ly_size ly1 = ly_size ly2⌠∗ T L))
+ ⊢ owned_subtype π E L pers () None (uninit st) (maybe_uninit ty) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly1 & %Halg1 & %ly2 & %Halg2 & %Hsz & HT)".
+ iIntros (???) "#CTX #HE HL". iExists L. iModIntro. iFrame.
+ iApply bi.intuitionistically_intuitionistically_if. iModIntro.
+ iSplit; last iSplitR.
+ { iPureIntro. simpl. intros ly3 ly4 Hst3 Hst4.
+ assert (ly1 = ly3) as <- by by eapply syn_type_has_layout_inj.
+ assert (ly4 = ly2) as <- by by eapply syn_type_has_layout_inj.
+ done. }
+ { simpl. done. }
+ iIntros (v) "Hv". rewrite {2}/ty_own_val/=. rewrite /ty_own_val/=.
+ iDestruct "Hv" as "(%ly & %Hst & %Hly & _)".
+ assert (ly1 = ly) as <- by by eapply syn_type_has_layout_inj.
+ iExists _. iR. iSplit.
+ - iPureIntro. rewrite /has_layout_val -Hsz//.
+ - iPureIntro. eapply Forall_forall; done.
+ Qed.
+ Global Instance owned_subtype_uninit_maybe_uninit_inst π E L pers {rt} (ty : type rt) st :
+ OwnedSubtype π E L pers () None (uninit st) (maybe_uninit ty) :=
+ λ T, i2p (owned_subtype_uninit_maybe_uninit π E L pers ty st T).
+
+ (* reading/writing:
+ does this need special handling?
+
+ We certainly need some handling for read/write rules to inject into maybe_uninit when necessary, esp. below arrays.
+ *)
+ (* TODO: add these rules *)
+
+
+ (** borrowing rules: *)
+ (* for now, just don't allow borrowing maybe_uninit directly and handle it specially.
+ TODO: in future, have an annotation for borrowing that enforces invariants. *)
+ (* TODO: add the override *)
+
+
+
+End rules.
+
+
+
+ (*
+ What happens with borrowing?
+ - if it is Some, I want to create a borrow for the whole thing.
+ To do that, I will probably need a place rule that just makes a maybeuninit into the inner type for the place access, and in the continuation wraps it again.
+ - what happens with the blocked then? I cannot wrap a blocked directly in this type.
+ In principle, this is fine from the perspective of the mutref contract, because the borrow enforces that I actually get a T back, so it is fine to put a Some there.
+ Should I just bubble the blocked up (i.e. use openedltype/coreable)?
+ In principle I know that I will get a maybe_uninit T back after the borrow ends, so this is fine intuitively. The only diff is how the ghost resolution does stuff. (NOTE: here ghost resolution would need to descend below the maybeuninit. But I have the right infrastructure for that, we just need to add a ghost_resolve instance for â— (maybe_uninit T)
+ So I guess the place instance will just work via openedltype.
+ *)
+
+ (*
+ How will the write of an initialized element to a maybeuninit location look?
+ - in principle, if we can write strongly, just write. OpenedLtype closing should later apply the subtyping rule for injection into maybe_uninit.
+
+ - for an array_ltype, subtyping should work elementwise. The openedltype in that case will require to go to an array where every field has the same type. Afterwards, that can be folded to an array_type again.
+
+
+ TODO one thing to think about: we can't do refinement type updates for array_ltype, so we need to do the injection already at time of writing.
+ How should writing work?
+ - have: current type of place (ltype), type of value to write
+ - options for rules we can use:
+ + do a strong write, just put in the current value at its type.
+ + do a strong write, but just put in a value_t for the written value and assemble ownership later on when needed.
+ + directly adapt the type via subtyping so they match
+ - we can also combine the options:
+ + have specific instances (high priority) for particular combinations of types, and use one of the other options as default if they don't match.
+ -> already doing that currently for writing to a mutltype etc.
+ -> for maybe_uninit: have two specific instances for writing to it.
+ + and then, as a fallback: just do a strong write (or decide based on the type change).
+
+ *)
+
+ (* Issue for borrowing:
+ if we borrow a maybe_uninit T but really need a T, we need to know that and commit to it ahead of time (when borrowing) because of restricted subtyping.
+ Solutions:
+ - actually do a reborrow when subtyping, since the refinement gives us enough information
+ then there's a lot of stuff happening there. it also needs later credits. so this gets quite fragile.
+ - can we do the previous thing without reborrowing? could this ability be directly built into mut refs?
+ in principle, stuff like this that is enabled by the refinements should be more natural.
+ Point is: our refinement model is too inflexible. we need more leverage to say that the other case (None) is vacuous because of refinement info.
+ - this is not quite true, because the lender will still expect the maybe_uninit back, not the full thing.
+ in a sense, this case is really similar to the [u8; 2] ≈ u16 case. It's basically equivalent according to the intuitive notion of subtyping (taking into account the refinement) but it doesn't hold in our model.
+ - have custom rules and just say that we generally borrow the T instead of the maybe_uninit when the refinement says so.
+ this makes it a bit less flexible, but it's probably fine. the annoying part is that we have to duplicate the borrowing logic a bit.
+ => TODO which of these makes most sense?
+ *)
diff --git a/theories/rust_typing/memcasts.v b/theories/rust_typing/memcasts.v
new file mode 100644
index 0000000000000000000000000000000000000000..3718f54433d87f63723f47203163977cda1873a7
--- /dev/null
+++ b/theories/rust_typing/memcasts.v
@@ -0,0 +1,316 @@
+From refinedrust Require Import base.
+
+(** ** op_types and mem_casts *)
+
+(** [memcast_compat_type] describes how a type can transfered via a
+mem_cast (see also [ty_memcast_compat] below):
+- MCNone: The type cannot be transferred across a mem_cast.
+- MCCopy: The value type can be transferred to a mem_casted value.
+- MCId: mem_cast on a value of this type is the identity.
+
+MCId implies the other two and MCCopy implies MCNone.
+ *)
+Inductive memcast_compat_type : Set :=
+| MCNone | MCCopy | MCId.
+
+Definition is_int_ot (ot : op_type) (it : int_type) : Prop :=
+ match ot with
+ | IntOp it' => it = it' ∧ (ly_size it ≤ max_int isize_t)%Z
+ | UntypedOp ly => ly = it_layout it ∧ (ly_size it ≤ max_int isize_t)%Z
+ | _ => False
+ end.
+(* TODO: ideally, BoolOp should also garble up all the other bits of the read value, as Rust will use the 7 excess bits of bool for niche optimizations *)
+Definition is_bool_ot (ot : op_type) : Prop :=
+ match ot with | BoolOp => True | UntypedOp ly => ly = it_layout u8 | _ => False end.
+Definition is_ptr_ot (ot : op_type) : Prop :=
+ match ot with | PtrOp => True | UntypedOp ly => ly = void* | _ => False end.
+Definition is_unit_ot (ot : op_type) : Prop :=
+ match ot with | StructOp sl ots => sl = unit_sl ∧ ots = [] | UntypedOp ly => ly = unit_sl | _ => False end.
+
+Lemma is_int_ot_layout it ot:
+ is_int_ot ot it → ot_layout ot = it_layout it.
+Proof.
+ destruct ot => //=; naive_solver.
+Qed.
+Lemma is_int_ot_size ot it :
+ is_int_ot ot it → (ly_size it ≤ max_int isize_t)%Z.
+Proof.
+ destruct ot; try done; intros []; done.
+Qed.
+
+Lemma is_bool_ot_layout ot :
+ is_bool_ot ot → ot_layout ot = it_layout u8.
+Proof. destruct ot => //. Qed.
+
+Lemma is_ptr_ot_layout ot:
+ is_ptr_ot ot → ot_layout ot = void*.
+Proof. by destruct ot => //= ->. Qed.
+
+Lemma is_unit_ot_layout ot :
+ is_unit_ot ot → ot_layout ot = unit_sl.
+Proof.
+ destruct ot => //=. by intros [-> ->].
+Qed.
+
+Section optypes.
+ Context `{refinedcG Σ}.
+ Lemma mem_cast_compat_id (P : val → iProp Σ) v ot st mt:
+ (P v ⊢ ⌜mem_cast_id v otâŒ) →
+ (P v ⊢ match mt with | MCNone => True | MCCopy => P (mem_cast v ot st) | MCId => ⌜mem_cast_id v ot⌠end).
+ Proof. iIntros (HP) "HP". iDestruct (HP with "HP") as %Hm. rewrite Hm. by destruct mt. Qed.
+
+ Lemma mem_cast_compat_Untyped (P : val → iProp Σ) v ot st mt:
+ ((if ot is UntypedOp _ then False else True) → ⊢ P v -∗ match mt with | MCNone => True | MCCopy => P (mem_cast v ot st) | MCId => ⌜mem_cast_id v ot⌠end) →
+ ⊢ P v -∗ match mt with | MCNone => True | MCCopy => P (mem_cast v ot st) | MCId => ⌜mem_cast_id v ot⌠end.
+ Proof. move => Hot. destruct ot; try by apply: Hot. apply bi.entails_wand'. apply: mem_cast_compat_id. by iIntros "?". Qed.
+
+ Lemma mem_cast_compat_int (P : val → iProp Σ) v ot it:
+ is_int_ot ot it →
+ (P v ⊢ ⌜∃ z, val_to_Z v it = Some zâŒ) →
+ (P v ⊢ ⌜mem_cast_id v otâŒ).
+ Proof.
+ destruct ot => //; simplify_eq/=.
+ - intros [<- ?]. etrans; [done|]. iPureIntro => -[??]. by apply: mem_cast_id_int.
+ - intros [-> ?]. etrans; [done|]. iPureIntro => -[??]. simpl. done.
+ Qed.
+
+ Lemma mem_cast_compat_bool (P : val → iProp Σ) v ot :
+ is_bool_ot ot →
+ (P v ⊢ ⌜∃ b, val_to_bool v = Some bâŒ) →
+ (P v ⊢ ⌜mem_cast_id v otâŒ).
+ Proof.
+ destruct ot => //; simplify_eq/=.
+ - intros _. etrans; [done|]. iPureIntro => -[??]. by apply: mem_cast_id_bool.
+ - intros ->. etrans; [done|]. iPureIntro => -[??]. simpl. done.
+ Qed.
+
+ Lemma mem_cast_compat_loc (P : val → iProp Σ) v ot :
+ is_ptr_ot ot →
+ (P v ⊢ ⌜∃ l, v = val_of_loc lâŒ) →
+ (P v ⊢ ⌜mem_cast_id v otâŒ).
+ Proof.
+ destruct ot => //; simplify_eq/=.
+ - intros _. etrans; [done|]. iPureIntro => -[? ->]. by apply: mem_cast_id_loc.
+ - intros ->. etrans; [done|]. iPureIntro => -[? ->]. done.
+ Qed.
+
+ Lemma mem_cast_compat_unit (P : val → iProp Σ) v ot :
+ is_unit_ot ot →
+ (P v ⊢ ⌜v = zst_valâŒ) →
+ (P v ⊢ ⌜mem_cast_id v otâŒ).
+ Proof.
+ destruct ot => //; simplify_eq/=.
+ - intros [-> ->]. etrans; first done. iIntros "->" => //.
+ - intros ->. etrans; first done. iIntros "->" => //.
+ Qed.
+End optypes.
+
+Lemma mem_cast_idemp v ot st st' :
+ mem_cast (mem_cast v ot st) ot st' = mem_cast v ot st.
+Proof.
+ (* TODO need stronger induction principle for the struct case *)
+ induction ot; simpl.
+ - rewrite /mem_cast.
+ destruct (val_to_bool v) as [b | ] eqn:Heq.
+ + rewrite (val_to_bytes_id_bool _ b); last done. simpl.
+ rewrite Heq. simpl. rewrite (val_to_bytes_id_bool _ b); done.
+ + simpl. destruct v; simpl; first done. rewrite replicate_length. done.
+ - rewrite /mem_cast.
+ destruct (val_to_bytes v) as [v' | ] eqn:Heq; simpl.
+ + erewrite val_to_bytes_idemp; done.
+ + rewrite replicate_length.
+ generalize (length v). intros []; done.
+ - rewrite /mem_cast.
+ destruct (val_to_loc v) as [l | ] eqn:Heq; simpl.
+ { rewrite Heq. done. }
+ destruct (val_to_bytes v) as [v' | ] eqn:Heq'; simpl.
+ + destruct (val_to_Z v' usize_t) as [ z | ] eqn:Heq2; simpl.
+ * case_bool_decide; first by rewrite val_to_of_loc //.
+ case_bool_decide; first by rewrite val_to_of_loc //.
+ case_bool_decide; by rewrite val_to_of_loc //.
+ * destruct v; simpl; first done.
+ rewrite replicate_length. done.
+ + destruct v; simpl; first done.
+ rewrite replicate_length //.
+ - rewrite /mem_cast. fold mem_cast.
+ simpl.
+ rewrite resize_length.
+ f_equiv. f_equiv.
+ generalize (sl_members sl) => f.
+ clear sl.
+ induction f as [ | [name ly] f IH]; simpl; first done.
+ (*destruct name; simpl.*)
+ admit.
+ - done.
+Admitted.
+
+Definition is_memcast_val (v : val) (ot : op_type) (v' : val) : Prop :=
+ v' = v ∨ ∃ st, v' = mem_cast v ot st.
+
+Lemma is_memcast_val_memcast v ot v' st :
+ is_memcast_val v ot v' →
+ is_memcast_val v ot (mem_cast v' ot st).
+Proof.
+ intros [-> | [st' ->]].
+ - right. eauto.
+ - right. exists st'. rewrite mem_cast_idemp. done.
+Qed.
+
+Lemma is_memcast_val_untyped_inv v v' ly :
+ is_memcast_val v (UntypedOp ly) v' → v = v'.
+Proof.
+ intros [-> | (st & ->)]; done.
+Qed.
+
+Lemma has_layout_val_mem_cast v ly ot st :
+ v `has_layout_val` ly →
+ mem_cast v ot st `has_layout_val` ly.
+Proof.
+ rewrite /has_layout_val mem_cast_length //.
+Qed.
+
+
+(* Q:
+ does the syntactical type alone determine the memcast_compat_type?
+
+ In principle, I might imagine that some type uses a syntactic struct type just to have some space, and all ops on it just treat it as a raw byte sequence (UntypedOp). In that case, I should be able to say that the type is MCNone: if I interpret it as a struct where the padding bytes are poison, something will go wrong.
+ On the other hand, has_op_type should always be defined for UntypedOp, at least for MCId (because mem_casts are always identity for UntypedOp). But: because a syn_type does not only have UntypedOp, this does not tell us that that is so for all ots valid for it.
+ => In the semantic type interpretation, I should be able to influence how it is memcastable, because that is a semantic property.
+ But the syntactic type can determine which op_type it has.
+
+ TODO there might be some interdependency now, in the case of structs, of the syn_type_has_op_type on the mt that is actually allowed by the sematnic type?
+ or rather, checking the mt part in case of structs will require a similar recursion as getting the op for a synty. So maybe there is a smart setup for combining it?
+ - well, actually. the op_type thiong goes very deep.
+ but in the semantic interpretation, we just need to put on top: that the component types match , and that the components are similarly memcasteable [this puts an indirection on the recursion, so we are not really recursive the same way as for the syn_types}
+
+
+ *)
+
+(*
+ - ot is fully determined by the synty
+ - mt is determined by the semty
+ - for the memcast_compat property of semtys, require
+ syn_type_has_op_type ty_syn_ty ot →
+ ty_has_memcast_type mt →
+ ty_own_val v -∗
+ match mt with
+ | MCNone => True
+ | MCCopy => ty_own_val (mem_cast v ot st)
+ | MCId => ⌜mem_cast_id v otâŒ
+ end
+
+ for structs: how to define ty_has_memcast_type?
+ => well, this depends on the optype with which we access!
+ - in general, the components need to have the same memcast_type
+ - For StructOp, it can't be id in general, because of padding.
+ For UntypedOp, we don't care further.
+
+ so instead:
+ define ty_has_op_type ot mt => this is quite similar to RefinedC
+ - usually, this will be defined in terms of synty
+ and require: ty_has_op_type ot mt → syn_type_has_op_type ty_syn_type ot
+ - Do we need this property for anything specific?
+ Probably no. But conceptually, the optype should just be fully determined by that.
+
+
+ => For now, just settle with defining that in terms of semantic types.
+ This doesn't quite seem right from a conceptual perspective, because the op_type should already be determined by the syntactic type, but it makes the setup easier.
+ *)
+
+(*
+
+(* The op_type of a semantic type should solely depend on its syntactic type and the layout algorithm *)
+Fixpoint syn_type_has_op_type `{!LayoutAlg} (synty : syn_type) (ot : op_type) (mt : memcast_compat_type) {struct synty} : Prop :=
+ match synty with
+ | IntSynType it =>
+ is_int_ot ot it
+ | BoolSynType => is_bool_ot ot
+ | PtrSynType => is_ptr_ot ot
+ | FnPtrSynType => is_ptr_ot ot
+ | StructSynType sn fields =>
+ (* this should match the definition of is_struct_ot *)
+ match ot with
+ | StructOp sl ots =>
+ (* must agree with what the layout alg specifies *)
+ use_struct_layout_alg (mk_sls sn fields) = Some sl ∧
+ (* check that all the ots are compatible with the field's types *)
+ length ots = length fields ∧
+ (* TODO the termination checker is not happy about this. possibly because of zip *)
+ (*foldr (λ '((_, fty), fot) acc, and (syn_type_has_op_type fty fot) acc) True (zip fields ots)*)
+ True
+ (* TODO untypedop *)
+ | _ => False
+ end
+ end.
+
+Lemma syn_type_has_op_type_layout_stable `{!LayoutAlg} synty ot ly :
+ syn_type_has_op_type synty ot →
+ syn_type_has_layout synty ly →
+ ot_layout ot = ly.
+Proof.
+ (* this is a property that should definitely hold. *)
+Admitted.
+
+(* options for getting the def through
+ - use equations (boo)
+ - try a custom fused-foldr-zip (foldr2?). problem: I may need a third list to relate to sl.(sl_fields).
+ - don't define this via syn_types, but on types (so that we get it via indirection)
+*)
+
+(*Definition is_struct_ot *)
+
+(* TODO *)
+ *)
+
+(*
+Definition is_struct_ot (sl : struct_layout) (tys : list syn_type) (ot : op_type) :=
+ length (field_names sl.(sl_members)) = length tys ∧
+ match ot with
+ | StructOp sl' ots => sl' = sl ∧ mt ≠MCId ∧ length ots = length tys ∧
+ foldr (λ x, and (x.1.1.(ty_has_op_type) x.2 mt ∧ ot_layout x.2 = x.1.2.2))
+ True (zip (zip tys (field_members sl.(sl_members)) ) ots)
+ | UntypedOp ly => ly = sl ∧
+ foldr (λ x, and (x.1.(ty_has_op_type) (UntypedOp x.2.2) mt))
+ True (zip tys (field_members sl.(sl_members)) )
+ | _ => False
+ end.
+
+Lemma is_struct_ot_layout sl tys ot mt:
+ is_struct_ot sl tys ot mt → ot_layout ot = sl.
+Proof. move => [?]. destruct ot => //; naive_solver. Qed.
+ *)
+
+
+
+
+(* field accesses refer to the layout we quantify over to get the offset -- this is anyways already the case in Caesium
+
+
+ - in the interpretation of types, we should be able to directly reason about the symbolic offset of a field, for the concrete (existentially quantified) layout that the alg gave us.
+ -> how does this nest?
+ interp [box inner] v :=
+ ∃ l ly,
+ use_layout_alg inner.lys = Some ly ∗
+ v = val_of_loc l ∗ l `loc_has_layout` ly ∗
+ ∃ w, l ↦ w ∗ inner.own w
+
+ interp (struct sls) v :=
+ ∃ sl,
+ use_struct_layout_alg sls = Some sl ∗
+ v `has_layout_val` sl ∗
+ [∗ list] field ∈ sl.fields, ...
+
+
+ types have:
+ - syn_type
+ require:
+ - ty.own v -∗ ∃ ly, use_layout_alg ty.(syn_type) = Some ly ∗ v `has_layout_val` ly
+ - has_op_type: can be directly defined in terms of the syn_type
+ -
+ for the resulting concrete thing, require compatibility with layouts and memcasts similarly to currently.
+ essentially, it is just deferred/ behind the ALG abstraction.
+ *)
+
+(*
+ Maybe we should also, similarly, treat usize/isize and other implementation-defined things like endianness, pointer size?
+ *)
diff --git a/theories/rust_typing/own.v b/theories/rust_typing/own.v
new file mode 100644
index 0000000000000000000000000000000000000000..3e2ac7d7dda1ebddd8975ec79bb4cf77196a93d1
--- /dev/null
+++ b/theories/rust_typing/own.v
@@ -0,0 +1,252 @@
+(* TODO: something breaks with the lft logic notations as soon as we import this *)
+(*From refinedc.lang Require Import rust.*)
+From refinedrust Require Export type references.
+
+(**
+NOTE: we should never borrow an [own] mutably. That breaks refinement.
+ Instead, should unfold to a [box] before.
+
+ Assuming inner : rtype
+
+ [r @ box inner] unfold to [∃ l. l @ own (r @ inner)]
+ [l @ own (r @ inner)] folds to [r @ box inner]
+
+
+ in terms of ltype:
+ ltype_eq (own_ltype (â— rty)) (â— own (ty_of_rty rty))
+ ltype_eq (box_ltype (â— rty)) (â— box rty)
+
+ we cannot formulate the correspondence between box and own in terms of ltype_eq,
+ because the refinements are different.
+
+ So what is the right way of formulating this?
+
+
+ For now, this question isn't so important: we are interested in own mainly for unsafe code¸
+ where we might need to deal with strong updates (uninit etc)
+ Well, we also need that for box. Moving out is allowed for boxes. just changing the refinement type is not.
+ So have some dummy inner type that takes any refinement if we move things out.
+
+
+
+ -------------------------------------
+
+
+ What is the correct notion of owned ptrs?
+ 1. Separate from that: need box, which also carries the permission to deallocate and is refined by just the inner refinement
+ 2. For owning stack values, we have (by default) the Owned ltype variant.
+
+ What do we need owned pointers for beyond that? (in a safe Rust program)
+ - in lambda rust: need some notion that we get when we split a Box into two Boxes.
+ BUT: that is only required due to splitting. We just don't need the same notion of owned ptr, at least for the safe fragment. (for the unsafe part, we will need something similar).
+ - ??
+
+ result: we don't need them for specifications in principle
+
+ It could still be useful to have them as "administrative" types for the typing rules to streamline the notions of ltypes and rtypes.
+ Instead of working with owned ltypes in the typing rules to reason about stack locations, we could have a owned ptr type.
+ + subsumption rules that allow us to convert to the ltype under the right conditions.
+
+
+ Guiding principle in the design of that: it should also work when, e.g., operating under a mutable reference:
+ - assume we have l â—[Owned] &mut (t2rt (uninit P ly)).
+ We do *l +â‚— n, this unfolds to ?.
+ Rather &mut ( *l +â‚— n)?
+
+ -> we just borrow some part of the sep. conj. and leave the rest there, effectively.
+ We can still access one part of that, if we want.
+ (not permitted in safe Rust but the semantic model allows that of course)
+
+ But: how would the typing rule for that look formally?
+
+ -> but point: it should not be the case that a single binop application can do a reborrow. both on the MIR side and the Caesium side. we should need an explicit reborrow of the offset address, and that should do the whole thing.
+ for the binop application itself, we should be able to assume full ownership of the location of the mut ref., since we are currently in the process of opening the borrow.
+ then, we should get the new ownership and the remaining ownership. the remaining ownership stays in the mutable borrow, but the new ownership that is passed to the continuation should be subject to reborrowing. (that should be stated in the continuation).
+
+
+ Plan for owned pointers:
+ - we have the box type, well, for Rust boxes.
+ - we have the own_ptr type for an owned location, refined by the location.
+ rvalue ownership of this unfolds to Owned ltype ownership of the nested type.
+
+ *)
+
+
+
+ (*
+Section own_ptr.
+ Context `{typeGS Σ}.
+
+ (** Owned ptrs are very similar to RefinedC's owned pointers:
+ they do not reflect the refinement of the inner type to the outside in order to allow
+ for strong updates to the inner types' refinement.
+ Instead, they are refined by locations.
+ *)
+
+ Program Definition own_ptr_type (ty : type) (l' : loc) : type := {|
+ ty_own_val tid v := (⌜v = l'⌠∗ ⌜l' `has_layout_loc` ty.(ty_layout)⌠∗ ▷ (l' ↦: (ty.(ty_own_val) tid)))%I;
+ ty_layout := void*;
+ ty_shr κ tid l :=
+ (&frac{κ}(λ q', l ↦{q'} l') ∗
+ □ (∀ F q, ⌜↑shrN ∪ ↑lftN ⊆ F⌠-∗ q.[κ] ={F}[F∖↑shrN]▷=∗
+ ty.(ty_shr) κ tid l' ∗ q.[κ]))%I;
+ ty_drop := ty.(ty_drop);
+ ty_depth := 1 + ty.(ty_depth);
+ |}.
+ Next Obligation.
+ iIntros (? l' ? v) "(-> & %Hly & Hown)".
+ iPureIntro. done.
+ Qed.
+ Next Obligation.
+ iIntros (ty l' E κ l tid q ?) "#LFT %Hly Hb Htok".
+ iMod (bor_exists with "LFT Hb") as "(%v & Hb)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "[Hl Hb]"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "[Heq Hb]"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "[Hly Hb]"; first solve_ndisj.
+
+ iMod (bor_persistent with "LFT Heq Htok") as "[>-> Htok]"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hly Htok") as "[>%Hly' Htok]"; first solve_ndisj.
+
+ iFrame.
+ iMod (bor_fracture (λ q, l ↦{q} l')%I with "LFT Hl") as "$"; first solve_ndisj.
+ rewrite bor_unfold_idx.
+ iDestruct "Hb" as (i) "(#Hpb&Hpbown)".
+ iMod (inv_alloc shrN _ (idx_bor_own 1 i ∨ ty_shr ty κ tid l')%I
+ with "[Hpbown]") as "#Hinv"; first by eauto.
+ iIntros "!> !> * % Htok".
+ iMod (inv_acc with "Hinv") as "[INV Hclose]"; first solve_ndisj.
+ iDestruct "INV" as "[>Hbtok|#Hshr]".
+ - iMod (bor_later_tok with "LFT [Hbtok] Htok") as "Hdelay"; first solve_ndisj.
+ { rewrite bor_unfold_idx. eauto. }
+ iModIntro. iNext. iMod "Hdelay" as "[Hb Htok]".
+ iMod (ty.(ty_share) with "LFT [//] Hb Htok") as "[#$ $]"; first solve_ndisj.
+ iApply "Hclose". auto.
+ - iMod fupd_mask_subseteq as "Hclose'"; first solve_ndisj. iModIntro.
+ iNext. iMod "Hclose'" as "_". iMod ("Hclose" with "[]") as "_"; by eauto.
+ Qed.
+ Next Obligation.
+ iIntros (ty l' ?? tid l) "#Hincl (Hfrac & #Hvs)".
+ iSplit; first by iApply (frac_bor_shorten with "[]"). iIntros "!> *% Htok".
+ iApply (step_fupd_mask_mono F _ (F∖↑shrN)); [solve_ndisj..|].
+ iMod (lft_incl_acc with "Hincl Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
+ iMod ("Hvs" with "[%] Htok") as "Hvs'"; first solve_ndisj. iModIntro. iNext.
+ iMod "Hvs'" as "[Hshr Htok]". iMod ("Hclose" with "Htok") as "$".
+ by iApply (ty.(ty_shr_mono) with "Hincl").
+ Qed.
+ Next Obligation.
+ iIntros (????) "(_ & ? & H)".
+ simpl. iModIntro. iNext. iDestruct "H" as "(%v' & ? & Hinner)".
+ iModIntro. iApply (ty.(ty_own_drop) with "Hinner").
+ Qed.
+
+ Program Definition own_ptr (ty : type) : rtype := {|
+ rty_type := loc;
+ rty := own_ptr_type ty;
+ rty_layout := void*;
+ rty_depth := 1 + ty.(ty_depth);
+ |}.
+ Next Obligation. done. Qed.
+ Next Obligation. done. Qed.
+
+ Global Instance own_ptr_wf `{!TyWf ty} : RTyWf (own_ptr ty) :=
+ λ r, {| ty_lfts := ty.(ty_lfts); ty_wf_E := ty.(ty_wf_E) |}.
+End own_ptr.
+
+Section own_lty.
+ Context `{typeGS Σ} (inner_rty : Type) (inner : ltype inner_rty)
+ (inner_core : ltype inner_rty)
+ `{ghost_varG Σ loc}.
+ Implicit Types (κ : lft) (γ : gname) (k : bor_kind).
+
+ (* Even though owned pointers itself allow strong updates just fine,
+ since we might nest mutable references on the outside, we still need to have
+ a "core" inner type.
+ *)
+ Program Definition own_ltype : ltype loc := {|
+ ltype_own k π l' l :=
+ match k with
+ | Owned =>
+ ⌜l `has_layout_loc` void*⌠∗ ⌜l = l'⌠∗
+ ∃ (l' : loc) r, l ↦ l' ∗ ▷ inner.(ltype_own) Owned π r l'
+ | Uniq κ' γ => ⌜l `has_layout_loc` ref_layout⌠∗ ⌜l = l'⌠∗
+ gvar_obs γ l ∗
+ &pin{κ'}
+ [∃ (l' : loc) (r : loc) r',
+ gvar_auth γ r ∗ l ↦ l' ∗
+ inner_core.(ltype_own) Owned π r' l']
+ (∃ (l' : loc) (r : loc) r',
+ gvar_auth γ r ∗ l ↦ l' ∗
+ inner.(ltype_own) Owned π r' l')
+ | Shared κ =>
+ (* TODO: have layout requirements ? *)
+ (*⌜l `has_layout_loc` ref_layout⌠∗*)
+ ⌜l = l'⌠∗
+ (∃ (li : loc) r, &frac{κ}(λ q', l ↦{q'} li) ∗
+ □ ∀ F q, ⌜↑shrN ∪ ↑lftN ⊆ F⌠-∗ q.[κ] ={F}[F∖↑shrN]▷=∗
+ inner.(ltype_own) (Shared κ) π r li ∗ q.[κ])%I
+ end%I;
+ ltype_depth := 1 + inner.(ltype_depth);
+ |}.
+ Next Obligation.
+ intros κ κ' π l' l. iIntros "#Hincl".
+ iIntros "(<- & (%li & %r & Hf & #Hb))".
+ iSplitR; first done.
+ iExists li, r.
+ iSplit; first by iApply (frac_bor_shorten with "[]").
+ iIntros "!> * % Htok".
+ iMod (lft_incl_acc with "Hincl Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
+ iMod ("Hb" with "[%] Htok") as "Hvs"; first solve_ndisj. iModIntro. iNext.
+ iMod "Hvs" as "[Hshr Htok]". iMod ("Hclose" with "Htok") as "$".
+ iModIntro. by iApply (ltype_shr_mono with "Hincl").
+ Qed.
+End own_lty.
+
+Section ltype_agree.
+ Context `{typeGS Σ}
+ (rt : rtype)
+ `{ghost_varG Σ rt.(rty_type)}
+ `{ghost_varG Σ loc}.
+
+ (* TODO *)
+ (*
+ Lemma own_unfold κ :
+ ⊢ ltype_eq _ (own_ltype _ (◠rt) (◠rt)) (◠(own_ptr ty)).
+ Proof.
+ iIntros "!#" (k π [r γ] l); iSplit; simpl.
+ - destruct k; simpl.
+ + iIntros ">[%Hly (%l' & Hl & %Hly' & Hobs & Hbor)]".
+ iSplitR; first done. iModIntro. eauto with iFrame.
+ + iIntros ">(%li & Hb & Hdel)". eauto with iFrame.
+ + iIntros ">(%Hly & Hobs & Hb)".
+ iSplitR; first done. iFrame "Hobs".
+ iMod (pinned_bor_fold with "Hb") as "Hb".
+ iApply (bor_iff with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%l' & %r' & Hauth & Hl & %Hly'' & Hobs & Hbor)".
+ iExists r'. iFrame. destruct r' as [r' γ''].
+ eauto with iFrame.
+ * iIntros "(%p & Hauth & (%v & Hl & Hv))".
+ destruct p as [r' γ''].
+ iDestruct "Hv" as "(%l' & -> & %Hly' & Hobs & Hbor)".
+ eauto with iFrame.
+ - destruct k; simpl.
+ + iIntros ">[%Hly (%v & Hl & %l' & -> & %Hly' & Hobs & Hbor)]".
+ iSplitR; first done. eauto with iFrame.
+ + iIntros ">(%li & Hb & Hdel)". eauto with iFrame.
+ + iIntros ">(%Hly & Hobs & Hb)".
+ iSplitR; first done. iFrame "Hobs".
+ iApply pinned_bor_unfold.
+ iApply (bor_iff with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%p & Hauth & (%v & Hl & Hv))".
+ destruct p as [r' γ''].
+ iDestruct "Hv" as "(%l' & -> & %Hly' & Hobs & Hbor)".
+ eauto with iFrame.
+ * iIntros "(%l' & %r' & Hauth & Hl & %Hly'' & Hobs & Hbor)".
+ iExists r'. iFrame. destruct r' as [r' γ''].
+ eauto with iFrame.
+ Qed.
+ *)
+End ltype_agree.
+
+ *)
diff --git a/theories/rust_typing/owned_ptr.v b/theories/rust_typing/owned_ptr.v
new file mode 100644
index 0000000000000000000000000000000000000000..eb37c0e8ac746dba6c20d903bd43d271e3bce3ed
--- /dev/null
+++ b/theories/rust_typing/owned_ptr.v
@@ -0,0 +1,164 @@
+From refinedrust Require Export base type.
+From refinedrust Require Import programs uninit ltypes.
+From caesium Require Import derived.
+
+Section owned_ptr.
+ Context `{typeGS Σ} {rt}
+ (*`{Inhabited rt} *)
+ (inner : type rt).
+
+ Program Definition owned_ptr : type (place_rfn rt * loc) := {|
+ ty_sidecond := True;
+ ty_own_val π '(r, l) v :=
+ ∃ (ly : layout), ⌜v = l⌠∗ ⌜syn_type_has_layout inner.(ty_syn_type) ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ inner.(ty_sidecond) ∗
+ £ num_cred ∗ atime 1 ∗
+ ∃ (ri : rt), place_rfn_interp_owned r ri ∗
+ (* this needs to match up with the corresponding later/fupd in the OfTyLtype to get the unfolding equation *)
+ ▷ |={lftE}=> ∃ v' : val, l ↦ v' ∗ inner.(ty_own_val) π ri v';
+ ty_has_op_type ot mt := is_ptr_ot ot;
+ ty_syn_type := PtrSynType;
+
+ ty_shr κ tid '(r, li) l :=
+ (∃ (ly : layout) (ri : rt), place_rfn_interp_shared r ri ∗
+ ⌜l `has_layout_loc` void*⌠∗
+ ⌜use_layout_alg inner.(ty_syn_type) = Some ly⌠∗
+ ⌜li `has_layout_loc` ly⌠∗
+ inner.(ty_sidecond) ∗
+ loc_in_bounds l 0 void*.(ly_size) ∗
+ (* also need this for the inner location to get the right unfolding equations *)
+ loc_in_bounds li 0 ly.(ly_size) ∗
+ &frac{κ}(λ q', l ↦{q'} li) ∗
+ (* later for contractiveness *)
+ ▷ □ |={lftE}=> inner.(ty_shr) κ tid ri li)%I;
+ ty_ghost_drop π '(r, l) :=
+ ∃ ri, place_rfn_interp_owned r ri ∗ inner.(ty_ghost_drop) π ri;
+
+ ty_lfts := inner.(ty_lfts);
+ ty_wf_E := inner.(ty_wf_E);
+ |}%I.
+ Next Obligation.
+ iIntros (Ï€ [r l] v) "(%ly & -> & ? & ? & _)". eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (ot mt Hot). apply is_ptr_ot_layout in Hot as ->. done.
+ Qed.
+ Next Obligation.
+ iIntros (?[] ?) "(%ly & -> & _)". done.
+ Qed.
+ Next Obligation.
+ intros ??? []. apply _.
+ Qed.
+ Next Obligation.
+ iIntros (κ π l []) "(%ly & %ri & Hr & ? & ? & ? & _)".
+ eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (E κ l ly π [r li] q ?) "#(LFT & TIME & LLCTX) Htok %Halg %Hly #Hlb Hb".
+ rewrite -lft_tok_sep. iDestruct "Htok" as "(Htok & Htoki)".
+ iApply fupd_logical_step.
+ iMod (bor_exists with "LFT Hb") as (v) "Hb"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hl & Hb)"; first solve_ndisj.
+ iMod (bor_exists with "LFT Hb") as (ly') "Hb"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Heq & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Heq Htok") as "(>-> & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hst & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hst Htok") as "(>%Hst & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hly & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hly Htok") as "(>%Hly' & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hlb' & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hlb' Htok") as "(>#Hlb' & Htok)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hsc & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hsc Htok") as "(>Hsc & Htok)"; first solve_ndisj.
+ rewrite bi.sep_assoc.
+ iMod (bor_sep with "LFT Hb") as "(Hcred & Hb)"; first solve_ndisj.
+ iMod (bor_exists_tok with "LFT Hb Htok") as "(%ri & Hb & Htok)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hrfn & Hb)"; first solve_ndisj.
+
+ (* get observation about refinement *)
+ iAssert (|={E}=> (place_rfn_interp_shared r ri ∗ q.[κ]))%I with "[Htok Hrfn]" as ">(Hrfn & Htok)".
+ { iMod (bor_acc with "LFT Hrfn Htok") as "(>Hrfn & Hcl)"; first solve_ndisj.
+ destruct r.
+ - iDestruct "Hrfn" as "->". iMod ("Hcl" with "[//]") as "(? & $)". eauto.
+ - iMod ("Hcl" with "Hrfn") as "(? & $)". eauto. }
+
+ (* use credits to remove the later + fupd from Hb *)
+ iDestruct "Htok" as "(Htok1 & Htok)".
+ iMod (bor_acc with "LFT Hcred Htok1") as "(>(Hcred & Hat) & Hcl_cred)"; first solve_ndisj.
+ iDestruct "Hcred" as "(Hcred1 & Hcred2 & Hcred)".
+ set (R := (∃ v' : val, li ↦ v' ∗ v' â—áµ¥{ Ï€} ri @ inner)%I).
+ iPoseProof (bor_fupd_later_strong E lftE _ _ R True with "LFT [//] [Hcred1] [] Hb Htok") as "Hu"; [done | done | ..].
+ { iIntros "(_ & Ha)". iModIntro. iNext. iApply (lc_fupd_add_later with "Hcred1"); iNext.
+ iMod "Ha". by iFrame. }
+ { eauto with iFrame. }
+ iMod "Hu"as "Hu".
+ iApply (lc_fupd_add_later with "Hcred2"); iNext.
+ iMod "Hu" as "(Hb & Htok & _)".
+
+ iMod (bor_fracture (λ q, l ↦{q} li)%I with "LFT Hl") as "Hl"; first solve_ndisj.
+
+ (* recusively share *)
+ iDestruct "Htoki" as "(Htoki & Htoki2)".
+ iPoseProof (ty_share with "[$LFT $TIME $LLCTX] [Htok Htoki] [//] [//] Hlb' Hb") as "Hb"; first done.
+ { rewrite -lft_tok_sep. iFrame. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hb").
+
+ iApply (logical_step_intro_atime with "Hat").
+ iModIntro. iIntros "Hcred' Hat !> [#Hshr Htok]".
+ iMod ("Hcl_cred" with "[$Hcred' $Hat]") as "(? & Htok2)".
+ iCombine "Htok2 Htoki2" as "Htok2". rewrite !lft_tok_sep.
+ iCombine "Htok Htok2" as "$".
+ iModIntro.
+ iExists ly', ri. iFrame.
+ iSplitR. { inversion Halg; subst; done. }
+ iSplitR; first done. iSplitR; first done.
+ inversion Halg; subst ly. iFrame "#".
+ iNext. iModIntro. iModIntro. done.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (κ κ' π [r li] l) "#Hincl (%ly & %r' & Hrfn & ? & ? & ? & Hsc & Hlb & Hlbi & Hl & #Hshr)".
+ iExists ly, r'. iFrame. iSplitL "Hl".
+ { iApply (frac_bor_shorten with "Hincl Hl"). }
+ iNext. iDestruct "Hshr" as "#Hshr". iModIntro. iMod "Hshr". iModIntro.
+ by iApply (ty_shr_mono with "Hincl Hshr").
+ Qed.
+ Next Obligation.
+ simpl. iIntros (Ï€ [r l] v??) "(%ly & -> & Halg & Hly & Hlb & Hsc & Hcred & Hat & Hb)".
+ iDestruct "Hb" as "(%r' & Hr & Hv)".
+ iApply fupd_logical_step.
+ iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iApply (lc_fupd_add_later with "Hcred1"); iNext.
+ iMod (fupd_mask_mono with "Hv") as "Hv"; first done.
+ iDestruct "Hv" as "(%v' & Hl & Hv)".
+ iPoseProof (ty_own_ghost_drop with "Hv") as "Hgdrop"; first done.
+ iApply (logical_step_compose with "Hgdrop").
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "!> Hcred' Hat !> Hgdrop".
+ eauto with iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (ot mt st π [r l] ? Hot).
+ destruct mt.
+ - eauto.
+ - iIntros "(%ly & -> & ?)".
+ iExists ly. iFrame.
+ iPoseProof (mem_cast_compat_loc (λ v, True)%I) as "%Hl"; first done.
+ + eauto.
+ + iPureIntro. by apply Hl.
+ - iApply (mem_cast_compat_loc (λ v, _)); first done.
+ iIntros "(%ly & -> & _)". eauto.
+ Qed.
+
+End owned_ptr.
+
+(* TODO rules *)
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+
+
+
+End rules.
diff --git a/theories/rust_typing/pinned_borrows.v b/theories/rust_typing/pinned_borrows.v
new file mode 100644
index 0000000000000000000000000000000000000000..95eec19c53695837508d7fddf7876aec9fcd67cc
--- /dev/null
+++ b/theories/rust_typing/pinned_borrows.v
@@ -0,0 +1,463 @@
+(** * Defining pinned borrows on top of the existing lifetime logic. *)
+(** Compared to a proper deep change in the model, we get two laters for some operations. *)
+From lrust.lifetime Require Export lifetime.
+From iris.proofmode Require Import proofmode.
+From iris.base_logic Require Import saved_prop.
+From iris Require Import options.
+
+Class pinnedBorG Σ := PinnedBorG {
+ pinnedBorG_saved_prop_ownG : savedPropG Σ;
+}.
+Local Existing Instance pinnedBorG_saved_prop_ownG.
+Global Hint Mode pinnedBorG - : typeclass_instances.
+
+(* what is the story here for parallel access to products? we consume credits here, so parallel composition does not work.
+ Options:
+ - use the accessor with two laters in that case.
+ - maybe switch completely to prepaid reasoning.
+ => ended up doing this!
+ - .... ?
+ *)
+
+Definition pinnedBorΣ : gFunctors := #[ savedPropΣ ].
+Global Instance subG_pinnedBorΣ {Σ} : subG pinnedBorΣ Σ → pinnedBorG Σ.
+Proof. solve_inG. Qed.
+
+Section pinned_borrows.
+ Context `{!invGS Σ} `{!pinnedBorG Σ} `{!lftGS Σ userE}.
+
+ Local Definition pinned_bor_def (κ : lft) (Q : iProp Σ) (P : iProp Σ) : iProp Σ :=
+ ∃ γ κ' P', κ ⊑ κ' ∗ saved_prop_own γ (DfracOwn (1/2)) P' ∗
+ ▷ □ (P' → P) ∗
+ ▷ □ (P → P' ∨ Q) ∗
+ &{κ'} (∃ P' : iProp Σ, saved_prop_own γ (DfracOwn (1/2)) P' ∗ P' ∗
+ £1 ∗ (P' -∗ [†κ'] ={userE}=∗ ▷ Q)).
+ Local Definition pinned_bor_aux : seal (@pinned_bor_def). Proof. by eexists. Qed.
+ Definition pinned_bor := pinned_bor_aux.(unseal).
+ Local Definition pinned_bor_unseal : @pinned_bor = @pinned_bor_def := pinned_bor_aux.(seal_eq).
+
+ Lemma pinned_bor_shorten κ κ' Q P :
+ κ ⊑ κ' -∗
+ pinned_bor κ' Q P -∗
+ pinned_bor κ Q P.
+ Proof.
+ iIntros "Hincl Hb". rewrite pinned_bor_unseal.
+ iDestruct "Hb" as (γ κ0 P0) "(Hincl0 & Hsaved & Hbor)".
+ iExists γ, κ0, P0. iFrame.
+ iApply (lft_incl_trans with "Hincl Hincl0").
+ Qed.
+
+ Lemma pinned_bor_fake E κ P Q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ [†κ] ={E}=∗ pinned_bor κ Q P.
+ Proof.
+ iIntros (?) "#LFT Hdead". rewrite pinned_bor_unseal.
+ iMod (saved_prop_alloc P (DfracOwn 1)) as (γ) "[Hsaved1 Hsaved2]"; first done.
+ iMod (bor_fake with "LFT Hdead") as "Hb"; first done.
+ iExists γ, κ, P.
+ iFrame. iModIntro. iSplit; last iSplit.
+ - iApply lft_incl_refl.
+ - eauto.
+ - eauto.
+ Qed.
+
+ (** We need the credit for the inheritance viewshift. *)
+ Lemma pinned_bor_unfold E κ P :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ £1 -∗
+ &{κ} P ={E}=∗ pinned_bor κ P P.
+ Proof.
+ iIntros (?) "#LFT Hcred Hb".
+ iMod (saved_prop_alloc P (DfracOwn 1%Qp)) as (γ) "[Hs1 Hs2]"; first done.
+ iMod (bor_acc_atomic_strong with "LFT Hb") as "[Ha | Hdead]"; first done.
+ - rewrite pinned_bor_unseal.
+ iDestruct "Ha" as (κ') "(#Hincl & HP & Hcl)".
+ set (Q := (∃ P', saved_prop_own γ (DfracOwn (1/2)) P' ∗ P' ∗ £1 ∗
+ (P' -∗ [†κ'] ={userE}=∗ ▷ P))%I).
+ iMod ("Hcl" $! Q with "[] [Hs2 HP Hcred]") as "Ha".
+ + iNext. iIntros "(%P' & Hsaved & HP' & >Hcred & Hvs) Hdead".
+ (* this is a problem due to commuting. Need a credit. *)
+ iApply (lc_fupd_add_later with "Hcred"). iNext.
+ iMod ("Hvs" with "HP' Hdead") as "HP". eauto.
+ + iNext. iExists P. iFrame. eauto.
+ + iModIntro. iExists γ, κ', P. iFrame "#∗". iSplit; eauto.
+ - iDestruct "Hdead" as "(Hdead & Hcl)". iMod "Hcl" as "_".
+ by iApply (pinned_bor_fake with "LFT Hdead").
+ Qed.
+ (*
+ Q: can we reasonably go further and directly make it prepaid, if we anyways have credits?
+ - the accessors will need to regenerate it.
+ - so this makes this interface less flexible. We just save on one credit at allocation time.
+ => think more about the trade-off.
+ *)
+
+ (** Note: we need a credit here to eliminate the later when opening a borrow.
+ Just having a later in the VS does not work because we are using an atomic accessor. *)
+ Lemma pinned_bor_fold E κ P :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ £1 -∗
+ pinned_bor κ P P ={E}=∗ &{κ} P.
+ Proof.
+ iIntros (?) "#LFT Hcred Hb". rewrite pinned_bor_unseal.
+ iDestruct "Hb" as (γ κ' P0) "(Hincl & Hsaved & #HP0P & #HPP0 & Hb)".
+ iMod (bor_acc_atomic_strong with "LFT Hb") as "[Ha | Hdead]"; first done.
+ - iDestruct "Ha" as (κ'') "(#Hincl' & HP & Hcl)".
+ iDestruct "HP" as (P') "HP".
+ (* we cannot just use [Hcred'] here, as we need to return it in the closing viewshift *)
+ iMod (lc_fupd_elim_later with "Hcred HP") as "HP".
+ iDestruct "HP" as "(Hsaved' & HP & Hcred' & _)".
+ iPoseProof (saved_prop_agree with "Hsaved Hsaved'") as "#Hag".
+ iMod (saved_prop_update_halves P with "Hsaved Hsaved'") as "[Hsaved Hsaved']".
+ iMod ("Hcl" $! P with "[Hsaved' Hcred'] [HP]") as "HP".
+ + iNext. iIntros "HP _ !>!>". iExists P. iFrame. eauto.
+ + iNext. iApply "HP0P". iRewrite "Hag". done.
+ + iModIntro. iApply (bor_shorten with "[Hincl] HP").
+ iApply (lft_incl_trans with "Hincl Hincl'").
+ - iDestruct "Hdead" as "(Hdead & Hcl)". iMod "Hcl" as "_".
+ iMod (lft_incl_dead with "Hincl Hdead") as "Hdead"; first done.
+ iApply (bor_fake with "LFT Hdead"); done.
+ Qed.
+
+ (** This variant requires a proof of liveness of [κ], but in turn only requires a later instead of a credit. *)
+ Lemma pinned_bor_fold_tok E q κ P :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ q.[κ] -∗
+ pinned_bor κ P P ={E}▷=∗ &{κ} P ∗ q.[κ].
+ Proof.
+ iIntros (?) "#LFT Htok Hb". rewrite pinned_bor_unseal.
+ iDestruct "Hb" as (γ κ' P0) "(#Hincl & Hsaved & #HP0P & #HPP0 & Hb)".
+ iMod (lft_incl_acc with "Hincl Htok") as "(%q' & Htok & Hcl_tok)"; first done.
+ iMod (bor_acc_strong with "LFT Hb Htok") as "(%κ'' & #Hincl' & Ha & Hcl)"; first done.
+ iDestruct "Ha" as (P') "HP".
+ iModIntro. iNext.
+ iDestruct "HP" as "(Hsaved' & HP & Hcred' & _)".
+ iPoseProof (saved_prop_agree with "Hsaved Hsaved'") as "#Hag".
+ iMod (saved_prop_update_halves P with "Hsaved Hsaved'") as "[Hsaved Hsaved']".
+ iMod ("Hcl" $! P with "[Hsaved' Hcred'] [HP]") as "(HP & Htok)".
+ + iNext. iIntros "HP _ !>!>". iExists P. iFrame. eauto.
+ + iNext. iApply "HP0P". iRewrite "Hag". done.
+ + iMod ("Hcl_tok" with "Htok") as "$".
+ iApply (bor_shorten with "[Hincl] HP").
+ iApply (lft_incl_trans with "Hincl Hincl'").
+ Qed.
+
+
+ (* This lemma requires a credit in the closing viewshift.
+ This is a choice we take in order to not get two laters over [P] when opening, but "just" one.
+ For the client, this slightly restricts the interface, but the credit-based reasoning we do here
+ could not otherwise encoded on top of the client since having two laters over [P] breaks
+ timeless-ness reasoning for credits.
+ *)
+ Lemma pinned_bor_acc_strong E q κ P Q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ pinned_bor κ Q P -∗
+ q.[κ] ={E}=∗
+ ∃ κ' : lft, κ ⊑ κ' ∗
+ ▷ P ∗
+ ▷ (P -∗ [†κ'] ={userE}=∗ ▷ Q) ∗
+ (∀ R,
+ ▷ (R -∗ [†κ'] ={userE}=∗ ▷ Q) -∗
+ £1 -∗
+ ▷ R ={E}=∗
+ pinned_bor κ' Q R ∗ q.[κ]).
+ Proof.
+ iIntros (?) "#LFT Hb Htok". rewrite pinned_bor_unseal.
+ iDestruct "Hb" as (γ κ' P0) "(#Hincl & Hsaved1 & #HP0P & #HPP0 & Hb)".
+ iMod (lft_incl_acc with "Hincl Htok") as (q') "(Htok & Hcl_tok)"; first done.
+ iMod (bor_acc with "LFT Hb Htok") as "(HP & Hcl)"; first done.
+ iDestruct "HP" as (P') "(Hsaved2 & HP & >Hcred & Hvs)".
+ (* use the credit to strip the later over [Hsaved2] *)
+ iMod (lc_fupd_elim_later with "Hcred Hsaved2") as "Hsaved2".
+ iPoseProof (saved_prop_agree with "Hsaved1 Hsaved2") as "#Hag".
+ iModIntro. iExists κ'. iFrame "Hincl".
+ iSplitL "HP". { iNext. iApply "HP0P". iRewrite "Hag". done. }
+ iSplitL "Hvs". {
+ iNext. iIntros "HP". iDestruct ("HPP0" with "HP") as "[HP0 | HQ]".
+ - iRewrite "Hag" in "HP0". iApply ("Hvs" with "HP0").
+ - eauto.
+ }
+ iIntros (R) "Hvs' Hcred HR".
+ iMod (saved_prop_update_halves R with "Hsaved1 Hsaved2") as "(Hsaved1 & Hsaved2)".
+ iMod ("Hcl" with "[Hsaved2 HR Hcred Hvs']") as "(Hb & Htok)".
+ - iNext. iExists R. iFrame.
+ - iMod ("Hcl_tok" with "Htok") as "$".
+ iModIntro. iExists γ, κ', R. iFrame. iSplitL; last iSplitL.
+ + iApply lft_incl_refl.
+ + eauto.
+ + eauto.
+ Qed.
+
+ (* A variant with two laters instead of the credit for completeness. *)
+ Lemma pinned_bor_acc_strong' E q κ P Q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ pinned_bor κ Q P -∗
+ q.[κ] ={E}=∗
+ ∃ κ' : lft, κ ⊑ κ' ∗ ▷(
+ ▷ P ∗
+ ▷ (P -∗ [†κ'] ={userE}=∗ ▷ Q) ∗
+ (∀ R,
+ ▷ (R -∗ [†κ'] ={userE}=∗ ▷ Q) -∗
+ ▷ R ={E}=∗
+ pinned_bor κ' Q R ∗ q.[κ])).
+ Proof.
+ iIntros (?) "#LFT Hb Htok". rewrite pinned_bor_unseal.
+ iDestruct "Hb" as (γ κ' P0) "(#Hincl & Hsaved1 & #HP0P & #HPP0 & Hb)".
+ iMod (lft_incl_acc with "Hincl Htok") as (q') "(Htok & Hcl_tok)"; first done.
+ iMod (bor_acc with "LFT Hb Htok") as "(HP & Hcl)"; first done.
+ iDestruct "HP" as (P') "(Hsaved2 & HP & >Hcred & Hvs)".
+ iModIntro. iExists κ'. iFrame "Hincl". iNext.
+ iPoseProof (saved_prop_agree with "Hsaved1 Hsaved2") as "#Hag".
+ iSplitL "HP". { iNext. iRewrite -"Hag" in "HP". iApply "HP0P". done. }
+ iSplitL "Hvs". {
+ iNext. iIntros "HP". iDestruct ("HPP0" with "HP") as "[HP0 | HQ]".
+ - iRewrite "Hag" in "HP0". iApply ("Hvs" with "HP0").
+ - eauto.
+ }
+ iIntros (R) "Hvs' HR".
+ iMod (saved_prop_update_halves R with "Hsaved1 Hsaved2") as "(Hsaved1 & Hsaved2)".
+ iMod ("Hcl" with "[Hsaved2 HR Hcred Hvs']") as "(Hb & Htok)".
+ - iNext. iExists R. iFrame.
+ - iMod ("Hcl_tok" with "Htok") as "$".
+ iModIntro. iExists γ, κ', R. iFrame. iSplitL; last iSplitL.
+ + iApply lft_incl_refl.
+ + eauto.
+ + eauto.
+ Qed.
+
+ (** derived variant where we go back to [P] *)
+ Lemma pinned_bor_acc_back E q κ P Q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ pinned_bor κ Q P -∗
+ q.[κ] ={E}=∗ ▷ P ∗
+ (▷ Q -∗ £1 ={E}=∗ pinned_bor κ Q Q ∗ q.[κ]).
+ Proof.
+ iIntros (?) "#LFT Hb Htok".
+ iMod (pinned_bor_acc_strong with "LFT Hb Htok") as (κ') "(Hincl & Hb & Hvs & Hclose)"; first done.
+ iModIntro. iFrame "Hb".
+ iIntros "HQ Hcred". iMod ("Hclose" $! Q with "[] Hcred HQ") as "(Hb & $)".
+ { eauto. }
+ iApply (pinned_bor_shorten with "Hincl Hb").
+ Qed.
+
+ Lemma pinned_bor_acc E q κ P Q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ pinned_bor κ Q P -∗
+ q.[κ] ={E}=∗
+ ▷ P ∗ (▷ P -∗ £1 ={E}=∗ pinned_bor κ Q P ∗ q.[κ]).
+ Proof.
+ iIntros (?) "#LFT Hb Htok".
+ iMod (pinned_bor_acc_strong with "LFT Hb Htok") as (κ') "(Hincl & Hb & Hvs & Hclose)"; first done.
+ iModIntro. iFrame "Hb".
+ iIntros "HP Hcred". iMod ("Hclose" $! P with "Hvs Hcred HP") as "(Hb & $)".
+ iApply (pinned_bor_shorten with "Hincl Hb").
+ Qed.
+
+ (* NOTE: we could also have an adapted version of this that takes a lifetime token proving that κ is live,
+ and in turn use laters instead of credits
+ -- the credits are necessary because we can't intro laters in a step_fupdN when accessing a borrow atomically. *)
+ Lemma pinned_bor_rebor_full E κ κ' P Q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ κ' ⊑ κ -∗
+ £2 -∗
+ pinned_bor κ Q P ={E}=∗
+ &{κ'} P ∗ ([†κ'] ={E}=∗ pinned_bor κ Q P).
+ Proof.
+ (* Proof sketch:
+ 1. unfold the pinned borrow.
+ 2. rebor the full borrow.
+ 3. adapt the contents of the borrow to P somehow.
+ - open with atomic accessor
+ - strip the later with a credit
+ - use saved prop agreement, use a credit
+ - close the borrow with the existential over P'' frozen to P
+ 4. use bor_sep on the closed borrow to throw away the parts that are not P.
+ 5. for the inheritance, use the inheritance of the full reborrow.
+ then just assemble everything again. *)
+ iIntros (?) "#LFT #Hincl (Hcred1 & Hcred2) Hb".
+ rewrite pinned_bor_unseal /pinned_bor_def.
+ iDestruct "Hb" as "(%γ & %κ'' & %P' & #Hincl' & Hsaved & HP & HP' & Hb)".
+ iMod (rebor _ _ κ' with "LFT [] Hb") as "(Hb & Hinh)"; first done.
+ { iApply lft_incl_trans; done. }
+
+ (* access the borrow to get agreement, spends credits due to atomic borrow *)
+ iMod (bor_acc_atomic_strong with "LFT Hb") as "[(%κ0 & #Hincl0 & Hb & Hcl_b) | (#Hdead_κ' & >_)]"; first done; first last.
+ { iMod (bor_fake _ _ P with "LFT Hdead_κ'") as "$"; first done.
+ iIntros "!> _".
+ iMod ("Hinh" with "Hdead_κ'") as "Hb".
+ iModIntro. iExists γ, κ'', P'. iFrame. done. }
+ iApply (lc_fupd_add_later with "Hcred1"). iNext.
+ iDestruct "Hb" as "(%P'' & Hsaved2 & HP'' & Hcred & Hvs)".
+ iPoseProof (saved_prop_agree with "Hsaved Hsaved2") as "#Hag".
+ iApply (lc_fupd_add_later with "Hcred2"). iNext.
+ iMod (saved_prop_update_halves P with "Hsaved Hsaved2") as "(Hsaved & Hsaved2)".
+ iDestruct "HP" as "#HP". iDestruct "HP'" as "#HP'".
+ iMod ("Hcl_b" $! (saved_prop_own γ (DfracOwn (1 / 2)) P ∗ P ∗ £ 1 ∗ (P -∗ [†κ''] ={userE}=∗ ▷ Q))%I with "[] [Hsaved2 HP'' Hcred Hvs]") as "Hb".
+ { iNext. iIntros "(Hsaved & Hprop & Hcred & Hvs) Hdead".
+ iModIntro. iNext. iExists P. iFrame. }
+ { iFrame. iNext. iSplitL "HP''". { iApply "HP". iRewrite "Hag". iFrame. }
+ iIntros "Hprop Hdead". iDestruct ("HP'" with "Hprop") as "[Hprop | Hprop]"; last by eauto.
+ iApply ("Hvs" with "[Hprop] Hdead"). iRewrite -"Hag". done. }
+
+ iMod (bor_sep with "LFT Hb") as "(_ & Hb)"; first done.
+ iMod (bor_sep with "LFT Hb") as "(Hb & _)"; first done.
+
+ iModIntro.
+ iSplitL "Hb". { iApply bor_shorten; last done. done. }
+ iIntros "Hdead". iMod ("Hinh" with "Hdead") as "Hb".
+ iModIntro. iExists γ, κ'', P. iFrame.
+ iSplit; first done. iSplit; iNext; iModIntro; eauto.
+ Qed.
+
+ (* Here, we need [κ] to be alive, because we cannot use the atomic accessor for the proof.
+ With the atomic accessor, we cannot execute the update inside the borrow when first opening it,
+ but that update is important for the inheritance viewshift of the outer borrow for thunking. *)
+ Lemma pinned_bor_unnest_full E κ κ' P Q q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ £ 2 -∗
+ q.[κ] -∗
+ &{κ} (|={↑lftN}=> pinned_bor κ' Q P) ={E}▷=∗^2
+ &{κ ⊓ κ'} P ∗ q.[κ].
+ Proof.
+ (* Proof sketch:
+ 1. open the borrow
+ 2. use a later.
+ 3. use the reborrow lemma for κ ⊓ κ'
+ 4. close the borrow, with the full borrow + inheritance; the fact that we have the ↑lftN mask is crucial for the inheritance here.
+ 5. use bor_sep and throw away the borrow of the inheritance
+ 6. use the bor_unnest lemma *)
+ iIntros (?) "#LFT Hcred2 Htok Hb".
+ iMod (bor_acc_strong with "LFT Hb Htok") as "(%κ'' & #Hincl & Hb & Hcl)"; first done.
+ iModIntro. iNext. iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ iMod (fupd_mask_subseteq (↑lftN)) as "Hcl_E"; first done.
+ iMod (pinned_bor_rebor_full (↑lftN) _ (κ ⊓ κ') with "LFT [] Hcred2 Hb") as "Hb"; first done.
+ { iApply lft_intersect_incl_r. }
+ iMod "Hcl_E" as "_".
+ iMod ("Hcl" with "[] Hb") as "(Hb & $)".
+ { iNext. iIntros "(Hb & Hinh) Hdead".
+ iModIntro. iNext. iMod (lft_incl_dead _ (κ ⊓ κ') with "[] Hdead") as "Hdead"; first done.
+ { iApply lft_incl_trans; last done. iApply lft_intersect_incl_l. }
+ iMod ("Hinh" with "Hdead") as "$". eauto. }
+ iMod (bor_sep with "LFT Hb") as "(Hb & _)"; first done.
+ iMod (bor_unnest with "LFT Hb") as "Hb"; first done.
+ iModIntro. iModIntro. iNext. iMod "Hb".
+ iApply (bor_shorten with "[] Hb").
+ iApply lft_incl_glb.
+ - iApply lft_incl_refl.
+ - iApply lft_incl_trans; last done.
+ iApply lft_intersect_incl_l.
+ Qed.
+
+ Global Instance pinned_bor_ne κ n :
+ Proper (dist n ==> dist n ==> dist n) (pinned_bor κ).
+ Proof. rewrite pinned_bor_unseal. solve_proper. Qed.
+
+ Global Instance pinned_bor_equiv κ :
+ Proper (equiv ==> equiv ==> equiv) (pinned_bor κ).
+ Proof. rewrite pinned_bor_unseal. solve_proper. Qed.
+
+ Lemma pinned_bor_impl κ P Q R :
+ (▷ □ ((P → R) ∧ (R → Q))) -∗
+ pinned_bor κ Q P -∗
+ pinned_bor κ Q R.
+ Proof.
+ rewrite pinned_bor_unseal. iIntros "#[HPR HRQ] Hb".
+ iDestruct "Hb" as (γ κ' P0) "(#Hincl & Hsaved1 & #HP0P & #HPP0 & Hb)".
+ iExists γ, κ', P0. iFrame "#∗".
+ iSplit; iModIntro; iModIntro.
+ - iIntros "HP0". iApply "HPR". iApply "HP0P". done.
+ - iIntros "HR". iRight. iApply "HRQ". done.
+ Qed.
+
+ Lemma pinned_bor_iff κ P P' Q Q' :
+ (▷ □ ((P → P') ∧ (P' → P))) -∗
+ (▷ □ ((Q → Q') ∧ (Q' → Q))) -∗
+ pinned_bor κ Q P -∗
+ pinned_bor κ Q' P'.
+ Proof.
+ rewrite pinned_bor_unseal. iIntros "#[HPP' HP'P] #[HQQ' HQ'Q] Hb".
+ iDestruct "Hb" as (γ κ' P0) "(#Hincl & Hsaved1 & #HP0P & #HPP0 & Hb)".
+ iExists γ, κ', P0. iFrame "#∗".
+ iSplitR; last iSplitR.
+ - iIntros "!> !>HP0". iApply "HPP'". iApply "HP0P". done.
+ - iIntros "!>!>HP'".
+ iPoseProof ("HP'P" with "HP'") as "HP".
+ iPoseProof ("HPP0" with "HP") as "[HP0 | HQ]".
+ + by iLeft.
+ + iRight. by iApply "HQQ'".
+ - iApply (bor_iff with "[] Hb").
+ iNext. iModIntro. iSplit; iIntros "(%PP & Hsaved & HPP & Hcred & Hvs)"; iExists PP; iFrame.
+ all: iIntros "HPP Hdead"; iMod ("Hvs" with "HPP Hdead") as "HQ".
+ + by iApply "HQQ'".
+ + by iApply "HQ'Q".
+ Qed.
+
+ Lemma pinned_bor_iff' κ P Q :
+ (▷ □ ((P → Q) ∧ (Q → P))) -∗
+ pinned_bor κ P P -∗
+ pinned_bor κ Q Q.
+ Proof.
+ iIntros "#Heq". iApply pinned_bor_iff; done.
+ Qed.
+
+ (* TODO maybe we can get the same thing without a token by using atomic accessors? *)
+ Lemma pinned_bor_exists_freeze {X} `{Inhabited X} κ q E (Q : iProp Σ) (Φ : X → iProp Σ) :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ pinned_bor κ Q (∃ x : X, Φ x) -∗
+ q.[κ] -∗
+ £ 1 ={E}=∗
+ ∃ x : X, pinned_bor κ Q (Φ x) ∗ q.[κ].
+ Proof.
+ iIntros (?) "#LFT Hb Htok Hcred".
+ iMod (pinned_bor_acc_strong with "LFT Hb Htok") as "(%κ' & #Hincl & HP & Hret & Hcl)"; first done.
+ iDestruct "HP" as "(%x & HP)".
+ iMod ("Hcl" $! (Φ x) with "[Hret] Hcred HP") as "(Hb & Htok)".
+ - iNext. iIntros "HP". iApply "Hret". eauto.
+ - iModIntro. iExists x. iFrame.
+ by iApply pinned_bor_shorten.
+ Qed.
+ (* using a later instead *)
+ Lemma pinned_bor_exists_freeze' {X} `{Inhabited X} κ q E (Q : iProp Σ) (Φ : X → iProp Σ) :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ pinned_bor κ Q (∃ x : X, Φ x) -∗
+ q.[κ] ={E}▷=∗
+ ∃ x : X, pinned_bor κ Q (Φ x) ∗ q.[κ].
+ Proof.
+ iIntros (?) "#LFT Hb Htok".
+ iMod (pinned_bor_acc_strong' with "LFT Hb Htok") as "(%κ' & #Hincl & HP & Hret & Hcl)"; first done.
+ iDestruct "HP" as "(%x & HP)".
+ iExists x.
+ iModIntro. iNext.
+ iMod ("Hcl" $! (Φ x) with "[Hret] HP") as "(Hb & Htok)".
+ - iNext. iIntros "HP". iApply "Hret". eauto.
+ - iModIntro. iFrame.
+ by iApply pinned_bor_shorten.
+ Qed.
+
+ (* TODO can we have atomic accessors for pinned borrows like bor_acc_atomic?
+ Problem/disadvantage: they will require later credits, which makes them much less useful for many things.
+ *)
+End pinned_borrows.
+
+Notation "'&pin{' κ } [ P ] Q" := (pinned_bor κ P Q) (at level 40) : bi_scope.
+Notation "'&pin{' κ } P" := (pinned_bor κ P P) (at level 40) : bi_scope.
+
+
+(*
+ One idle idea (that does not work):
+ If we work in a model where everything is prepaid, do we need pinned borrows anymore?
+ The immediate idea would be to use atomic accessors and use the credits we have stored to strip the laters,
+ and that we can do even if we don't have lifetime tokens, since all this happens atomically.
+ The problem then is that we cannot regenerate those credits.
+ *)
diff --git a/theories/rust_typing/products.v b/theories/rust_typing/products.v
new file mode 100644
index 0000000000000000000000000000000000000000..42b7a1feabf2396eb4c2f2e080cb74d3d281f29a
--- /dev/null
+++ b/theories/rust_typing/products.v
@@ -0,0 +1,2758 @@
+From refinedrust Require Export type ltypes.
+From refinedrust Require Import util hlist.
+From refinedrust Require Import uninit_def.
+From refinedrust Require Import uninit programs ltype_rules.
+Set Default Proof Using "Type".
+
+(** * Struct types *)
+(** Basic design notes:
+ - parameterized by a (heterogeneous) list of [type]s.
+ - for refinements, use a heterogeneous list, indexed by the refinement.
+ - parameterize by the [struct_layout_spec] *)
+
+(** We define [is_struct_ot] not just on the syntactic type, but also directly involve the component types [tys],
+ because this stratifies the recursion going on and we anyways need to define a relation involving the [mt] for the semantic types. *)
+Definition is_struct_ot `{typeGS Σ} (sls : struct_layout_spec) (tys : list rtype) (ot : op_type) (mt : memcast_compat_type) :=
+ length (sls.(sls_fields)) = length tys ∧
+ match ot with
+ | StructOp sl ots =>
+ (* padding bits will be garbled, so we cannot fulfill MCId *)
+ mt ≠MCId ∧
+ (* sl is a valid layout for this sls *)
+ use_struct_layout_alg sls = Some sl ∧
+ length ots = length tys ∧
+ (* pointwise, the members have the right op_type and a layout matching the optype *)
+ foldr (λ ty, and (let '(ty, ot) := ty in
+ (ty.(rt_ty) : type _).(ty_has_op_type) ot mt ∧
+ syn_type_has_layout (ty.(rt_ty).(ty_syn_type)) (ot_layout ot)))
+ True (zip tys ots)
+ | UntypedOp ly =>
+ (* ly is a valid layout for this sls *)
+ ∃ sl, use_struct_layout_alg sls = Some sl ∧ ly = sl ∧
+ (* pointwise, the members have the right op type *)
+ foldr (λ ty, and (∃ ly,
+ syn_type_has_layout (ty.(rt_ty).(ty_syn_type)) ly ∧ (ty.(rt_ty) : type _).(ty_has_op_type) (UntypedOp ly) mt
+ ))
+ True tys
+ | _ => False
+ end.
+
+(* Problem:
+ the sl is embedded in the StructOp.
+ We require that the sls matches this sl.
+ Then we have also the ots for the fields. We should require that the types at those fields are compatible with that.
+ We should get automatically that the sl is compatible with the fields..
+
+
+ we could also use sl_has_members I guess, though.
+ -
+ *)
+
+(*
+Definition is_struct_ot `{typeGS Σ} (sls : struct_layout_spec) (tys : list rtype) (ot : op_type) (mt : memcast_compat_type) :=
+ length (sls.(sls_fields)) = length tys ∧
+ match ot with
+ | StructOp sl ots =>
+ (* padding bits will be garbled, so we cannot fulfill MCId *)
+ mt ≠MCId ∧
+ (* sl is a valid layout for this sls *)
+ use_struct_layout_alg sls = Some sl ∧
+ length ots = length tys ∧
+ (* pointwise, the members have the right op_type and a layout matching the optype *)
+ foldr (λ ty, and (let '(ty, (x, ly), ot) := ty in (ty.(rt_ty) : type _).(ty_has_op_type) ot mt ∧ ot_layout ot = ly))
+ True (zip (zip tys (field_members sl.(sl_members))) ots)
+ | UntypedOp ly =>
+ (* ly is a valid layout for this sls *)
+ ∃ sl, use_struct_layout_alg sls = Some sl ∧ ly = sl ∧
+ (* pointwise, the members have the right op type *)
+ foldr (λ ty, and (let '(ty, (x, ly)) := ty in (ty.(rt_ty) : type _).(ty_has_op_type) (UntypedOp ly) mt))
+ True (zip tys (field_members sl.(sl_members)))
+ | _ => False
+ end.
+ *)
+
+Lemma is_struct_ot_layout `{typeGS Σ} sls sl tys ot mt :
+ use_struct_layout_alg sls = Some sl →
+ is_struct_ot sls tys ot mt → ot_layout ot = sl.
+Proof. move => ? [?]. destruct ot => //; naive_solver. Qed.
+
+(** ** Unit type *)
+(** [unit_t] gets some special treatment, because it occurs frequently and is specced to be a ZST *)
+Section unit.
+ Context `{!typeGS Σ}.
+
+ Program Definition unit_t : type unit := {|
+ st_own Ï€ _ v := ⌜v = zst_valâŒ;
+ st_syn_type := UnitSynType;
+ st_has_op_type ot mt := is_unit_ot ot;
+ |}%I.
+ Next Obligation.
+ iIntros (Ï€ _ v ->). eauto.
+ Qed.
+ Next Obligation.
+ intros ot mt ->%is_unit_ot_layout. done.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (ot ?? _ _ v Hot ->).
+ destruct mt.
+ - done.
+ - destruct ot; try by destruct Hot. destruct Hot as [-> ->]. done.
+ - iApply (mem_cast_compat_unit (λ _, True)%I); eauto.
+ Qed.
+
+ Global Instance unit_copyable : Copyable unit_t.
+ Proof. apply _. Qed.
+
+ Global Instance unit_timeless l z π:
+ Timeless (l â—áµ¥{Ï€} z @ unit_t)%I.
+ Proof. apply _. Qed.
+
+ Lemma type_val_unit π (T : ∀ rt, type rt → rt → iProp Σ):
+ T _ (unit_t) () ⊢ typed_value (zst_val) π T.
+ Proof.
+ iIntros "HT #LFT".
+ iExists _, unit_t, (). iFrame "HT". done.
+ Qed.
+ Global Instance type_val_unit_inst π : TypedValue zst_val π :=
+ λ T, i2p (type_val_unit π T).
+End unit.
+
+Global Hint Unfold unit_t : tyunfold.
+
+(** ** Full structs *)
+Section structs.
+ Context `{!typeGS Σ}.
+
+
+ Polymorphic Definition zip_to_rtype (rt : list Type) (tys : hlist type rt) :=
+ (fmap (λ x, mk_rtype (projT2 x)) (hzipl rt tys)).
+
+ (** We use a [hlist] for the list of types and a [plist] for the refinement, to work around universe problems.
+ See also the [ltype] definition. Using just [hlist] will cause universe problems, while using [plist] in the [lty]
+ inductive will cause strict positivity problems. *)
+ Program Definition struct_t {rts : list Type} (sls : struct_layout_spec) (tys : hlist type rts) : type (plist place_rfn rts) := {|
+ ty_own_val π r v :=
+ (∃ sl,
+ ⌜use_struct_layout_alg sls = Some sl⌠∗
+ ⌜length rts = length sls.(sls_fields)⌠∗
+ ⌜v `has_layout_val` sl⌠∗
+ (* the padding fields get the uninit type *)
+ [∗ list] i ↦ v';ty ∈ reshape (ly_size <$> sl.(sl_members).*2) v; pad_struct sl.(sl_members) (hpzipl rts tys r)
+ (λ ly, existT unit (uninit (UntypedSynType ly), PlaceIn ())),
+ let '(existT rt (ty, r)) := ty in
+ (* TODO add ty_sidecond? *)
+ (∃ (r' : rt) (ly : layout), place_rfn_interp_owned r r' ∗
+ (* Require that the layout taken here matches the struct component's layout.
+ We already know that the sizes match, but for the alignment requirement, we need to require this explicitly. *)
+ ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ v' â—áµ¥{Ï€} r' @ ty))%I;
+ ty_sidecond := ⌜length rts = length (sls_fields sls)âŒ;
+ ty_has_op_type ot mt := is_struct_ot sls (zip_to_rtype rts tys) ot mt;
+ ty_syn_type := sls : syn_type;
+ ty_shr κ π r l :=
+ (∃ sl,
+ ⌜use_struct_layout_alg sls = Some sl⌠∗
+ ⌜length rts = length sls.(sls_fields)⌠∗
+ ⌜l `has_layout_loc` sl⌠∗
+ (* TODO Should we have a loc_in_bounds here? If so, then we'd need to require one in the definition of sharing! *)
+ [∗ list] i ↦ ty ∈ pad_struct sl.(sl_members) (hpzipl rts tys r) (λ ly, existT unit (uninit (UntypedSynType ly), PlaceIn ())),
+ ∃ r' ly, place_rfn_interp_shared (projT2 ty).2 r' ∗
+ ⌜snd <$> sl.(sl_members) !! i = Some ly⌠∗
+ ⌜syn_type_has_layout ((projT2 ty).1).(ty_syn_type) ly⌠∗
+ ty_sidecond (projT2 ty).1 ∗
+ (l +â‚— Z.of_nat (offset_of_idx sl.(sl_members) i)) â—â‚—{Ï€, κ} r' @ (projT2 ty).1
+ )%I;
+ ty_ghost_drop π r := True%I; (* TODO *)
+ ty_lfts := concat (fmap (λ ty, (projT2 ty).(ty_lfts)) (hzipl rts tys));
+ ty_wf_E := concat (fmap (λ ty, (projT2 ty).(ty_wf_E)) (hzipl rts tys));
+ |}.
+ Next Obligation.
+ iIntros (rts sls tys π r v) "(%sl & %Halg & %Hlen & %Hly & ?)".
+ iExists sl. iPureIntro. split; last done.
+ by apply use_struct_layout_alg_Some_inv.
+ Qed.
+ Next Obligation.
+ iIntros (rts sls tys ot mt Hot).
+ destruct Hot as [Hlen Hot].
+ destruct ot; try done.
+ - destruct Hot as (Halg & Hlen' & Hmem).
+ simpl. by apply use_struct_layout_alg_Some_inv.
+ - destruct Hot as (sl & Halg & -> & Hmem).
+ simpl. by apply use_struct_layout_alg_Some_inv.
+ Qed.
+ Next Obligation.
+ iIntros (rts sls tys π r v) "(%sl & ? & $ & _)".
+ Qed.
+ Next Obligation.
+ iIntros (rts sls tys κ π l r) "(%sl & %Halg & %Hly & % & Hmem)".
+ iExists sl. iSplitR; first done. iPureIntro.
+ by apply use_struct_layout_alg_Some_inv.
+ Qed.
+ Next Obligation.
+ (* sharing *)
+ Admitted.
+ Next Obligation.
+ (* monotonicity of sharing *)
+ Admitted.
+ Next Obligation.
+ iIntros (rts sls tys π r v F ?) "(%sl & %Halg & Hlen & %Hly & Hmem)".
+ by iApply logical_step_intro.
+ Qed.
+ Next Obligation.
+ iIntros (rts sls tys ot mt st π r v Hot).
+ apply (mem_cast_compat_Untyped) => ?.
+ iIntros "(%sl & %Halg & %Hlen & %Hsl & Hmem)".
+ destruct Hot as [? Hot]. destruct ot as [ | | | sl' ots | ]; try done.
+ destruct Hot as (? & Halg' & Hlen_ots & Hot%Forall_fold_right).
+ assert (sl' = sl) as ->. { by eapply struct_layout_spec_has_layout_inj. }
+ destruct mt.
+ - done.
+ - iExists sl. iSplitR; first done. iSplitR; first done.
+ iSplitR. { rewrite /has_layout_val mem_cast_length. done. }
+ assert (length (field_names (sl_members sl)) = length (sls_fields sls)) as Hlen2.
+ { by eapply struct_layout_spec_has_layout_fields_length. }
+ (* we memcast the value and need to show that it is preserved *)
+ iAssert ⌜∀ i v' n ly,
+ reshape (ly_size <$> (sl_members sl).*2) v !! i = Some v' →
+ sl_members sl !! i = Some (Some n, ly) → v' `has_layout_val` lyâŒ%I as %?. {
+ iIntros (i v' n ly Hv' Hly).
+ (* lookup the corresponding index and type assignment for the member *)
+ have [|rt Hlook]:= lookup_lt_is_Some_2 rts (field_idx_of_idx (sl_members sl) i).
+ { have := field_idx_of_idx_bound sl i _ _ ltac:(done). lia. }
+ edestruct (hpzipl_lookup rts tys r) as [ty [r' Hlook2]]; first done.
+ iDestruct (big_sepL2_lookup with "Hmem") as "Hv"; [done| |].
+ { apply/pad_struct_lookup_Some. { rewrite hpzipl_length Hlen. done. }
+ naive_solver. }
+ (* lookup the ot *)
+ have [|ot ?]:= lookup_lt_is_Some_2 ots (field_idx_of_idx (sl_members sl) i).
+ { have := field_idx_of_idx_bound sl i _ _ ltac:(done). lia. }
+ iDestruct "Hv" as "(%r'' & %ly0 & Hrfn & %Ha & % & Hv)".
+ iPoseProof (ty_has_layout with "Hv") as "(%ly' & %Halg'' & %Hly')".
+ enough (ly' = ly) as ->; first done.
+ assert (ly0 = ly') as -> by by eapply syn_type_has_layout_inj.
+ rewrite Hly in Ha. by injection Ha.
+ }
+ iFrame. iApply (big_sepL2_impl' with "Hmem"); [by rewrite !reshape_length |done|].
+ iIntros "!>" (k v1 ty1 v2 ty2 Hv1 Hty1 Hv2 Hty2) "Hv"; simplify_eq.
+ destruct ty1 as (rt1 & ty1 & r1).
+ rewrite Hty1 in Hty2. injection Hty2 as [= <-].
+ rewrite mem_cast_struct_reshape // in Hv2; last congruence.
+ move: Hv2 => /lookup_zip_with_Some [?[?[?[Hpad Hv']]]]. simplify_eq.
+ rewrite Hv1 in Hv'. simplify_eq.
+ iDestruct "Hv" as "(%r' & % & Hrfn & %Hlook & % & Hv)". iExists r', _. iFrame.
+ move: Hty1 => /pad_struct_lookup_Some[|n[?[Hlook2 Hor1]]].
+ { rewrite hpzipl_length Hlen. done. }
+ move: Hpad => /pad_struct_lookup_Some[|?[?[? Hor2]]]. { rewrite fmap_length. congruence. } simplify_eq.
+ destruct Hor1 as [[??] | [? ?]], Hor2 as [[? Hl] |[? ?]]; simplify_eq.
+ + rewrite list_lookup_fmap in Hl. move: Hl => /fmap_Some[ot [??]]. simplify_eq.
+ iSplitR; first done. iSplitR; first done.
+ iApply ty_memcast_compat_copy; [|done]. destruct n as [n|] => //.
+ (* lookup layout in sl *)
+ (*have [|p ?]:= lookup_lt_is_Some_2 (field_members (sl_members sl)) (field_idx_of_idx (sl_members sl) k).*)
+ (*{ have := field_idx_of_idx_bound sl k _ _ ltac:(done). rewrite field_members_length. lia. }*)
+ move: Hot => /(Forall_lookup_1 _ _ (field_idx_of_idx (sl_members sl) k) (mk_rtype ty1, ot)).
+ (*destruct p as [p ?].*)
+ move => [|??]; last done.
+ apply/lookup_zip_with_Some. eexists _, _. split_and!; [done| |done].
+ (*apply/lookup_zip_with_Some. eexists _, _.*)
+ (*split; first done. split; last done.*)
+ rewrite list_lookup_fmap.
+ match goal with
+ | H : hpzipl rts _ _ !! _ = Some _ |- _ => eapply (hpzipl_lookup_inv_hzipl_pzipl rts tys r) in H as [-> _]
+ end. done.
+ + match goal with | H : existT _ _ = existT _ _ |- _ => rename H into Heq end.
+ apply existT_inj in Heq. subst ty1.
+ iSplitR; first done. iSplitR; first done.
+ iExists _; iPureIntro. split; first done.
+ rewrite /has_layout_val replicate_length.
+ rewrite Hlook2 in Hlook. injection Hlook as [= ->].
+ split; first done. by apply Forall_true.
+ - iPureIntro. done.
+ Qed.
+
+ Global Instance struct_t_ne {rts : list Type} n : Proper ((=) ==> (dist n) ==> (dist n)) (struct_t (rts := rts)).
+ Proof.
+ intros ? sls -> tys1 tys2 Htys.
+ constructor.
+ - move => ot mt /=. rewrite /is_struct_ot. rewrite !fmap_length !hzipl_length.
+ apply and_proper => Hsl.
+ destruct ot as [ | | | sl ots | ly ] => //=.
+ + f_equiv. apply and_proper => Halg. apply and_proper => Hots. rewrite -!Forall_fold_right.
+ erewrite <-struct_layout_spec_has_layout_fields_length in Hsl; last done.
+ rewrite -field_members_length in Hsl.
+ elim: (field_members (sl_members sl)) ots rts tys1 tys2 Htys Hsl Hots => //; csimpl.
+ { intros ots rts tys1 tys2 Heq Hlen. destruct rts; last done.
+ inv_hlist tys1. inv_hlist tys2. intros _ ?. destruct ots; done. }
+ move => [m ?] s IH ots rts tys1 tys2 Htys Hlen1 Hlen2.
+ destruct rts as [ | rt rts]; first done. destruct ots as [ | ot ots]; first done.
+ inv_hlist tys1 => ty1 tys1. inv_hlist tys2 => ty2 tys2.
+ intros Heq.
+ eapply HForallTwo_cons_inv in Heq as [Hty1_ty2 Heq].
+ simplify_eq/=; rewrite !Forall_cons/=; f_equiv.
+ { f_equiv; first apply Hty1_ty2.
+ f_equiv. apply Hty1_ty2. }
+ eapply IH; done.
+ + f_equiv. intros sl. apply and_proper => Halg.
+ apply and_proper => Heq. subst ly.
+ rewrite -!Forall_fold_right.
+ specialize (struct_layout_spec_has_layout_fields_length _ _ Halg) as Hlen.
+ rewrite -field_members_length Hsl in Hlen. clear Hsl.
+ elim: (field_members (sl_members sl)) rts tys1 tys2 Htys Hlen => //; csimpl.
+ { intros rts tys1 tys2 Heq Hlen. destruct rts; last done.
+ inv_hlist tys1; inv_hlist tys2; intros _. done. }
+ move => [m ?] s IH rts tys1 tys2 Heq Hlen.
+ destruct rts as [ | rt rts]; first done.
+ inv_hlist tys1 => ty1 tys1. inv_hlist tys2 => ty2 tys2 Heq.
+ apply HForallTwo_cons_inv in Heq as [Hty1_ty2 Heq].
+ rewrite !Forall_cons/=; f_equiv.
+ { f_equiv; f_equiv; f_equiv; last apply Hty1_ty2.
+ f_equiv; apply Hty1_ty2. }
+ eapply IH; first done. by simplify_eq/=.
+ - iIntros (Ï€ r v). rewrite /ty_own_val/=.
+ f_equiv => sl.
+ apply sep_ne_proper => Halg. apply sep_ne_proper => Hlen.
+ f_equiv.
+ specialize (struct_layout_spec_has_layout_fields_length _ _ Halg) as Hlen2.
+ rewrite -field_members_length -Hlen in Hlen2. clear Hlen.
+ elim: (sl_members sl) rts tys1 tys2 r Htys Hlen2 v => //. intros [m ?] s IH rts tys1 tys2 r Htys Hlen v; csimpl.
+ destruct m; simpl in *.
+ + destruct rts as [ | rt rts]; first done.
+ inv_hlist tys1 => ty1 tys1. inv_hlist tys2 => ty2 tys2.
+ intros [Hty1_ty2 Heq]%HForallTwo_cons_inv.
+ simpl. f_equiv. { do 8 f_equiv; [f_equiv | ]; apply Hty1_ty2. }
+ eapply IH; first done. simpl in Hlen. lia.
+ + f_equiv. eapply IH; done.
+ - iIntros (κ π r l). rewrite /ty_shr /=.
+ f_equiv => sl. apply sep_ne_proper => Halg. apply sep_ne_proper => Hlen.
+ f_equiv.
+ specialize (struct_layout_spec_has_layout_fields_length _ _ Halg) as Hlen2.
+ rewrite -field_members_length -Hlen in Hlen2. clear Hlen.
+ elim: (sl_members sl) rts tys1 tys2 r Htys Hlen2 l => //. intros [m ly] s IH rts tys1 tys2 r Htys Hlen l; csimpl.
+ destruct m; simpl in *.
+ + destruct rts as [ | rt rts]; first done.
+ inv_hlist tys1 => ty1 tys1. inv_hlist tys2 => ty2 tys2.
+ intros [Hty1_ty2 Heq]%HForallTwo_cons_inv.
+ simpl. f_equiv. { do 8 f_equiv; [f_equiv | | ]; apply Hty1_ty2. }
+ cbn. setoid_rewrite <-shift_loc_assoc_nat.
+ eapply IH; first done. simpl in Hlen. lia.
+ + f_equiv. setoid_rewrite <-shift_loc_assoc_nat. apply IH; done.
+ - done.
+ - done.
+ - done.
+ - rewrite /ty_lfts /=.
+ induction rts as [ | rt rts IH] in tys1, tys2, Htys |-*; inv_hlist tys1; inv_hlist tys2; simpl; first done.
+ intros ty2 tys2 ty1 tys1 [Hty1_ty2 Heq]%HForallTwo_cons_inv.
+ f_equiv. { apply Hty1_ty2. }
+ eapply IH; done.
+ - rewrite /ty_wf_E /=.
+ induction rts as [ | rt rts IH] in tys1, tys2, Htys |-*; inv_hlist tys1; inv_hlist tys2; simpl; first done.
+ intros ty2 tys2 ty1 tys1 [Hty1_ty2 Heq]%HForallTwo_cons_inv.
+ f_equiv. { apply Hty1_ty2. }
+ eapply IH; done.
+ Qed.
+ Global Instance struct_t_proper {rts : list Type} : Proper ((=) ==> (≡) ==> (≡)) (struct_t (rts := rts)).
+ Proof.
+ move => ??-> tys1 tys2 Htys.
+ apply equiv_dist. rewrite equiv_dist in Htys. intros n. by rewrite Htys.
+ Qed.
+End structs.
+
+Global Hint Unfold struct_t : tyunfold.
+
+(* TODO Move *)
+Section util.
+ Context `{!typeGS Σ}.
+
+ Lemma reshape_pointsto (sl : struct_layout) v l :
+ v `has_layout_val` sl →
+ l ↦ v ⊢
+ [∗ list] i ↦ v ∈ reshape (ly_size <$> (sl_members sl).*2) v, (l +ₗ offset_of_idx (sl_members sl) i) ↦ v.
+ Proof.
+ rewrite /has_layout_val {1}/ly_size /=.
+ elim: (sl_members sl) l v; first by eauto.
+ intros [m ly] s IH l v Hlen. iIntros "Hpts". simpl in Hlen.
+
+ specialize (take_drop (ly_size ly) v) as Heq.
+ rewrite -Heq heap_mapsto_app.
+ assert (length (take (ly_size ly) v) = ly_size ly) as Hlen2.
+ { rewrite take_length. lia. }
+ iDestruct "Hpts" as "(Hpts1 & Hpts)".
+ iSplitL "Hpts1".
+ { simpl. rewrite shift_loc_0_nat -{2}Hlen2 take_app. done. }
+ rewrite /offset_of_idx. simpl. setoid_rewrite <-shift_loc_assoc_nat.
+ iApply IH.
+ { rewrite drop_length app_length take_length drop_length. unfold fmap. lia. }
+ rewrite Hlen2.
+ rewrite - [X in drop X (_ ++ _)]Hlen2.
+ rewrite drop_app. done.
+ Qed.
+
+ Lemma struct_layout_field_aligned (sl : struct_layout) l :
+ l `has_layout_loc` sl →
+ ∀ k ly,
+ snd <$> sl_members sl !! k = Some ly →
+ l +â‚— offset_of_idx (sl_members sl) k `has_layout_loc` ly.
+ Proof.
+ intros Hl%check_fields_aligned_alt_correct k ly Hlook.
+ elim: (sl_members sl) l Hl k Hlook => //.
+ intros [n ly0] s IH l [Hl0 Hl] k Hlook.
+ rewrite /offset_of_idx.
+ destruct k as [ | k]; simpl in *.
+ { injection Hlook as [= ->]. rewrite shift_loc_0_nat. done. }
+ rewrite -(shift_loc_assoc_nat l).
+ eapply IH; done.
+ Qed.
+
+ Lemma loc_in_bounds_sl_offset sl m k l ly :
+ snd <$> sl_members sl !! k = Some ly →
+ loc_in_bounds l m (ly_size sl) -∗
+ loc_in_bounds (l +â‚— offset_of_idx (sl_members sl) k) 0 (ly_size ly).
+ Proof.
+ iIntros (Hlook).
+ iApply loc_in_bounds_offset.
+ - done.
+ - simpl. rewrite /addr. lia.
+ - rewrite {2}/ly_size /=.
+ elim: (sl_members sl) k l Hlook => //.
+ intros [n ly0] s IH k l Hlook.
+ rewrite /offset_of_idx.
+ destruct k as [ | k]; simpl in *.
+ + injection Hlook as [= ->]. rewrite /addr. lia.
+ + eapply (IH k (l +â‚— (ly_size ly0))) in Hlook.
+ simpl in Hlook. move: Hlook. rewrite /addr /offset_of_idx /fmap. lia.
+ Qed.
+End util.
+
+Section copy.
+ Context `{!typeGS Σ}.
+
+
+ Local Instance struct_t_copy_pers {rts} (tys : hlist type rts) sls :
+ TCHForall (λ _, Copyable) tys →
+ ∀ Ï€ v r, Persistent (v â—áµ¥{Ï€} r @ struct_t sls tys).
+ Proof.
+ iIntros (Hcopy).
+ iIntros (???).
+ apply bi.exist_persistent => sl. apply bi_sep_persistent_pure_l => Halg.
+ apply bi_sep_persistent_pure_l => Hlen. apply bi.sep_persistent; first apply _.
+ apply big_sepL2_persistent_strong => _ k v' [rt [ty r']] Hlook1 Hlook2.
+ apply pad_struct_lookup_Some in Hlook2 as (n & ly & ? & Hlook2); first last.
+ { rewrite hpzipl_length. erewrite struct_layout_spec_has_layout_fields_length; done. }
+ destruct Hlook2 as [[? Hlook2] | [-> Hlook2]].
+ + apply hpzipl_lookup_inv_hzipl_pzipl in Hlook2 as [Hlook21 Hlook22].
+ eapply TCHForall_nth_hzipl in Hcopy; last apply Hlook21.
+ eapply bi.exist_persistent => r0.
+ eapply bi.exist_persistent => ly'.
+ eapply bi.sep_persistent.
+ {
+ (* can I make place_rfn_interp persistent?
+ - in principle I could remove the credit, I think. (I didn't end up needing it IIRC)
+ - for the gvar_auth, make it a persistent element when unblocking.
+ TODO.
+ *)
+ admit.
+ }
+ apply _.
+ + injection Hlook2 => [= ? _] _ _; subst.
+ apply existT_inj in Hlook2 as [= -> ->].
+ simpl. apply _.
+ Admitted.
+
+ Global Instance struct_t_copy {rts} (tys : hlist type rts) sls :
+ TCHForall (λ _, Copyable) tys →
+ Copyable (struct_t sls tys).
+ Proof.
+ iIntros (Hcopy). split; first apply _.
+ iIntros (κ π E F l ly r q ? Halg ?) "#CTX Hshr Hna Htok".
+ rewrite /ty_shr /=.
+ iDestruct "Hshr" as (sl) "(%Halg' & %Hlen & %Hly & #Hb)".
+ simpl in Halg.
+ specialize (use_struct_layout_alg_Some_inv _ _ Halg') as Halg2.
+ assert (ly = sl) as -> by by eapply syn_type_has_layout_inj.
+
+ (* - use the copy lemma for all the element types and eliminate the updates here.
+ - open the fractional borrow
+ - for closing, just close the fractional borrow again
+ TODO: figure out what is the best way to set up the induction
+ *)
+ Abort.
+End copy.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ Import EqNotations.
+ Local Definition struct_t_incl_precond {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 :=
+ ([∗ list] t1; t2 ∈ hpzipl _ tys1 rs1; hpzipl _ tys2 rs2,
+ match (projT2 t1).2, (projT2 t2).2 with
+ | #r1, #r2 => type_incl r1 r2 (projT2 t1).1 (projT2 t2).1
+ | _, _ => ∃ (Heq : projT1 t1 = projT1 t2), ⌜(projT2 t1).2 = rew <-Heq in (projT2 t2).2⌠∗ ∀ (r : projT1 t1), type_incl r (rew [id] Heq in r) (projT2 t1).1 (projT2 t2).1
+ end)%I.
+ Local Instance struct_t_incl_precond_pers {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 :
+ Persistent (struct_t_incl_precond tys1 tys2 rs1 rs2).
+ Proof.
+ apply big_sepL2_persistent. intros ? [? [? []]] [? [? []]]; simpl; apply _.
+ Qed.
+
+ Lemma struct_t_own_val_mono {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 sls v π :
+ struct_t_incl_precond tys1 tys2 rs1 rs2 -∗
+ v â—áµ¥{Ï€} rs1 @ struct_t sls tys1 -∗
+ v â—áµ¥{Ï€} rs2 @ struct_t sls tys2.
+ Proof.
+ iIntros "#Hincl Hv".
+ iPoseProof (big_sepL2_length with "Hincl") as "%Hlen".
+ rewrite !hpzipl_length in Hlen.
+ iDestruct "Hv" as "(%sl & %Halg & %Hlen1 & %Hly & Hb)".
+ iExists sl. iR. rewrite -Hlen. iR. iR.
+ iApply (big_sepL2_impl' with "Hb").
+ { done. }
+ { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k v1 [rt1 [ty1 r1]] v2 [rt2 [ty2 r2]] Hlook_v1 Hlook_ty1 Hlook_v2 Hlook_ty2) "Hv".
+ iDestruct "Hv" as "(%r' & %ly & Hrfn & %Hly' & %Hst' & Hv)".
+ rewrite Hlook_v2 in Hlook_v1. injection Hlook_v1 as ->.
+ apply pad_struct_lookup_Some in Hlook_ty1 as (n & ly' & Hly'' & Hlook_ty1).
+ 2: { rewrite hpzipl_length Hlen1. symmetry. by apply struct_layout_spec_has_layout_fields_length. }
+ rewrite Hly'' in Hly'. injection Hly' as ->.
+ eapply pad_struct_lookup_Some_1' in Hlook_ty2; last done; first last.
+ { rewrite hpzipl_length -Hlen Hlen1. symmetry. by apply struct_layout_spec_has_layout_fields_length. }
+ destruct Hlook_ty1 as [ [? Hlook_ty1] | (-> & Hlook_ty1)]; first last.
+ { (* padding *)
+ destruct Hlook_ty2 as [ [? ?] | [_ Hlook_ty2]]; first congruence.
+ injection Hlook_ty1 => _ _ ?; subst.
+ injection Hlook_ty2 => _ _ ?; subst.
+ apply existT_inj in Hlook_ty1. injection Hlook_ty1 as -> ->.
+ apply existT_inj in Hlook_ty2. injection Hlook_ty2 as -> ->.
+ iExists r', ly. rewrite Hly''. iFrame. done. }
+ (* element *)
+ destruct Hlook_ty2 as [[_ Hlook_ty2] | [? _]]; last congruence.
+ iPoseProof (big_sepL2_lookup with "Hincl") as "Ha"; [apply Hlook_ty1 | apply Hlook_ty2 | ]; simpl.
+ destruct r1 as [r1 | ]; first destruct r2 as [r2 | ].
+ + iDestruct "Hrfn" as "<-".
+ iDestruct "Ha" as "(%Hst & _ & #Ha & _)". iPoseProof ("Ha" with "Hv") as "Hv".
+ rewrite Hly'' -Hst. eauto with iFrame.
+ + iDestruct "Ha" as "(%Heq & %Heq' & Ha)". subst.
+ iDestruct "Hrfn" as "<-". done.
+ + iDestruct "Ha" as "(%Heq & %Heq' & Ha)". subst. cbn in Heq'. subst.
+ iDestruct ("Ha" $! r') as "(%Hst & _ & #Ha' & _)". iPoseProof ("Ha'" with "Hv") as "Hv".
+ rewrite Hly'' -Hst. eauto with iFrame.
+ Qed.
+
+ Lemma struct_t_shr_mono {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 sls l κ π :
+ struct_t_incl_precond tys1 tys2 rs1 rs2 -∗
+ l â—â‚—{Ï€, κ} rs1 @ struct_t sls tys1 -∗
+ l â—â‚—{Ï€, κ} rs2 @ struct_t sls tys2.
+ Proof.
+ iIntros "#Hincl Hl".
+ iPoseProof (big_sepL2_length with "Hincl") as "%Hlen".
+ rewrite !hpzipl_length in Hlen.
+ iDestruct "Hl" as "(%sl & %Halg & %Hlen1 & %Hly & Hb)".
+ iExists sl. iR. rewrite -Hlen. iR. iR.
+ iApply (big_sepL_impl' with "Hb").
+ { rewrite !pad_struct_length //. }
+ iModIntro.
+ iIntros (k [rt1 [ty1 r1]] [rt2 [ty2 r2]] Hlook_ty1 Hlook_ty2) "Hl".
+ iDestruct "Hl" as "(%r' & %ly & Hrfn & %Hly' & %Hst' & #Hsc1 & Hl)".
+ apply pad_struct_lookup_Some in Hlook_ty1 as (n & ly' & Hly'' & Hlook_ty1).
+ 2: { rewrite hpzipl_length Hlen1. symmetry. by apply struct_layout_spec_has_layout_fields_length. }
+ rewrite Hly'' in Hly'. injection Hly' as ->.
+ eapply pad_struct_lookup_Some_1' in Hlook_ty2; last done; first last.
+ { rewrite hpzipl_length -Hlen Hlen1. symmetry. by apply struct_layout_spec_has_layout_fields_length. }
+ destruct Hlook_ty1 as [ [? Hlook_ty1] | (-> & Hlook_ty1)]; first last.
+ { (* padding *)
+ destruct Hlook_ty2 as [ [? ?] | [_ Hlook_ty2]]; first congruence.
+ injection Hlook_ty1 => _ _ ?; subst.
+ injection Hlook_ty2 => _ _ ?; subst.
+ apply existT_inj in Hlook_ty1. injection Hlook_ty1 as -> ->.
+ apply existT_inj in Hlook_ty2. injection Hlook_ty2 as -> ->.
+ iExists r', ly. rewrite Hly''. iFrame. simpl. done. }
+ (* element *)
+ destruct Hlook_ty2 as [[_ Hlook_ty2] | [? _]]; last congruence.
+ iPoseProof (big_sepL2_lookup with "Hincl") as "Ha"; [apply Hlook_ty1 | apply Hlook_ty2 | ]; simpl.
+ destruct r1 as [r1 | ]; first destruct r2 as [r2 | ].
+ + iDestruct "Hrfn" as "<-".
+ iDestruct "Ha" as "(%Hst & #Hsc & _ & #Ha)". iPoseProof ("Ha" with "Hl") as "Hl".
+ iPoseProof ("Hsc" with "Hsc1") as "Hsc2".
+ rewrite Hly'' -Hst. iFrame "#". eauto with iFrame.
+ + iDestruct "Ha" as "(%Heq & %Heq' & Ha)". subst.
+ iDestruct "Hrfn" as "<-". done.
+ + iDestruct "Ha" as "(%Heq & %Heq' & Ha)". subst. cbn in Heq'. subst.
+ iDestruct ("Ha" $! r') as "(%Hst & #Hsc & _ & #Ha')". iPoseProof ("Ha'" with "Hl") as "Hl".
+ iPoseProof ("Hsc" with "Hsc1") as "Hsc2".
+ rewrite Hly'' -Hst. iFrame "#". eauto with iFrame.
+ Qed.
+
+ Lemma struct_t_type_incl {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 sls :
+ struct_t_incl_precond tys1 tys2 rs1 rs2 -∗
+ type_incl rs1 rs2 (struct_t sls tys1) (struct_t sls tys2).
+ Proof.
+ iIntros "#Hincl".
+ iPoseProof (big_sepL2_length with "Hincl") as "%Hlen".
+ rewrite !hpzipl_length in Hlen.
+ iSplitR; first done. iSplitR. { simpl. rewrite Hlen. done. }
+ iSplit; iModIntro.
+ - iIntros (??). by iApply struct_t_own_val_mono.
+ - iIntros (???). by iApply struct_t_shr_mono.
+ Qed.
+
+ Lemma struct_t_full_subtype E L {rts} (tys1 : hlist type rts) (tys2 : hlist type rts) sls :
+ Forall (λ '(existT _ (ty1, ty2)), full_subtype E L ty1 ty2) (hzipl2 _ tys1 tys2) →
+ full_subtype E L (struct_t sls tys1) (struct_t sls tys2).
+ Proof.
+ intros Hsubt r. iIntros (?) "HL #HE".
+ iApply struct_t_type_incl.
+ iApply big_sepL2_forall.
+ { intros ? [? [? []]] [? [? []]]; apply _. }
+ iSplit. { iPureIntro. rewrite !hpzipl_length. done. }
+ iIntros (? [rt1 [ty1 r1]] [rt2 [ty2 r2]] Hlook1 Hlook2); simpl.
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook1) as Hlook1'.
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook2) as Hlook2'.
+ rewrite Hlook2' in Hlook1'. injection Hlook1' as ->.
+ apply hpzipl_lookup_inv_hzipl_pzipl in Hlook1 as (Hlook11 & Hlook12).
+ apply hpzipl_lookup_inv_hzipl_pzipl in Hlook2 as (Hlook21 & Hlook22).
+ rewrite Hlook22 in Hlook12. injection Hlook12 as [= <-%existT_inj].
+ efeed pose proof (hzipl_hzipl2_lookup _ tys1 tys2) as Hlook; [done.. | ].
+ specialize (Forall_lookup_1 _ _ _ _ Hsubt Hlook) as Hx.
+ iPoseProof (full_subtype_acc_noend with "HE HL") as "Ha"; first apply Hx.
+ destruct r2.
+ - iApply "Ha".
+ - iExists eq_refl. iR. done.
+ Qed.
+End subtype.
+
+Section subltype.
+ Context `{!typeGS Σ}.
+ Local Lemma pad_struct_hpzipl_2_inv {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) (rs1 : plist place_rfn rts1) (rs2 : plist place_rfn rts2) sl f k lt1 lt2 :
+ length rts1 = length rts2 →
+ pad_struct (sl_members sl) (hpzipl rts1 lts1 rs1) f !! k = Some lt1 →
+ pad_struct (sl_members sl) (hpzipl rts2 lts2 rs2) f !! k = Some lt2 →
+ (∃ rt1 rt2 lt1' lt2' r1 r2,
+ lt1 = existT rt1 (lt1', r1) ∧ lt2 = existT rt2 (lt2', r2) ∧
+ hpzipl _ lts1 rs1 !! field_idx_of_idx (sl_members sl) k = Some (existT rt1 (lt1', r1)) ∧
+ hpzipl _ lts2 rs2 !! field_idx_of_idx (sl_members sl) k = Some (existT rt2 (lt2', r2))) ∨
+ (∃ ly, lt1 = f ly ∧ lt2 = f ly).
+ Proof.
+ intros Hlen Hlook1 Hlook2.
+ apply pad_struct_lookup_Some_1 in Hlook1.
+ destruct Hlook1 as (n & ly & Hmem & Hlook1).
+ destruct Hlook1 as [ [ ? Hlook1] | Hlook1].
+ - apply pad_struct_lookup_Some_1 in Hlook2.
+ destruct Hlook2 as (n' & ly' & Hmem' & Hlook2). simplify_eq.
+ destruct Hlook2 as [ (_ & Hlook2) | (Hc & _) ]; first last.
+ { destruct Hc as [ | Hc]; first done.
+ exfalso. apply lookup_lt_Some in Hlook1.
+ move: Hc Hlook1. rewrite !hpzipl_length. lia. }
+ destruct lt1 as [rt1 [lt1 r1]]. destruct lt2 as [rt2 [lt2 r2]].
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook1) as Hrt1.
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook2) as Hrt2.
+ left. eauto 10.
+ - destruct Hlook1 as (Hnone & ->).
+ erewrite pad_struct_lookup_field_None_2 in Hlook2; [ | done | reflexivity | ]; first last.
+ { move : Hnone. rewrite !hpzipl_length Hlen. done. }
+ injection Hlook2 as [= <-]. eauto.
+ Qed.
+ Local Lemma pad_struct_hpzipl_2_inv' {rts} (lts1 lts2 : hlist ltype rts) (rs : plist place_rfn rts) sl f k lt1 lt2 :
+ pad_struct (sl_members sl) (hpzipl rts lts1 rs) f !! k = Some lt1 →
+ pad_struct (sl_members sl) (hpzipl rts lts2 rs) f !! k = Some lt2 →
+ (∃ rt lt1' lt2' r,
+ lt1 = existT rt (lt1', r) ∧ lt2 = existT rt (lt2', r) ∧
+ hzipl2 rts lts1 lts2 !! field_idx_of_idx (sl_members sl) k = Some (existT rt (lt1', lt2'))) ∨
+ (∃ ly, lt1 = f ly ∧ lt2 = f ly).
+ Proof.
+ intros Hlook1 Hlook2.
+ apply pad_struct_lookup_Some_1 in Hlook1.
+ destruct Hlook1 as (n & ly & Hmem & Hlook1).
+ destruct Hlook1 as [ [ ? Hlook1] | Hlook1].
+ - apply pad_struct_lookup_Some_1 in Hlook2.
+ destruct Hlook2 as (n' & ly' & Hmem' & Hlook2). simplify_eq.
+ destruct Hlook2 as [ (_ & Hlook2) | (Hc & _) ]; first last.
+ { destruct Hc as [ | Hc]; first done.
+ exfalso. apply lookup_lt_Some in Hlook1.
+ move: Hc Hlook1. rewrite !hpzipl_length. lia. }
+ destruct lt1 as [rt1 [lt1 r1]]. destruct lt2 as [rt2 [lt2 r2]].
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook1) as Hrt1.
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook2) as Hrt2.
+ rewrite Hrt1 in Hrt2. injection Hrt2 as [= <-].
+ specialize (hpzipl_hzipl2_lookup _ _ _ _ _ _ _ _ _ Hlook1 Hlook2) as Hlook. simpl in Hlook.
+ specialize (hpzipl_hpzipl_lookup_2_eq _ _ _ _ _ _ _ _ _ _ Hlook1 Hlook2) as ->.
+ eauto 10.
+ - destruct Hlook1 as (Hnone & ->).
+ erewrite pad_struct_lookup_field_None_2 in Hlook2; [ | done | reflexivity | ]; first last.
+ { move : Hnone. rewrite !hpzipl_length. done. }
+ injection Hlook2 as [= <-]. eauto.
+ Qed.
+
+ Local Lemma struct_ltype_incl'_shared_in {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) κ' rs1 rs2 sls :
+ ([∗ list] lt1; lt2 ∈ hpzipl _ lts1 rs1; hpzipl _ lts2 rs2,
+ ltype_incl (Shared κ') (projT2 lt1).2 (projT2 lt2).2 (projT2 lt1).1 (projT2 lt2).1) -∗
+ ltype_incl' (Shared κ') #rs1 #rs2 (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iPoseProof (big_sepL2_length with "Heq") as "%Hlen".
+ rewrite !hpzipl_length in Hlen.
+ iModIntro.
+ iIntros (Ï€ l).
+ rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hlen1 & %Hly & Hlb & Hb)".
+ iExists sl. iR. rewrite -Hlen. iR. iR. iFrame.
+ iDestruct "Hb" as "(%r' & Hrfn & Hb)". iExists rs2. iFrame.
+ iDestruct "Hb" as "#Hb". iDestruct "Hrfn" as "<-". iSplitR; first done.
+ iModIntro. iMod "Hb". iModIntro.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv _ _ _ _ _ _ _ _ _ Hlen Hlook1 Hlook2) as
+ [ (rt1 & rt2 & lt1' & lt2' & r1 & r2 & -> & -> & Hlook1' & Hlook2') | (ly & -> & ->)]; last by eauto.
+ simpl. iPoseProof (big_sepL2_lookup with "Heq") as "Hb"; [done.. | ]. simpl.
+ iDestruct "Hb" as "(%Hst & #Hb & _)".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ by iApply "Hb".
+ Qed.
+ Lemma struct_ltype_incl_shared_in {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) κ' rs1 rs2 sls :
+ ([∗ list] lt1; lt2 ∈ hpzipl _ lts1 rs1; hpzipl _ lts2 rs2,
+ ltype_incl (Shared κ') (projT2 lt1).2 (projT2 lt2).2 (projT2 lt1).1 (projT2 lt2).1) -∗
+ ltype_incl (Shared κ') #rs1 #rs2 (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply struct_ltype_incl'_shared_in).
+ - done.
+ - rewrite !hpzipl_hmap.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k [rt1 [lt1 r1]] [rt2 [lt2 r2]] ??). simpl. iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma struct_ltype_incl'_shared {rts} (lts1 lts2 : hlist ltype rts) κ' rs sls :
+ (([∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_incl (Shared κ') r r (projT2 ltp).1 (projT2 ltp).2)) -∗
+ ltype_incl' (Shared κ') rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iModIntro.
+ iIntros (Ï€ l).
+ rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hlen & %Hly & Hlb & Hb)".
+ iExists sl. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iFrame.
+ iDestruct "Hb" as "(%r' & Hrfn & Hb)". iExists r'. iFrame.
+ iDestruct "Hb" as "#Hb".
+ iModIntro. iMod "Hb". iModIntro.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv' _ _ _ _ _ _ _ _ Hlook1 Hlook2) as
+ [ (rt & lt1' & lt2' & r & -> & -> & Hlook) | (ly & -> & ->)]; last by eauto.
+ simpl. iPoseProof (big_sepL_lookup with "Heq") as "Hb"; first done. simpl.
+ iDestruct ("Hb" $! r) as "(%Hst & #Hb' & _)".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ by iApply "Hb'".
+ Qed.
+ Lemma struct_ltype_incl_shared {rts} (lts1 lts2 : hlist ltype rts) κ' rs sls :
+ ([∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_incl (Shared κ') r r (projT2 ltp).1 (projT2 ltp).2) -∗
+ ltype_incl (Shared κ') rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply struct_ltype_incl'_shared).
+ - done.
+ - rewrite hzipl2_fmap big_sepL_fmap. iApply (big_sepL_mono with "Heq").
+ iIntros (k [rt [lt1 lt2]] ?). simpl.
+ iIntros "Heq" (r). iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma struct_ltype_incl'_owned_in {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) wl rs1 rs2 sls :
+ ([∗ list] lt1; lt2 ∈ (hpzipl _ lts1 rs1); hpzipl _ lts2 rs2,
+ ltype_incl (Owned false) (projT2 lt1).2 (projT2 lt2).2 (projT2 lt1).1 (projT2 lt2).1) -∗
+ ltype_incl' (Owned wl) #rs1 #rs2 (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iPoseProof (big_sepL2_length with "Heq") as "%Hlen". rewrite !hpzipl_length in Hlen.
+ iModIntro.
+ iIntros (Ï€ l).
+ rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hlen1 & %Hly & Hlb & ? & Hb)".
+ iExists sl. iR. rewrite -Hlen. iR. iR. iFrame.
+ iDestruct "Hb" as "(%r' & <- & Hb)". iExists rs2. iSplitR; first done.
+ iModIntro. iNext. iMod "Hb". rewrite -big_sepL_fupd.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv _ _ _ _ _ _ _ _ _ Hlen Hlook1 Hlook2) as
+ [ (rt1 & rt2 & lt1' & lt2' & r1 & r2 & -> & -> & Hlook1' & Hlook2') | (ly & -> & ->)]; last by eauto.
+ simpl. iPoseProof (big_sepL2_lookup with "Heq") as "Hb"; [done.. | ]. simpl.
+ iDestruct "Hb" as "(%Hst & #Hb & _)".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ by iMod ("Hb" with "Hc").
+ Qed.
+ Lemma struct_ltype_incl_owned_in {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) wl rs1 rs2 sls :
+ ([∗ list] lt1; lt2 ∈ hpzipl _ lts1 rs1; hpzipl _ lts2 rs2,
+ ltype_incl (Owned false) (projT2 lt1).2 (projT2 lt2).2 (projT2 lt1).1 (projT2 lt2).1) -∗
+ ltype_incl (Owned wl) #rs1 #rs2 (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply struct_ltype_incl'_owned_in).
+ - done.
+ - rewrite !hpzipl_hmap.
+ rewrite big_sepL2_fmap_l big_sepL2_fmap_r.
+ iApply (big_sepL2_mono with "Heq").
+ iIntros (k [rt1 [lt1 r1]] [rt2 [lt2 r2]] ??). simpl. iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma struct_ltype_incl'_owned {rts} (lts1 lts2 : hlist ltype rts) wl rs sls :
+ (([∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_incl (Owned false) r r (projT2 ltp).1 (projT2 ltp).2)) -∗
+ ltype_incl' (Owned wl) rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iModIntro.
+ iIntros (Ï€ l).
+ rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hlen & %Hly & Hlb & ? & Hb)".
+ iExists sl. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iFrame.
+ iDestruct "Hb" as "(%r' & Hrfn & Hb)". iExists r'. iFrame.
+ iModIntro. iNext. iMod "Hb". rewrite -big_sepL_fupd.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv' _ _ _ _ _ _ _ _ Hlook1 Hlook2) as
+ [ (rt & lt1' & lt2' & r & -> & -> & Hlook) | (ly & -> & ->)]; last by eauto.
+ simpl. iPoseProof (big_sepL_lookup with "Heq") as "Hb"; first done. simpl.
+ iDestruct ("Hb" $! r) as "(%Hst & #Hb' & _)".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ by iApply "Hb'".
+ Qed.
+ Lemma struct_ltype_incl_owned {rts} (lts1 lts2 : hlist ltype rts) wl rs sls :
+ ([∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_incl (Owned false) r r (projT2 ltp).1 (projT2 ltp).2) -∗
+ ltype_incl (Owned wl) rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply struct_ltype_incl'_owned).
+ - done.
+ - rewrite hzipl2_fmap big_sepL_fmap. iApply (big_sepL_mono with "Heq").
+ iIntros (k [rt [lt1 lt2]] ?). simpl.
+ iIntros "Heq" (r). iApply ltype_incl_core; done.
+ Qed.
+
+ Local Lemma struct_ltype_incl'_uniq {rts} (lts1 lts2 : hlist ltype rts) κ γ rs sls :
+ (([∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_eq (Owned false) r r (projT2 ltp).1 (projT2 ltp).2)) -∗
+ ltype_incl' (Uniq κ γ) rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iModIntro.
+ iIntros (Ï€ l).
+ rewrite !ltype_own_struct_unfold /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hlen & %Hly & Hlb & ? & ? & Hrfn & Hb)".
+ iExists sl. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iFrame.
+ iMod "Hb". iModIntro. iApply (pinned_bor_iff with "[] [] Hb").
+ + iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame. iMod "Hb" as "Hb".
+ iApply big_sepL_fupd.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv' _ _ _ _ _ _ _ _ Hlook1 Hlook2) as
+ [ (rt & lt1' & lt2' & r0 & -> & -> & Hlook) | (ly & -> & ->)]; last by eauto.
+ simpl.
+ iPoseProof (big_sepL_lookup with "Heq") as "Hb"; first done. simpl.
+ iDestruct ("Hb" $! _) as "((%Hst & #Hb' & _) & _)".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ by iApply "Hb'".
+ * iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame. iMod "Hb" as "Hb".
+ iApply big_sepL_fupd.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv' _ _ _ _ _ _ _ _ Hlook2 Hlook1) as
+ [ (rt & lt1' & lt2' & r0 & -> & -> & Hlook) | (ly & -> & ->)]; last by eauto.
+ simpl.
+ iPoseProof (big_sepL_lookup with "Heq") as "Hb"; first done. simpl.
+ iDestruct ("Hb" $! _) as "(_ & (%Hst & #Hb' & _))".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ by iApply "Hb'".
+ + iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame. iMod "Hb" as "Hb".
+ iApply big_sepL_fupd.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv' _ _ _ _ _ _ _ _ Hlook1 Hlook2) as
+ [ (rt & lt1' & lt2' & r0 & -> & -> & Hlook) | (ly & -> & ->)]; last by eauto.
+ simpl.
+ iPoseProof (big_sepL_lookup with "Heq") as "Hb"; first done. simpl.
+ iDestruct ("Hb" $! _) as "((%Hst & _ & #Hb') & _)".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ rewrite !ltype_own_core_equiv. by iApply "Hb'".
+ * iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame. iMod "Hb" as "Hb".
+ iApply big_sepL_fupd.
+ iApply (big_sepL_impl' with "Hb"). { rewrite !pad_struct_length //. }
+ iModIntro. iIntros (k lt1 lt2 Hlook1 Hlook2).
+ destruct (pad_struct_hpzipl_2_inv' _ _ _ _ _ _ _ _ Hlook2 Hlook1) as
+ [ (rt & lt1' & lt2' & r0 & -> & -> & Hlook) | (ly & -> & ->)]; last by eauto.
+ simpl.
+ iPoseProof (big_sepL_lookup with "Heq") as "Hb"; first done. simpl.
+ iDestruct ("Hb" $! _) as "(_ & (%Hst & _ & #Hb'))".
+ iIntros "(%ly & ? & ? & Hc)". iExists ly. rewrite Hst. iFrame.
+ rewrite !ltype_own_core_equiv. by iApply "Hb'".
+ Qed.
+ Lemma struct_ltype_incl_uniq {rts} (lts1 lts2 : hlist ltype rts) κ γ rs sls :
+ ([∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_eq (Owned false) r r (projT2 ltp).1 (projT2 ltp).2) -∗
+ ltype_incl (Uniq κ γ) rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply struct_ltype_incl'_uniq).
+ - done.
+ - rewrite hzipl2_fmap big_sepL_fmap. iApply (big_sepL_mono with "Heq").
+ iIntros (k [rt [lt1 lt2]] ?). simpl.
+ iIntros "Heq" (r). iApply ltype_eq_core; done.
+ Qed.
+
+ Lemma struct_ltype_incl {rts} (lts1 lts2 : hlist ltype rts) k rs sls :
+ (∀ k, [∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_eq k r r (projT2 ltp).1 (projT2 ltp).2) -∗
+ ltype_incl k rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ destruct k.
+ - iApply (struct_ltype_incl_owned lts1 lts2) .
+ iApply (big_sepL_wand with "Heq"). iApply big_sepL_intro.
+ iIntros "!>" (? [rt [lt1 lt2]] ?) "Ha". iIntros (r).
+ iDestruct ("Ha" $! r) as "[$ _]".
+ - iApply struct_ltype_incl_shared.
+ iApply (big_sepL_wand with "Heq"). iApply big_sepL_intro.
+ iIntros "!>" (? [rt [lt1 lt2]] ?) "Ha". iIntros (r).
+ iDestruct ("Ha" $! r) as "[$ _]".
+ - iApply struct_ltype_incl_uniq. done.
+ Qed.
+ Lemma struct_ltype_eq {rts} (lts1 lts2 : hlist ltype rts) k rs sls :
+ (∀ k, [∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_eq k r r (projT2 ltp).1 (projT2 ltp).2) -∗
+ ltype_eq k rs rs (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ iIntros "#Heq".
+ iSplit.
+ - iApply (struct_ltype_incl lts1 lts2); done.
+ - iApply struct_ltype_incl. iIntros (k').
+ iSpecialize ("Heq" $! k').
+ rewrite hzipl2_swap big_sepL_fmap.
+ iApply (big_sepL_wand with "Heq").
+ iApply big_sepL_intro. iIntros "!>" (? [? []] ?) "Heq'".
+ iIntros (?). iApply ltype_eq_sym. done.
+ Qed.
+
+ Lemma struct_full_subltype E L {rts} (lts1 lts2 : hlist ltype rts) sls :
+ Forall (λ lts, full_eqltype E L (projT2 lts).1 (projT2 lts).2) (hzipl2 rts lts1 lts2) →
+ full_subltype E L (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ intros Hsub.
+ iIntros (qL) "HL #CTX #HE".
+ iAssert (∀ k, [∗ list] ltp ∈ (hzipl2 rts lts1 lts2),
+ ∀ r, ltype_eq k r r (projT2 ltp).1 (projT2 ltp).2)%I with "[HL]" as "#Heq".
+ { iIntros (k). iInduction rts as [ | rt rts] "IH"; first done.
+ inv_hlist lts1 => lt1 lts1. inv_hlist lts2 => lt2 lts2.
+ rewrite hzipl2_cons. rewrite Forall_cons.
+ intros [Heq Heqs].
+ iPoseProof (Heq with "HL CTX HE") as "#Heq".
+ iPoseProof ("IH" with "[//] HL") as "Heqs".
+ iApply big_sepL_cons. iFrame. done.
+ }
+ iIntros (k r). iApply (struct_ltype_incl lts1 lts2). done.
+ Qed.
+ Lemma struct_full_eqltype E L {rts} (lts1 lts2 : hlist ltype rts) sls :
+ Forall (λ lts, full_eqltype E L (projT2 lts).1 (projT2 lts).2) (hzipl2 rts lts1 lts2) →
+ full_eqltype E L (StructLtype lts1 sls) (StructLtype lts2 sls).
+ Proof.
+ intros Hsub.
+ apply full_subltype_eqltype. { by apply (struct_full_subltype _ _ lts1 lts2). }
+ apply (struct_full_subltype _ _ lts2 lts1).
+ rewrite hzipl2_swap. rewrite Forall_fmap.
+ eapply Forall_impl; first done.
+ intros [rt []]; naive_solver.
+ Qed.
+End subltype.
+
+Section unfold.
+ Context `{!typeGS Σ}.
+ Lemma struct_t_unfold_1_owned {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) wl r :
+ ⊢ ltype_incl' (Owned wl) r r (◠(struct_t sls tys))%I (StructLtype (hmap (λ _, OfTy) tys) sls).
+ Proof.
+ iModIntro. iIntros (Ï€ l).
+ rewrite ltype_own_struct_unfold ltype_own_ofty_unfold /lty_of_ty_own /struct_ltype_own.
+ iIntros "(%ly & %Halg & %Hly & %Hsc & #Hlb & ? & %r' & Hrfn & Hv)".
+ eapply use_layout_alg_struct_Some_inv in Halg as (sl & Halg & ->).
+ (*assert (ly = sl) as ->. { eapply syn_type_has_layout_inj; first done.*)
+ (*eapply use_struct_layout_alg_Some_inv. done. }*)
+ iExists sl. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done.
+ iSplitR; first done.
+ iFrame. iExists r'. iFrame.
+ iModIntro. iNext. iMod "Hv" as "(%v & Hl & Hv)".
+ iDestruct "Hv" as "(%sl' & %Halg' & _ & %Hly' & Hb)".
+ assert (sl' = sl) as ->. { by eapply struct_layout_spec_has_layout_inj. }
+ rewrite hpzipl_hmap.
+ set (f := (λ '(existT x (a, b)), existT x (◠a, b))%I).
+ rewrite (pad_struct_ext _ _ _ (λ ly, f (existT (unit : Type) (uninit (UntypedSynType ly), PlaceIn ())))); last done.
+ rewrite pad_struct_fmap big_sepL_fmap.
+ rewrite reshape_pointsto; last done.
+ iPoseProof (big_sepL2_sep_sepL_l with "[$Hl $Hb]") as "Ha".
+
+ iAssert ([∗ list] k↦ _;y ∈ reshape (ly_size <$> (sl_members sl).*2) v; pad_struct (sl_members sl) (hpzipl rts tys r') (λ ly : layout, existT (unit : Type) (uninit (UntypedSynType ly), PlaceIn ())), |={lftE}=> ∃ ly : layout, ⌜snd <$> sl_members sl !! k = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 (f y)).1) ly⌠∗ ltype_own (projT2 (f y)).1 (Owned false) π (projT2 (f y)).2 (l +ₗ offset_of_idx (sl_members sl) k))%I with "[-]" as "Hs"; first last.
+ { rewrite big_sepL2_const_sepL_r. rewrite big_sepL_fupd. iDestruct "Hs" as "[_ $]". }
+
+ iApply (big_sepL2_wand with "Ha").
+ iApply big_sepL2_intro.
+ { rewrite reshape_length pad_struct_length fmap_length fmap_length //. }
+ iIntros "!>" (k w [rt [ty r0]] Hlook1 Hlook2) => /=.
+ iIntros "(Hl & %r0' & %ly & Hrfn & %Hmem & %st & Hty)".
+ iExists ly. iSplitR; first done. simp_ltypes.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iSplitR; first done.
+ iExists ly. iSplitR; first done.
+ iSplitR. { iPureIntro. eapply struct_layout_field_aligned; done. }
+ iPoseProof (ty_own_val_sidecond with "Hty") as "#$".
+ iSplitR. { iApply loc_in_bounds_sl_offset; done. }
+ iSplitR; first done.
+ iExists _. iFrame. iModIntro. iNext. iModIntro. iExists w. iFrame.
+ Qed.
+
+ Lemma struct_t_unfold_1_shared {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) κ r :
+ ⊢ ltype_incl' (Shared κ) r r (◠(struct_t sls tys))%I (StructLtype (hmap (λ _, OfTy) tys) sls).
+ Proof.
+ iModIntro. iIntros (Ï€ l).
+ rewrite ltype_own_struct_unfold ltype_own_ofty_unfold /lty_of_ty_own /struct_ltype_own.
+ iIntros "(%ly & %Halg & %Hly & %Hsc & #Hlb & %r' & Hrfn & #Hb)".
+ apply use_layout_alg_struct_Some_inv in Halg as (sl & Halg & ->).
+ iExists sl. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done. iFrame "Hlb".
+ iExists r'. iFrame "Hrfn". iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%sl' & %Halg' & _ & %Hly' & Hb)".
+ assert (sl' = sl) as ->. { by eapply struct_layout_spec_has_layout_inj. }
+
+ rewrite hpzipl_hmap.
+ set (f := (λ '(existT x (a, b)), existT x (◠a, b))%I).
+ rewrite (pad_struct_ext _ _ _ (λ ly, f (existT (unit : Type) (uninit (UntypedSynType ly), PlaceIn ())))); last done.
+ rewrite pad_struct_fmap big_sepL_fmap.
+ iModIntro. iApply (big_sepL_wand with "Hb").
+ iApply big_sepL_intro. iIntros "!>" (k [rt0 [ty0 r0]] Hlook).
+ iIntros "(%r0' & %ly & Hrfn & %Hmem & %Hst & #Hsc & #Hb)".
+ iExists ly. iSplitR; first done. iSplitR; first done.
+ simpl in *. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iSplitR; first done.
+ iSplitR.
+ { iPureIntro. eapply struct_layout_field_aligned; done. }
+ iSplitR; first done.
+ iSplitR. { iApply loc_in_bounds_sl_offset; done. }
+ iExists r0'. iFrame "Hrfn". iModIntro. iModIntro. done.
+ Qed.
+
+ (* The lemma stating the main unfolding condition for the Uniq case *)
+ Local Lemma unfold_case_uniq {rts} π (tys : hlist type rts) sls sl l γ wl (b : bool) :
+ wl = false →
+ use_struct_layout_alg sls = Some sl →
+ l `has_layout_loc` sl →
+ length rts = length (sls_fields sls) →
+ ⊢ loc_in_bounds l 0 (ly_size sl) -∗
+ (∃ r' : plist place_rfn rts, gvar_auth γ r' ∗
+ (|={lftE}=> ∃ v : val, l ↦ v ∗ v â—áµ¥{ Ï€} r' @ struct_t sls tys)) ↔
+ (∃ r' : plist place_rfn rts, gvar_auth γ r' ∗ (|={lftE}=>
+ [∗ list] i↦ty ∈ pad_struct (sl_members sl) (hpzipl rts ((λ X : Type, OfTy) +<$> tys) r') (λ ly : layout, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗
+ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx (sl_members sl) i) â—â‚—[ Ï€, Owned wl] (projT2 ty).2 @ if b then ltype_core (projT2 ty).1 else (projT2 ty).1)).
+ Proof.
+ intros -> Hst Hly Hsc. iIntros "#Hlb".
+ iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iDestruct "Hb" as ">(%v & Hl & Hb)".
+ iApply big_sepL_fupd.
+ iDestruct "Hb" as "(%sl' & %Halg & %Hlen & %Hly' & Hb)".
+ assert (sl' = sl) as ->. { by eapply struct_layout_spec_has_layout_inj. }
+ rewrite hpzipl_hmap.
+ set (f := (λ '(existT x (a, b)), existT x (◠a, b))%I).
+ rewrite (pad_struct_ext _ _ _ (λ ly, f (existT (unit : Type) (uninit (UntypedSynType ly), PlaceIn ())))); last done.
+ rewrite pad_struct_fmap big_sepL_fmap.
+ rewrite reshape_pointsto; last done.
+ iPoseProof (big_sepL2_sep_sepL_l with "[$Hl $Hb]") as "Ha".
+
+ iAssert ([∗ list] k↦ _;y ∈ reshape (ly_size <$> (sl_members sl).*2) v; pad_struct (sl_members sl) (hpzipl rts tys r') (λ ly : layout, existT (unit : Type) (uninit (UntypedSynType ly), PlaceIn ())), |={lftE}=> ∃ ly : layout, ⌜snd <$> sl_members sl !! k = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 (f y)).1) ly⌠∗ ltype_own (if b then ltype_core (projT2 (f y)).1 else (projT2 (f y)).1) (Owned false) π (projT2 (f y)).2 (l +ₗ offset_of_idx (sl_members sl) k))%I with "[-]" as "Hs"; first last.
+ { rewrite big_sepL2_const_sepL_r. iDestruct "Hs" as "[_ $]". }
+
+ iApply (big_sepL2_wand with "Ha").
+ iApply big_sepL2_intro.
+ { rewrite reshape_length pad_struct_length fmap_length fmap_length //. }
+ iIntros "!>" (k w [rt [ty r0]] Hlook1 Hlook2) => /=.
+ iIntros "(Hl & %r0' & %ly & Hrfn & %Hmem & %st & Hty)".
+ iExists ly. iSplitR; first done. simp_ltypes.
+ rewrite Tauto.if_same.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iSplitR; first done.
+ iExists ly. iSplitR; first done.
+ iSplitR. { iPureIntro. eapply struct_layout_field_aligned; done. }
+ iPoseProof (ty_own_val_sidecond with "Hty") as "#$".
+ iSplitR. { iApply loc_in_bounds_sl_offset; done. }
+ iSplitR; first done.
+ iExists _. iFrame. iModIntro. iModIntro. iExists w. iFrame.
+ * iIntros "(%r' & Hauth & Hb)". iExists r'. iFrame "Hauth".
+ iMod "Hb".
+ specialize (struct_layout_field_aligned _ _ Hly) as Hfield_ly.
+ (* generalize sl_members before initiating induction *)
+ rewrite /ty_own_val /=.
+ setoid_rewrite bi.sep_exist_l. rewrite bi_exist_comm.
+ iExists sl. iFrame "%".
+ rewrite /has_layout_val {1 2}/ly_size {1 2}/layout_of /=.
+ specialize (struct_layout_spec_has_layout_fields_length _ _ Hst).
+ remember (sl_members sl) as slm eqn:Heqslm.
+ remember (sls_fields sls) as slsm eqn:Heqslsm.
+ clear Heqslsm Heqslm Hst sls sl Hly => Hlen.
+
+ iInduction (slm) as [ | [m ly] slm] "IH" forall (l slsm rts tys r' Hlen Hsc Hfield_ly); simpl.
+ { iExists [].
+ iSplitR. { iApply heap_mapsto_nil. iApply loc_in_bounds_shorten_suf; last done. lia. }
+ iSplitR; first done. done. }
+ rewrite -Hsc in Hlen.
+ iDestruct "Hb" as "(Hb0 & Hb)".
+ destruct m as [ m | ].
+ -- simpl in Hlen. destruct rts as [ | rt rts]; first done.
+ simpl in Hsc, Hlen. destruct slsm as [ | st slsm]; first done.
+ inv_hlist tys => ty tys. destruct r' as [r0 r]. simpl.
+ (* use the IH *)
+ iSpecialize ("IH" $! (l +â‚— ly_size ly) slsm rts tys r).
+ simpl in *.
+ iSpecialize ("IH" with "[] [] [] [] [Hb]").
+ { iPureIntro. lia. }
+ { iPureIntro. lia. }
+ { iPureIntro. intros k ly' Hlook.
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eapply (Hfield_ly (S k)). done. }
+ { iModIntro.
+ iApply loc_in_bounds_offset; last done.
+ - done.
+ - simpl. rewrite /addr. lia.
+ - simpl. rewrite /fmap /addr. lia. }
+ { iApply (big_sepL_wand with "Hb"). iApply big_sepL_intro.
+ iIntros "!>" (k [rt1 [lt1 r1]] Hlook).
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eauto. }
+ iMod "IH" as "(%v1 & Hl1 & %Hv1_len & Hb)".
+ (* destruct the head *)
+ iDestruct "Hb0" as "(%ly0 & %Heq0 & %Halg0 & Hb0)".
+ injection Heq0 as [= <-].
+ simp_ltypes. rewrite Tauto.if_same.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb0" as "(%ly0 & %Hst0 & %Hly0 & Hsc0 & Hlb0 & _ & %r0' & Hrfn0 & Hb0)".
+ (* TODO need the v also under there. *)
+ iMod "Hb0" as "(%v0 & Hl0 & Hb0)".
+ move: Halg0. simp_ltypes. intros Halg0.
+ assert (ly0 = ly) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hb0") as "#%Hly0'"; first done.
+ iExists (v0 ++ v1). rewrite heap_mapsto_app.
+ iSplitL "Hl0 Hl1".
+ { rewrite /offset_of_idx. simpl. rewrite shift_loc_0_nat. iFrame "Hl0".
+ rewrite Hly0'. done. }
+ iSplitR. { iPureIntro. rewrite app_length Hv1_len Hly0'. done. }
+ iSplitL "Hb0 Hrfn0".
+ { iExists _, ly. iFrame. iSplitR; first done. iSplitR; first done.
+ rewrite -Hly0'. rewrite take_app. done. }
+ rewrite -Hly0'. rewrite drop_app. done.
+ -- simpl in Hlen. simpl.
+ (* use the iH *)
+ iSpecialize ("IH" $! (l +â‚— ly_size ly) slsm rts tys r').
+ simpl in *.
+ iSpecialize ("IH" with "[] [] [] [] [Hb]").
+ { iPureIntro. lia. }
+ { iPureIntro. lia. }
+ { iPureIntro. intros k ly' Hlook.
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eapply (Hfield_ly (S k)). done. }
+ { iModIntro.
+ iApply loc_in_bounds_offset; last done.
+ - done.
+ - simpl. rewrite /addr. lia.
+ - simpl. rewrite /fmap /addr. lia. }
+ { iApply (big_sepL_wand with "Hb"). iApply big_sepL_intro.
+ iIntros "!>" (k [rt1 [lt1 r1]] Hlook).
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eauto. }
+ iMod "IH" as "(%v1 & Hl1 & %Hv1_len & Hb)".
+ (* destruct the head *)
+ iDestruct "Hb0" as "(%ly0 & %Heq0 & %Halg0 & Hb0)".
+ injection Heq0 as [= <-].
+ rewrite /UninitLtype. simp_ltypes. rewrite Tauto.if_same.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb0" as "(%ly0 & %Hst0 & %Hly0 & Hsc0 & Hlb0 & _ & %r0' & Hrfn0 & >(%v0 & Hl0 & Hb0))".
+ move: Halg0. simp_ltypes. intros Halg0.
+ assert (ly0 = ly) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hb0") as "#%Hly0'"; first done.
+ iExists (v0 ++ v1). rewrite heap_mapsto_app.
+ iSplitL "Hl0 Hl1".
+ { rewrite /offset_of_idx. simpl. rewrite shift_loc_0_nat. iFrame "Hl0".
+ rewrite Hly0'. done. }
+ iSplitR. { iPureIntro. rewrite app_length Hv1_len Hly0'. done. }
+ iSplitL "Hb0 Hrfn0".
+ { iExists _, ly. iFrame. iSplitR; first done. iSplitR; first done.
+ rewrite -Hly0'. rewrite take_app. done. }
+ rewrite -Hly0'. rewrite drop_app. done.
+ Qed.
+
+ Lemma struct_t_unfold_1_uniq {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) κ γ r :
+ ⊢ ltype_incl' (Uniq κ γ) r r (◠(struct_t sls tys))%I (StructLtype (hmap (λ _, OfTy) tys) sls).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_struct_unfold ltype_own_ofty_unfold /lty_of_ty_own /struct_ltype_own.
+ iIntros "(%ly & %Hst & %Hly & %Hsc & #Hlb & Hrfn & ? & ? & Hb)". simpl in Hst.
+ apply use_layout_alg_struct_Some_inv in Hst as (sl & Hst & ->).
+ iExists sl. iSplitR; first done.
+ (* NOTE: here we really need the ty_sidecond; we would not be able to just extract this info out from under the borrow! *)
+ iSplitR. { rewrite Hsc. done. }
+ iSplitR; first done.
+ iSplitR; first done.
+ iFrame. iMod "Hb". iModIntro.
+ setoid_rewrite ltype_own_core_equiv.
+ iApply (pinned_bor_iff with "[] [] Hb").
+ + iNext. iModIntro.
+ iPoseProof (unfold_case_uniq _ _ _ _ _ _ false false with "Hlb") as "[Ha1 Ha2]"; [reflexivity | done.. | ].
+ iSplit; done.
+ + iNext. iModIntro.
+ iPoseProof (unfold_case_uniq _ _ _ _ _ _ false true with "Hlb") as "[Ha1 Ha2]"; [reflexivity | done.. | ].
+ iSplit; done.
+ Qed.
+
+ Local Lemma struct_t_unfold_1' {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) k r :
+ ⊢ ltype_incl' k r r (◠(struct_t sls tys))%I (StructLtype (hmap (λ _, OfTy) tys) sls).
+ Proof.
+ destruct k.
+ - iApply struct_t_unfold_1_owned.
+ - iApply struct_t_unfold_1_shared.
+ - iApply struct_t_unfold_1_uniq.
+ Qed.
+
+ Local Lemma ltype_core_hmap_ofty {rts : list Type} (tys : hlist type rts) :
+ @ltype_core _ _ +<$> ((λ _, OfTy) +<$> tys) = ((λ _, OfTy) +<$> tys).
+ Proof.
+ induction tys as [ | rt rts ty tys IH]; simpl; first done. f_equiv. { simp_ltypes. done. } eapply IH.
+ Qed.
+
+ Lemma struct_t_unfold_1 {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) k r :
+ ⊢ ltype_incl k r r (◠(struct_t sls tys))%I (StructLtype (hmap (λ _, OfTy) tys) sls).
+ Proof.
+ iSplitR; first done. iModIntro. iSplit.
+ + iApply struct_t_unfold_1'.
+ + simp_ltypes. rewrite ltype_core_hmap_ofty. by iApply struct_t_unfold_1'.
+ Qed.
+
+ Lemma struct_t_unfold_2_owned {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) wl r :
+ ⊢ ltype_incl' (Owned wl) r r (StructLtype (hmap (λ _, OfTy) tys) sls) (◠(struct_t sls tys))%I.
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_struct_unfold ltype_own_ofty_unfold /lty_of_ty_own /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hsc & %Hly & #Hlb & ? & %r' & Hrfn & Hb)".
+ iExists sl. iSplitR. { iPureIntro. eapply use_struct_layout_alg_Some_inv. done. }
+ iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iModIntro. iFrame. iExists r'. iFrame "Hrfn".
+ iNext. iMod "Hb".
+ specialize (struct_layout_field_aligned _ _ Hly) as Hfield_ly.
+ (* generalize *)
+ (* TODO mostly duplicated with the Uniq lemma above *)
+ rewrite /ty_own_val /=.
+ setoid_rewrite bi.sep_exist_l. rewrite bi_exist_comm.
+ iExists sl. symmetry in Hsc. iFrame "%".
+ rewrite /has_layout_val {1 2}/ly_size {1 2}/layout_of /=.
+ specialize (struct_layout_spec_has_layout_fields_length _ _ Halg).
+ remember (sl_members sl) as slm eqn:Heqslm.
+ remember (sls_fields sls) as slsm eqn:Heqslsm.
+ clear Heqslsm Heqslm Halg sls r sl Hly => Hlen.
+
+ iInduction (slm) as [ | [m ly] slm] "IH" forall (l slsm rts tys r' Hsc Hlen Hfield_ly); simpl.
+ { iExists [].
+ iSplitR. { iApply heap_mapsto_nil. iApply loc_in_bounds_shorten_suf; last done. lia. }
+ iSplitR; first done. iModIntro. done. }
+ rewrite -Hsc in Hlen.
+ iDestruct "Hb" as "(Hb0 & Hb)".
+ destruct m as [ m | ].
+ -- simpl in Hlen. destruct rts as [ | rt rts]; first done.
+ simpl in Hsc, Hlen. destruct slsm as [ | st slsm]; first done.
+ inv_hlist tys => ty tys. destruct r' as [r0 r]. simpl.
+ (* use the IH *)
+ iSpecialize ("IH" $! (l +â‚— ly_size ly) slsm rts tys r).
+ simpl in *.
+ iSpecialize ("IH" with "[] [] [] [] [Hb]").
+ { iPureIntro. lia. }
+ { iPureIntro. lia. }
+ { iPureIntro. intros k ly' Hlook.
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eapply (Hfield_ly (S k)). done. }
+ { iModIntro.
+ iApply loc_in_bounds_offset; last done.
+ - done.
+ - simpl. rewrite /addr. lia.
+ - simpl. rewrite /fmap /addr. lia. }
+ { iApply (big_sepL_wand with "Hb"). iApply big_sepL_intro.
+ iIntros "!>" (k [rt1 [lt1 r1]] Hlook).
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eauto. }
+ iMod "IH".
+ iDestruct "IH" as "(%v1 & Hl1 & %Hv1_len & Hb)".
+ (* destruct the head *)
+ iDestruct "Hb0" as "(%ly0 & %Heq0 & %Halg0 & Hb0)".
+ injection Heq0 as [= <-].
+ simp_ltypes.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb0" as "(%ly0 & %Hst0 & %Hly0 & Hsc0 & Hlb0 & _ & %r0' & Hrfn0 & >(%v0 & Hl0 & Hb0))".
+ move: Halg0. simp_ltypes. intros Halg0.
+ assert (ly0 = ly) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hb0") as "#%Hly0'"; first done.
+ iModIntro.
+ iExists (v0 ++ v1). rewrite heap_mapsto_app.
+ iSplitL "Hl0 Hl1".
+ { rewrite /offset_of_idx. simpl. rewrite shift_loc_0_nat. iFrame "Hl0".
+ rewrite Hly0'. done. }
+ iSplitR. { iPureIntro. rewrite app_length Hv1_len Hly0'. done. }
+ iSplitL "Hb0 Hrfn0".
+ { iExists _, ly. iFrame. iSplitR; first done. iSplitR; first done.
+ rewrite -Hly0'. rewrite take_app. done. }
+ rewrite -Hly0'. rewrite drop_app. done.
+ -- simpl in Hlen. simpl.
+ (* use the iH *)
+ iSpecialize ("IH" $! (l +â‚— ly_size ly) slsm rts tys r').
+ simpl in *.
+ iSpecialize ("IH" with "[] [] [] [] [Hb]").
+ { iPureIntro. lia. }
+ { iPureIntro. lia. }
+ { iPureIntro. intros k ly' Hlook.
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eapply (Hfield_ly (S k)). done. }
+ { iModIntro.
+ iApply loc_in_bounds_offset; last done.
+ - done.
+ - simpl. rewrite /addr. lia.
+ - simpl. rewrite /fmap /addr. lia. }
+ { iApply (big_sepL_wand with "Hb"). iApply big_sepL_intro.
+ iIntros "!>" (k [rt1 [lt1 r1]] Hlook).
+ rewrite shift_loc_assoc.
+ replace ((ly_size ly + offset_of_idx slm k)%Z) with (Z.of_nat (ly_size ly + offset_of_idx slm k)%nat)by lia.
+ eauto. }
+ iMod "IH".
+ iDestruct "IH" as "(%v1 & Hl1 & %Hv1_len & Hb)".
+ (* destruct the head *)
+ iDestruct "Hb0" as "(%ly0 & %Heq0 & %Halg0 & Hb0)".
+ injection Heq0 as [= <-].
+ rewrite /UninitLtype. simp_ltypes.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb0" as "(%ly0 & %Hst0 & %Hly0 & Hsc0 & Hlb0 & _ & %r0' & Hrfn0 & >(%v0 & Hl0 & Hb0))".
+ move: Halg0. simp_ltypes. intros Halg0.
+ assert (ly0 = ly) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hb0") as "#%Hly0'"; first done.
+ iExists (v0 ++ v1). rewrite heap_mapsto_app.
+ iSplitL "Hl0 Hl1".
+ { rewrite /offset_of_idx. simpl. rewrite shift_loc_0_nat. iFrame "Hl0".
+ rewrite Hly0'. done. }
+ iSplitR. { iPureIntro. rewrite app_length Hv1_len Hly0'. done. }
+ iSplitL "Hb0 Hrfn0".
+ { iExists _, ly. iFrame. iSplitR; first done. iSplitR; first done.
+ rewrite -Hly0'. rewrite take_app. done. }
+ rewrite -Hly0'. rewrite drop_app. done.
+ Qed.
+ Lemma struct_t_unfold_2_shared {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) κ r :
+ ⊢ ltype_incl' (Shared κ) r r (StructLtype (hmap (λ _, OfTy) tys) sls) (◠(struct_t sls tys))%I.
+ Proof.
+ iModIntro. iIntros (Ï€ l).
+ rewrite ltype_own_struct_unfold ltype_own_ofty_unfold /lty_of_ty_own /struct_ltype_own.
+ iIntros "(%sl & %Halg & %Hlen & %Hly & #Hlb & %r' & Hrfn & #Hb)".
+ iExists sl. iSplitR. { iPureIntro. by eapply use_struct_layout_alg_Some_inv. }
+ iSplitR; first done. iSplitR; first done. iFrame "Hlb".
+ iExists r'. iFrame "Hrfn". iModIntro. iMod "Hb".
+
+ rewrite /ty_shr /=. iExists sl. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. rewrite -big_sepL_fupd.
+ rewrite hpzipl_hmap.
+ set (f := (λ '(existT x (a, b)), existT x (◠a, b))%I).
+ rewrite (pad_struct_ext _ _ _ (λ ly, f (existT (unit : Type) (uninit (UntypedSynType ly), PlaceIn ())))); last done.
+ rewrite pad_struct_fmap big_sepL_fmap.
+ iApply (big_sepL_wand with "Hb").
+ iApply big_sepL_intro. iIntros "!>" (k [rt0 [ty0 r0]] Hlook).
+ iIntros "(%ly & %Hmem & %Hst & Hb)". simpl in *.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly0 & %Hst0 & %Hly0 & Hsc0 & Hlb0 & %r0' & Hrfn0 & #>#Hb)".
+ iModIntro. iExists r0', ly0.
+ move: Hst. simp_ltypes => Hst. assert (ly0 = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ iFrame "# ∗". iSplit; done.
+ Qed.
+ Lemma struct_t_unfold_2_uniq {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) κ γ r :
+ ⊢ ltype_incl' (Uniq κ γ) r r (StructLtype (hmap (λ _, OfTy) tys) sls) (◠(struct_t sls tys))%I.
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_struct_unfold ltype_own_ofty_unfold /lty_of_ty_own /struct_ltype_own.
+ iIntros "(%sl & %Hst & %Hlen & %Hly & #Hlb & Hrfn & ? & ? & Hb)".
+ iExists sl.
+ iSplitR. { iPureIntro. eapply use_struct_layout_alg_Some_inv; done. }
+ iSplitR; first done.
+ iSplitR; first done.
+ iSplitR; first done.
+ iFrame "∗". iMod "Hb". iModIntro.
+ setoid_rewrite ltype_own_core_equiv.
+ iApply (pinned_bor_iff with "[] [] Hb").
+ + iNext. iModIntro.
+ iPoseProof (unfold_case_uniq _ _ _ _ _ _ false false with "Hlb") as "[Ha1 Ha2]"; [reflexivity | done.. | ].
+ iSplit; done.
+ + iNext. iModIntro.
+ iPoseProof (unfold_case_uniq _ _ _ _ _ _ false true with "Hlb") as "[Ha1 Ha2]"; [reflexivity | done.. | ].
+ iSplit; done.
+ Qed.
+
+ Local Lemma struct_t_unfold_2' {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) k r :
+ ⊢ ltype_incl' k r r (StructLtype (hmap (λ _, OfTy) tys) sls) (◠(struct_t sls tys))%I.
+ Proof.
+ destruct k.
+ - iApply struct_t_unfold_2_owned.
+ - iApply struct_t_unfold_2_shared.
+ - iApply struct_t_unfold_2_uniq.
+ Qed.
+ Lemma struct_t_unfold_2 {rts : list Type} (tys : hlist type rts) (sls : struct_layout_spec) k r :
+ ⊢ ltype_incl k r r (StructLtype (hmap (λ _, OfTy) tys) sls) (◠(struct_t sls tys))%I.
+ Proof.
+ iSplitR; first done. iModIntro. iSplit.
+ + iApply struct_t_unfold_2'.
+ + simp_ltypes. rewrite ltype_core_hmap_ofty. iApply struct_t_unfold_2'.
+ Qed.
+
+ Lemma struct_t_unfold {rts} (tys : hlist type rts) sls k r :
+ ⊢ ltype_eq k r r (◠(struct_t sls tys))%I (StructLtype (hmap (λ _, OfTy) tys) sls).
+ Proof.
+ iSplit.
+ - iApply struct_t_unfold_1.
+ - iApply struct_t_unfold_2.
+ Qed.
+
+ Lemma struct_t_unfold_full_eqltype' E L {rts} (tys : hlist type rts) lts sls :
+ (Forall (λ ltp, full_eqltype E L (projT2 ltp).1 (◠(projT2 ltp).2)%I) (hzipl2 rts lts tys)) →
+ full_eqltype E L (StructLtype lts sls) (â— (struct_t sls tys))%I.
+ Proof.
+ iIntros (Heq ?) "HL #CTX #HE".
+ iAssert ([∗ list] ltp ∈ hzipl2 rts lts tys, ∀ k r, ltype_eq k r r (projT2 ltp).1 (◠(projT2 ltp).2)%I)%I with "[HL]" as "Ha".
+ { iInduction rts as [ | rt rts] "IH"; first done.
+ inv_hlist tys. inv_hlist lts. intros lt lts ty tys.
+ rewrite hzipl2_cons. rewrite Forall_cons. intros [Heq Heqs].
+ iPoseProof (Heq with "HL CTX HE") as "#Heq".
+ iPoseProof ("IH" with "[//] HL") as "Heqs".
+ iFrame. simpl. done. }
+ iIntros (b r).
+ iApply (ltype_eq_trans with "[Ha]"); last (iApply ltype_eq_sym; iApply struct_t_unfold).
+ iApply (struct_ltype_eq lts).
+ iIntros (k).
+
+ (* TODO *)
+ Abort.
+
+ Lemma struct_t_unfold_full_eqltype E L {rts} (tys : hlist type rts) sls :
+ (*full_eqltype E L lt (◠ty)%I →*)
+ full_eqltype E L (StructLtype (hmap (λ _, OfTy) tys) sls) (◠(struct_t sls tys))%I.
+ Proof.
+ iIntros (?) "HL #CTX #HE". iIntros (b r).
+ iApply ltype_eq_sym.
+ iApply struct_t_unfold.
+ Qed.
+End unfold.
+
+Section lemmas.
+ Context `{!typeGS Σ}.
+
+ (** Focusing lemmas for pad_struct big_seps *)
+ Lemma focus_struct_component {rts} (lts : hlist ltype rts) (r : plist place_rfn rts) sl π k l i x rto lto ro :
+ field_index_of (sl_members sl) x = Some i →
+ hpzipl rts lts r !! i = Some (existT rto (lto, ro)) →
+ (* assume the big sep of components *)
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl rts lts r) (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx (sl_members sl) i) â—â‚—[ Ï€, k] (projT2 ty).2 @ (projT2 ty).1) -∗
+ ⌜rto = lnth (unit : Type) rts i⌠∗
+ (* get the component *)
+ ∃ ly : layout, ⌜syn_type_has_layout (ltype_st lto) ly⌠∗ (l at{sl}â‚— x) â—â‚—[ Ï€, k] ro @ lto ∗
+ (* for any strong update, get the corresponding big_sep back *)
+ (∀ rt' lt' r',
+ (l at{sl}â‚— x) â—â‚—[ Ï€, k] r' @ lt' -∗
+ ⌜syn_type_has_layout (ltype_st lt') ly⌠-∗
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl (<[i := rt']> rts) (hlist_insert rts lts i rt' lt') (plist_insert rts r i rt' r')) (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx (sl_members sl) i) â—â‚—[ Ï€, k] (projT2 ty).2 @ (projT2 ty).1)) ∧
+ (* alternatively, for any weak (non-rt-changing) update: *)
+ (∀ (lt' : ltype (lnth (unit : Type) rts i)) (r' : place_rfn (lnth (unit : Type) rts i)),
+ (l at{sl}â‚— x) â—â‚—[ Ï€, k] r' @ lt' -∗
+ ⌜syn_type_has_layout (ltype_st lt') ly⌠-∗
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl (rts) (hlist_insert_id (unit : Type) rts lts i lt') (plist_insert_id (unit : Type) rts r i r')) (λ ly, existT (unit : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx (sl_members sl) i) â—â‚—[ Ï€, k] (projT2 ty).2 @ (projT2 ty).1)).
+ Proof.
+ iIntros (Hfield Hlook) "Hb".
+ edestruct (field_index_of_to_index_of _ _ _ Hfield) as (j & Hindex).
+ iPoseProof (big_sepL_insert_acc with "Hb") as "((%ly & %Hly & %Hst & Hl) & Hclose)".
+ { eapply pad_struct_lookup_field_Some_2'; done. }
+ specialize (hpzipl_lookup_inv _ _ _ _ _ _ _ Hlook) as Hlook'.
+ simpl. iSplitR. { eapply lookup_lnth in Hlook'. done. }
+ iExists ly. iSplitR; first done.
+ rewrite /GetMemberLoc /offset_of Hindex. simpl. iFrame.
+ iSplit.
+ - iIntros (rt' lt' r') "He %Hst'".
+ set (ra := existT (P := λ rt, (ltype rt * place_rfn rt)%type) rt' (lt', r')).
+ iSpecialize ("Hclose" $! ra with "[He]").
+ { iExists ly. iSplitR; first done. iSplitR; done. }
+ erewrite pad_struct_insert_field; [ | done | done | ].
+ 2: { eapply lookup_lt_Some. done. }
+ rewrite insert_hpzipl. done.
+ - iIntros (lt' r') "He %Hst'".
+ set (ra := existT (P := λ rt, (ltype rt * place_rfn rt)%type) _ (lt', r')).
+ iSpecialize ("Hclose" $! ra with "[He]").
+ { iExists ly. iSplitR; first done. iSplitR; done. }
+ erewrite pad_struct_insert_field; [ | done | done | ].
+ 2: { eapply lookup_lt_Some. done. }
+ rewrite insert_hpzipl.
+ enough (hpzipl rts (hlist_insert_id (unit : Type) rts lts i lt') (plist_insert_id (unit : Type) rts r i r') =
+ (hpzipl (<[i:=lnth (unit : Type) rts i]> rts) (hlist_insert rts lts i (lnth (unit : Type) rts i) lt') (plist_insert rts r i (lnth (unit : Type) rts i) r'))) as -> by done.
+ unfold hlist_insert_id, plist_insert_id.
+ generalize (list_insert_lnth rts (unit : Type) i).
+ intros <-. done.
+ Qed.
+
+ (* TODO move *)
+ Section of_list.
+ Context {X} {F : X → Type} (a : X).
+ Fixpoint list_to_plist (l : list (F a)) : plist F (replicate (length l) a) :=
+ match l with
+ | [] => -[]
+ | x :: l => x -:: list_to_plist l
+ end.
+
+ Fixpoint list_to_hlist (l : list (F a)) : hlist F (replicate (length l) a) :=
+ match l with
+ | [] => +[]
+ | x :: l => x +:: list_to_hlist l
+ end.
+
+ Fixpoint mk_const_hlist (x : F a) n : hlist F (replicate n a) :=
+ match n with
+ | 0 => +[]
+ | S n => x +:: mk_const_hlist x n
+ end.
+ Fixpoint mk_const_plist (x : F a) n : plist F (replicate n a) :=
+ match n with
+ | 0 => -[]
+ | S n => x -:: mk_const_plist x n
+ end.
+
+ Lemma mk_const_plist_pzipl_lookup c n i :
+ i < n → pzipl _ (mk_const_plist c n) !! i = Some (existT _ c).
+ Proof.
+ induction n as [ | n IH] in i |-*; simpl; first lia.
+ intros Ha. destruct i as [ | i]; simpl; first done.
+ apply IH. lia.
+ Qed.
+ Lemma mk_const_hlist_hzipl_lookup c n i :
+ i < n → hzipl _ (mk_const_hlist c n) !! i = Some (existT _ c).
+ Proof.
+ induction n as [ | n IH] in i |-*; simpl; first lia.
+ intros Ha. destruct i as [ | i]; simpl; first done.
+ apply IH. lia.
+ Qed.
+ End of_list.
+
+ Fixpoint uninit_struct_hlist (fields : list (var_name * syn_type)) : hlist type (replicate (length fields) (unit : Type)) :=
+ match fields with
+ | [] => +[]
+ | (_, st) :: fields => uninit st +:: uninit_struct_hlist fields
+ end.
+ Lemma uninit_struct_hlist_hzipl_lookup fields i :
+ i < length fields →
+ ∃ x st, fields !! i = Some (x, st) ∧ hzipl _ (uninit_struct_hlist fields) !! i = Some (existT _ $ uninit st).
+ Proof.
+ induction fields as [ | [x st] fields IH] in i |-*; simpl; first lia.
+ intros Ha. destruct i; first by eauto.
+ efeed pose proof (IH i) as Hb; first lia.
+ destruct Hb as (? & ? & Hlook & Hlook'). eauto.
+ Qed.
+
+ Definition uninit_struct_plist (fields : list (var_name * syn_type)) : plist place_rfn (replicate (length fields) (unit : Type)) :=
+ mk_const_plist (unit : Type) #() (length fields).
+
+ Lemma struct_uninit_equiv_val1 π v (sls : struct_layout_spec) :
+ v â—áµ¥{Ï€} .@ uninit sls -∗
+ v â—áµ¥{Ï€} uninit_struct_plist (sls.(sls_fields)) @ struct_t sls (uninit_struct_hlist sls.(sls_fields)).
+ Proof.
+ rewrite /ty_own_val /=.
+ iIntros "(%ly & %Halg & %Hly & _)".
+ apply use_layout_alg_struct_Some_inv in Halg as (sl & Halg & ->).
+ iExists sl. iR. rewrite replicate_length. iR. iR.
+ iApply big_sepL2_intro.
+ { rewrite pad_struct_length reshape_length !fmap_length //. }
+ iModIntro. iIntros (k v1 [rt [ty r]] Hlook1 Hlook2).
+ apply pad_struct_lookup_Some in Hlook2; first last.
+ { rewrite hpzipl_length replicate_length.
+ erewrite struct_layout_spec_has_layout_fields_length; done. }
+ destruct Hlook2 as (n & ly & Hlook2 & [ [? Hlook3] | [-> Heq]]).
+ - apply hpzipl_lookup_inv_hzipl_pzipl in Hlook3 as [Hlook31 Hlook32].
+ (* strategy:
+ - sls lookup gives us something
+ *)
+ Abort.
+ Lemma struct_uninit_equiv_val2 π v (sls : struct_layout_spec) {rts} (rs : plist place_rfn rts) (tys : hlist type rts) :
+ v â—áµ¥{Ï€} rs @ struct_t sls tys -∗
+ v â—áµ¥{Ï€} .@ uninit sls.
+ Proof.
+ rewrite /ty_own_val /=. iIntros "(%sl & %Halg & %Hlen & %Hly & Hb)".
+ iExists sl. eapply use_struct_layout_alg_Some_inv in Halg. iR. iR.
+ iPureIntro. apply Forall_true. done.
+ Qed.
+
+ Lemma struct_uninit_equiv_place1 π l wl (sls : struct_layout_spec) :
+ l â—â‚—[Ï€, Owned wl] .@ (â— uninit sls) -∗
+ l â—â‚—[Ï€, Owned wl] #(uninit_struct_plist sls.(sls_fields)) @ â— struct_t sls (uninit_struct_hlist sls.(sls_fields)).
+ Proof.
+ Abort.
+
+
+ Lemma struct_uninit_equiv_place2 π l wl (sls : struct_layout_spec) {rts} (lts : hlist ltype rts) (rs : plist place_rfn rts) :
+ l â—â‚—[Ï€, Owned wl] #rs @ StructLtype lts sls -∗
+ l â—â‚—[Ï€, Owned wl] .@ â— uninit sls.
+ Proof.
+ (* TODO: also need to know that the lts are all deinitializable.
+ We could do one of the following:
+ - have a pure predicate doing a syntactic check
+ - require a semantic VS via a bigsep.
+ *)
+ Abort.
+
+End lemmas.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ Local Lemma Forall2_place_access_rt_rel b rts rts' :
+ (match b with | Owned _ => False | _ => True end) →
+ Forall2 (place_access_rt_rel b) rts rts' → rts = rts'.
+ Proof.
+ intros Hb Hrel.
+ induction rts as [ | rt rts IH] in rts', Hrel |-*; destruct rts' as [ | rt' rts'];
+ [done | inversion Hrel | inversion Hrel | ].
+ inversion Hrel; subst.
+ destruct b; first done.
+ all: match goal with
+ | H : place_access_rt_rel _ _ _ |- _ => unfold place_access_rt_rel in H; rewrite H
+ end; f_equiv; by apply IH.
+ Qed.
+
+ (** Note: regrettably, this does not allow us to just preserve one component trivially.
+ This is due to the way how mutable references of products are setup.
+ Effectively, this means that our place access lemmas for products will have some sideconditions on when borrows beneath other components will end.
+ TODO is there are smarter setup for this? (e.g. by tracking this as a sidecondition in ltypes so that it does not need to reproved over and over again?)
+ *)
+ Import EqNotations.
+ Lemma struct_ltype_place_cond_ty b {rts rts'} (lts : hlist ltype rts) (lts' : hlist ltype rts') sls :
+ Forall2 (place_access_rt_rel b) rts rts' →
+ ([∗ list] lt; lt' ∈ hzipl rts lts; hzipl rts' lts', typed_place_cond_ty b (projT2 lt) (projT2 lt')) -∗
+ typed_place_cond_ty b (StructLtype lts sls) (StructLtype lts' sls).
+ Proof.
+ iIntros (Hrel). destruct b; simpl.
+ - iIntros "_". done.
+ - iIntros "Hrel".
+ specialize (Forall2_place_access_rt_rel (Shared κ) _ _ I Hrel) as <-.
+ iExists eq_refl.
+ setoid_rewrite <-bi.sep_exist_r.
+ rewrite big_sepL2_sep_sepL_r. iDestruct "Hrel" as "(#Heq & #Hub)".
+ iSplitL.
+ + iIntros (k r). iApply (struct_ltype_eq lts).
+ rewrite (big_sepL2_hzipl_hzipl_sepL_hzipl2 _ _ _
+ (λ _ a b, ∃ Heq, ∀ k r, ltype_eq k r r (projT2 a) (rew <-[ltype] Heq in projT2 b))%I
+ (λ _ ltp, ∀ k r, ltype_eq k r r (projT2 ltp).1 (projT2 ltp).2)%I 0).
+ { iIntros (k'). iApply (big_sepL_impl with "Heq"). iModIntro.
+ iIntros (? [] ?) "Heq'". iIntros (?). iApply "Heq'". }
+ intros _ x a b. iSplit.
+ * iIntros "(%Heq & Heq)". rewrite (UIP_refl _ _ Heq). done.
+ * iIntros "Heq". iExists eq_refl. done.
+ + iApply struct_ltype_imp_unblockable. done.
+ - iIntros "Hrel".
+ specialize (Forall2_place_access_rt_rel (Uniq κ γ) _ _ I Hrel) as <-.
+ iExists eq_refl.
+ setoid_rewrite <-bi.sep_exist_r.
+ rewrite big_sepL2_sep_sepL_r. iDestruct "Hrel" as "(#Heq & #Hub)".
+ iSplitL.
+ + cbn. simp_ltypes. iIntros (k r). iApply struct_ltype_eq. iIntros (k').
+ rewrite hzipl2_fmap big_sepL_fmap.
+ rewrite (big_sepL2_hzipl_hzipl_sepL_hzipl2 _ _ _
+ (λ _ a b, ∃ Heq, ∀ k r, ltype_eq k r r (ltype_core $ projT2 a) (ltype_core $ rew <-[ltype] Heq in projT2 b))%I
+ (λ _ ltp, ∀ k r, ltype_eq k r r (ltype_core (projT2 ltp).1) (ltype_core (projT2 ltp).2))%I 0).
+ { iApply big_sepL_mono; last done. iIntros (? [? [??]] ?). eauto. }
+ intros _ x a b. iSplit.
+ * iIntros "(%Heq & Heq)". rewrite (UIP_refl _ _ Heq). done.
+ * iIntros "Heq". iExists eq_refl. done.
+ + iApply struct_ltype_imp_unblockable. done.
+ Qed.
+ Lemma struct_ltype_place_cond_ty_strong wl {rts rts'} (lts : hlist ltype rts) (lts' : hlist ltype rts') sls :
+ ([∗ list] lt; lt' ∈ hzipl rts lts; hzipl rts' lts', typed_place_cond_ty (Owned wl) (projT2 lt) (projT2 lt')) -∗
+ typed_place_cond_ty (Owned wl) (StructLtype lts sls) (StructLtype lts' sls).
+ Proof.
+ iIntros "_". done.
+ Qed.
+
+ Lemma struct_ltype_acc_owned {rts} F π (lts : hlist ltype rts) (r : plist place_rfn rts) l sls wl :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned wl] #r @ StructLtype lts sls -∗
+ ∃ sl, ⌜use_struct_layout_alg sls = Some sl⌠∗
+ ⌜l `has_layout_loc` sl⌠∗ ⌜length sls.(sls_fields) = length rts⌠∗
+ loc_in_bounds l 0 (sl.(ly_size)) ∗ |={F}=>
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl rts lts r) (λ ly, existT (()%type : Type) (UninitLtype (UntypedSynType ly), #())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx sl.(sl_members) i) â—â‚—[Ï€, Owned false] (projT2 ty).2 @ (projT2 ty).1) ∗
+ logical_step F
+ (∀ rts' (lts' : hlist ltype rts') (r' : plist place_rfn rts'),
+ (* the number of fields should remain equal *)
+ ⌜length rts' = length rts⌠-∗
+ (* new ownership *)
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl rts' lts' r') (λ ly, existT (()%type : Type) (UninitLtype (UntypedSynType ly), #())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx sl.(sl_members) i) â—â‚—[Ï€, Owned false] (projT2 ty).2 @ (projT2 ty).1) ={F}=∗
+ l â—â‚—[Ï€, Owned wl] #r' @ StructLtype lts' sls ∗
+ (* place condition, if required *)
+ (∀ bmin, ([∗ list] ty1; ty2 ∈ hzipl rts lts; hzipl rts' lts', typed_place_cond_ty bmin (projT2 ty1) (projT2 ty2)) -∗
+ ([∗ list] ty1; ty2 ∈ pzipl rts r; pzipl rts' r', typed_place_cond_rfn bmin (projT2 ty1) (projT2 ty2)) -∗
+ ⌜Forall2 (place_access_rt_rel bmin) rts rts'⌠-∗
+ typed_place_cond bmin (StructLtype lts sls) (StructLtype lts' sls) (#r) (#r'))).
+ Proof.
+ iIntros (?) "Hb". rewrite ltype_own_struct_unfold /struct_ltype_own.
+ iDestruct "Hb" as "(%sl & %Halg & %Hlen & %Hly & #Hlb & Hcred & %r' & -> & Hb)".
+ iExists sl. iFrame "#%".
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iModIntro. iFrame.
+ iApply (logical_step_intro_maybe with "Hat"). iIntros "Hcred' !>".
+ iIntros (rts' lts' r) "%Hlen_eq Hb".
+ iSplitL "Hb Hcred'".
+ { rewrite ltype_own_struct_unfold /struct_ltype_own.
+ iExists sl. rewrite Hlen_eq. iFrame "%#∗".
+ iExists r. iSplitR; first done. iModIntro. done. }
+ iModIntro.
+ iIntros (bmin) "Hcond_ty Hcond_rfn %Hrt".
+ rewrite /typed_place_cond.
+ iSplitL "Hcond_ty".
+ { iApply struct_ltype_place_cond_ty; done. }
+ destruct bmin; simpl; [done | | done].
+ assert (rts = rts') as <-.
+ { clear -Hrt. rewrite /place_access_rt_rel in Hrt.
+ induction rts as [ | ?? IH] in rts', Hrt |-*; destruct rts' as [ | ??]; inversion Hrt; try done.
+ subst. f_equiv. by eapply IH. }
+ iExists eq_refl. iClear "Hlb Hcred". clear.
+ iInduction rts as [ | rt rts IH] "IH".
+ - destruct r, r'. done.
+ - destruct r as [r0 r], r' as [r0' r'].
+ simpl. iDestruct "Hcond_rfn" as "(Hh & Hcond_rfn)".
+ iDestruct ("IH" with "Hcond_rfn") as "%Heq". injection Heq as <-.
+ iDestruct "Hh" as "(%Heq & %Heq2)".
+ rewrite -Heq2. rewrite (UIP_refl _ _ Heq). done.
+ Qed.
+
+ Lemma struct_ltype_acc_uniq {rts} F π (lts : hlist ltype rts) (r : plist place_rfn rts) l sls κ γ q R :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ (q.[κ] ={lftE}=∗ R) -∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn r @ StructLtype lts sls -∗
+ ∃ sl, ⌜use_struct_layout_alg sls = Some sl⌠∗
+ ⌜l `has_layout_loc` sl⌠∗ ⌜length sls.(sls_fields) = length rts⌠∗
+ loc_in_bounds l 0 (sl.(ly_size)) ∗ |={F}=>
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl rts lts r) (λ ly, existT (()%type : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx sl.(sl_members) i) â—â‚—[Ï€, Owned false] (projT2 ty).2 @ (projT2 ty).1) ∗
+ logical_step F
+ (((* weak access *)
+ ∀ bmin (lts' : hlist ltype rts) (r' : plist place_rfn rts),
+ bmin ⊑ₖ Uniq κ γ -∗
+ (* new ownership *)
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl rts lts' r') (λ ly, existT (()%type : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx sl.(sl_members) i) â—â‚—[Ï€, Owned false] (projT2 ty).2 @ (projT2 ty).1) -∗
+ ([∗ list] ty1; ty2 ∈ hzipl rts lts; hzipl rts lts', typed_place_cond_ty (bmin) (projT2 ty1) (projT2 ty2)) -∗
+ ([∗ list] ty1; ty2 ∈ pzipl rts r; pzipl rts r', typed_place_cond_rfn (bmin) (projT2 ty1) (projT2 ty2)) ={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn r' @ StructLtype lts' sls ∗
+ R ∗
+ typed_place_cond (Uniq κ γ ⊓ₖ bmin) (StructLtype lts sls) (StructLtype lts' sls) (PlaceIn r) (PlaceIn r')) ∧
+ ((* strong access, go to OpenedLtype *)
+ ∀ rts' (lts' : hlist ltype rts') (r' : plist place_rfn rts'),
+ (* same number of fields *)
+ ⌜length rts' = length rts⌠-∗
+ (* new ownership *)
+ ([∗ list] i ↦ ty ∈ pad_struct (sl_members sl) (hpzipl rts' lts' r') (λ ly, existT (()%type : Type) (UninitLtype (UntypedSynType ly), PlaceIn ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx sl.(sl_members) i) â—â‚—[Ï€, Owned false] (projT2 ty).2 @ (projT2 ty).1) -∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn r' @ OpenedLtype (StructLtype lts' sls) (StructLtype lts sls) (StructLtype lts sls)
+ (λ ri ri', ⌜ri = ri'âŒ) (λ _ _, R))).
+ Proof.
+ Admitted.
+
+
+ (** Place lemmas for products *)
+ (* NOTE: these lemmas require sideconditions for the unaffected components of the product that state that we can keep blocked subplaces blocked because the outer bor_kinds outlive the the blocking lifetimes.
+ It would be good if we could remove this sidecondition with a smarter setup of ltypes... TODO
+ But it's not clear that that is possible: We can arbitrarily shorten the lifetime of outer things -- then at the later point we just don't knwo anymore that really the lender expects it back at a later point.
+
+
+ *)
+
+
+ (* TODO maybe need some simplification mechanism here, given that hlist_insert_id/plist_insert_id will not nicely compute due to the eqcasts?
+ In practice, the eqcast should be a reflexivity cast, we just need to use UIP_refl to get it to simplify.
+ Ideas:
+ - have a tactic hint for simplifying it.
+ + probably this is simplest. Maybe make it a general purpose simplification tactic, i.e. integrate the map simplification stuff that I already have?
+ + problem: this is in a continuation, so we can't concretely simplify yet.
+ Rather: need to do that at clients of typed_place.
+ Or: do that at users of place types, i.e. SimplifyHypPlace. Have an external instance that just computes. However, that is difficult with descending into.
+ Also, getting a reasonable progress indicator for that is difficult.
+
+ simplify_term {T} (t : T)
+ Can we make this extensible?
+ Can we phrase the removal of the eqcast via a tc instance?
+
+ - augment Lithium directly with support for doing this stuff. Seems hard though. Ask Michael if he thinks this is sensible?
+ - some type class instances in Lithium I could use? Need to understand Lithium's infrastructure for simplification better first. Ask Michael?
+ -
+ *)
+
+ Lemma typed_place_struct_owned {rts} (lts : hlist ltype rts) π E L (r : plist place_rfn rts) sls f wl bmin0 P l
+ (T : place_cont_t (plist place_rfn rts)) :
+ ((* sidecondition for other components *)
+ ⌜Forall (lctx_bor_kind_outlives E L bmin0) (concat ((λ _, ltype_blocked_lfts) +c<$> lts))⌠∗
+ (* recursively check place *)
+ (∃ i, ⌜sls_field_index_of sls.(sls_fields) f = Some i⌠∗
+ ∃ lto (ro : place_rfn (lnth (unit : Type) rts i)),
+ ⌜hnth (UninitLtype UnitSynType) lts i = lto⌠∗
+ ⌜pnth (#tt) r i = ro⌠∗
+ typed_place π E L (l atst{sls}ₗ f) lto ro bmin0 (Owned false) P
+ (λ L' κs l1 b2 bmin rti ltyi ri strong weak,
+ T L' κs l1 b2 bmin rti ltyi ri
+ (fmap (λ strong, mk_strong
+ (λ rt', plist place_rfn (<[i := strong.(strong_rt) rt']> rts))
+ (λ rt' lt' r', StructLtype (hlist_insert rts lts i _ (strong.(strong_lt) _ lt' r')) sls)
+ (λ rt' (r' : place_rfn rt'), #(plist_insert rts r i _ (strong.(strong_rfn) _ r')))
+ strong.(strong_R)) strong)
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, StructLtype (hlist_insert_id (unit : Type) rts lts i (weak.(weak_lt) lti2 ri2)) sls)
+ (λ (r' : place_rfn rti), #(plist_insert_id (unit : Type) rts r i (weak.(weak_rfn) r')))
+ weak.(weak_R)) weak))))
+ ⊢ typed_place π E L l (StructLtype lts sls) (#r) bmin0 (Owned wl) (GetMemberPCtx sls f :: P) T.
+ Proof.
+ rewrite /compute_struct_layout_goal.
+ iIntros "(%Houtl & %i & %Hfield & %lto & %ro & %Hlto & %Hro & Hp)".
+ iIntros (Φ F ??) "#(LFT & TIME & LLCTX) #HE HL #Hincl0 Hl HΦ/=".
+ iPoseProof (struct_ltype_acc_owned F with "Hl") as "(%sl & %Halg & %Hly & %Hmem & #Hlb & Hb)"; first done.
+ iApply fupd_wp.
+ iMod (fupd_mask_mono with "Hb") as "(Hb & Hcl)"; first done.
+ iPoseProof (lctx_bor_kind_outlives_all_use with "[//] HE HL") as "#Houtl".
+
+ eapply (sls_field_index_of_lookup) in Hfield as (ly & Hfield).
+ assert (i < length rts)%nat. { rewrite -Hmem. eapply lookup_lt_Some. done. }
+ (* Note: if we later on want to allow the struct alg to change order of fields, then we need to change pad_struct (or use something else here), because it currently relies on the order of the types and the order of the sl members matching up *)
+ assert (field_index_of (sl_members sl) f = Some i) as Hfield'.
+ { eapply struct_layout_spec_has_layout_lookup; done. }
+ iApply (wp_logical_step with "TIME Hcl"); [done | solve_ndisj.. | ].
+ iApply (wp_get_member).
+ { apply val_to_of_loc. }
+ { done. }
+ { by eapply field_index_of_to_index_of. }
+ { done. }
+ iModIntro. iNext. iIntros "Hcred Hcl". iExists _. iSplitR; first done.
+ iPoseProof (focus_struct_component with "Hb") as "(%Heq & %ly' & %Hst & Hb & Hc_close)".
+ { done. }
+ { eapply (hnth_pnth_hpzipl_lookup _ (unit : Type) (UninitLtype UnitSynType) (PlaceIn ())); [ | done..].
+ eapply field_index_of_leq in Hfield'.
+ erewrite struct_layout_spec_has_layout_fields_length in Hfield'; last done. lia. }
+ assert (l at{sl}â‚— f = l atst{sls}â‚— f) as Hleq.
+ { rewrite /GetMemberLocSt /use_struct_layout_alg' Halg //. }
+ rewrite Hleq.
+ iApply ("Hp" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hincl0 [Hb]").
+ { rewrite -Hlto -Hro. done. }
+ iModIntro. iIntros (L' κs l2 b2 bmin rti ltyi ri strong weak) "#Hincl1 Hli Hcont".
+ iApply ("HΦ" $! _ _ _ _ _ _ _ _ _ _ with "Hincl1 Hli").
+ simpl. iSplit.
+ - (* strong *)
+ destruct strong as [strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hli %Hst'".
+ iDestruct "Hcont" as "(Hcont & _)".
+ iMod ("Hcont" with "Hli [//]") as "(Hb1 & %Hst2 & HR)".
+ iDestruct "Hc_close" as "[Hc_close _]".
+ iPoseProof ("Hc_close" with "Hb1 []") as "Hb".
+ { rewrite -Hst2. done. }
+ iFrame.
+ iMod ("Hcl" with "[] Hb") as "(Hb & _)".
+ { rewrite insert_length //. }
+ iFrame. iPureIntro. done.
+ - (* weak *)
+ destruct weak as [ weak | ]; last done.
+ iDestruct "Hcont" as "[_ Hcont]".
+ iIntros (ltyi2 ri2 bmin') "#Hincl2 Hli Hcond".
+ iMod ("Hcont" $! _ _ bmin' with "Hincl2 Hli Hcond") as "(Hb1 & Hcond & HL & HR)".
+ simpl. iDestruct "Hc_close" as "[_ Hc_close]".
+ iPoseProof ("Hc_close" with "Hb1") as "Hb".
+ iFrame "HL HR".
+ iDestruct "Hcond" as "(#Hcond_ty & Hcond_rfn)".
+ iMod ("Hcl" with "[] [Hb]") as "(Hb & Hcond)".
+ { done. }
+ { iApply "Hb". iPoseProof (typed_place_cond_ty_syn_type_eq with "Hcond_ty") as "<-". done. }
+ iFrame "Hb".
+ iApply ("Hcond" with "[] [Hcond_rfn] []").
+ + (* plan: first separate the first one also into an insert, then show a general lemma about inserting into big_sepL2 *)
+ rewrite hzipl_hlist_insert_id.
+ rewrite -(list_insert_id (hzipl rts lts) i (existT _ lto)).
+ 2: { rewrite -Hlto. apply hzipl_lookup_hnth. done. }
+ rewrite (big_sepL2_insert _ _ _ _ _ (λ _ a b, typed_place_cond_ty _ _ _) 0%nat); simpl.
+ 2: { rewrite hzipl_length. lia. }
+ 2: { rewrite insert_length hzipl_length. lia. }
+ iSplitL "Hcond_ty"; first done.
+ iApply big_sepL2_intro. { rewrite insert_length; done. }
+ iIntros "!>" (k [rt1 lt1] [rt2 lt2] Hlook1 Hlook2).
+ case_decide as Heqki; first done.
+ rewrite list_lookup_insert_ne in Hlook2; last done.
+ rewrite Hlook2 in Hlook1. injection Hlook1 as [= -> Heq2].
+ apply existT_inj in Heq2 as ->.
+ iApply typed_place_cond_ty_refl.
+ iPoseProof (big_sepL_concat_lookup _ _ k with "Houtl") as "Ha".
+ { eapply hcmap_lookup_hzipl. done. }
+ simpl. done.
+ + (* same ? *)
+ rewrite pzipl_plist_insert_id.
+ rewrite -(list_insert_id (pzipl rts r) i (existT _ ro)).
+ 2: { rewrite -Hro. apply pzipl_lookup_pnth. done. }
+ rewrite (big_sepL2_insert _ _ _ _ _ (λ _ a b, _) 0%nat); simpl.
+ 2: { rewrite pzipl_length. lia. }
+ 2: { rewrite insert_length pzipl_length. lia. }
+ iSplitL "Hcond_rfn"; first done.
+ iApply big_sepL2_intro. { rewrite insert_length; done. }
+ iIntros "!>" (k [rt1 r1] [rt2 r2] Hlook1 Hlook2).
+ case_decide as Heqki; first done.
+ rewrite list_lookup_insert_ne in Hlook2; last done.
+ rewrite Hlook2 in Hlook1. injection Hlook1 as [= -> Heq2].
+ apply existT_inj in Heq2 as ->.
+ iApply typed_place_cond_rfn_refl.
+ + iPureIntro. clear. induction rts; simpl; first done.
+ constructor; first apply place_access_rt_rel_refl. done.
+ Qed.
+ Global Instance typed_place_struct_owned_inst π E L {rts} (lts : hlist ltype rts) (r : plist place_rfn rts) sls wl bmin0 f l P :
+ TypedPlace E L π l (StructLtype lts sls) (PlaceIn r) bmin0 (Owned wl) (GetMemberPCtx sls f :: P) | 30 :=
+ λ T, i2p (typed_place_struct_owned lts π E L r sls f wl bmin0 P l T).
+
+ (* TODO revisit *)
+ Lemma typed_place_struct_uniq {rts} (lts : hlist ltype rts) π E L (r : plist place_rfn rts) sls f κ γ bmin0 P l
+ (T : place_cont_t (plist place_rfn rts)) :
+ ((* sidecondition for other components *)
+ ⌜Forall (lctx_bor_kind_outlives E L bmin0) (concat ((λ _, ltype_blocked_lfts) +c<$> lts))⌠∗
+ (* get lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L κ) (λ '(κs, L2),
+ (* recursively check place *)
+ (∃ i, ⌜sls_field_index_of sls.(sls_fields) f = Some i⌠∗
+ ∃ lto (ro : place_rfn (lnth (unit : Type) rts i)),
+ ⌜hnth (UninitLtype UnitSynType) lts i = lto⌠∗
+ ⌜pnth (#tt) r i = ro⌠∗
+ typed_place π E L2 (l atst{sls}ₗ f) lto ro bmin0 (Owned false) P
+ (λ L' κs' l1 b2 bmin rti ltyi ri strong weak,
+ T L' (κs ++ κs') l1 b2 bmin rti ltyi ri
+ None
+ (* TODO allow strong by opening *)
+ (*
+ (fmap (λ strong, mk_strong
+ (λ rt', plist place_rfn (<[i := strong.(strong_rt) rt']> rts))
+ (λ rt' lt' r', StructLtype (hlist_insert rts lts i _ (strong.(strong_lt) _ lt' r')) sls)
+ (λ rt' (r' : place_rfn rt'), #(plist_insert rts r i _ (strong.(strong_rfn) _ r')))
+ strong.(strong_R)) strong)
+ *)
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, StructLtype (hlist_insert_id (unit : Type) rts lts i (weak.(weak_lt) lti2 ri2)) sls)
+ (λ (r' : place_rfn rti), #(plist_insert_id (unit : Type) rts r i (weak.(weak_rfn) r')))
+ weak.(weak_R)) weak)))))
+ ⊢ typed_place π E L l (StructLtype lts sls) (#r) bmin0 (Uniq κ γ) (GetMemberPCtx sls f :: P) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance typed_place_struct_uniq_inst π E L {rts} (lts : hlist ltype rts) (r : plist place_rfn rts) sls κ γ bmin0 f l P :
+ TypedPlace E L π l (StructLtype lts sls) (PlaceIn r) bmin0 (Uniq κ γ) (GetMemberPCtx sls f :: P) | 30 :=
+ λ T, i2p (typed_place_struct_uniq lts π E L r sls f κ γ bmin0 P l T).
+
+ Lemma typed_place_struct_shared {rts} (lts : hlist ltype rts) π E L (r : plist place_rfn rts) sls f κ bmin0 P l
+ (T : place_cont_t (plist place_rfn rts)) :
+ ((* sidecondition for other components *)
+ ⌜Forall (lctx_bor_kind_outlives E L bmin0) (concat ((λ _, ltype_blocked_lfts) +c<$> lts))⌠∗
+ (* get lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L κ) (λ '(κs, L'),
+ (* recursively check place *)
+ (∃ i, ⌜sls_field_index_of sls.(sls_fields) f = Some i⌠∗
+ ∃ lto (ro : place_rfn (lnth (unit : Type) rts i)),
+ ⌜hnth (UninitLtype UnitSynType) lts i = lto⌠∗
+ ⌜pnth (#tt) r i = ro⌠∗
+ typed_place π E L (l atst{sls}ₗ f) lto ro bmin0 (Shared κ) P
+ (λ L' κs' l1 b2 bmin rti ltyi ri strong weak,
+ T L' (κs ++ κs') l1 b2 bmin rti ltyi ri
+ (* this should not require wrapping by Shadowed *)
+ (fmap (λ strong, mk_strong
+ (λ rt', plist place_rfn (<[i := strong.(strong_rt) rt']> rts))
+ (λ rt' lt' r', StructLtype (hlist_insert rts lts i _ (strong.(strong_lt) _ lt' r')) sls)
+ (λ rt' (r' : place_rfn rt'), #(plist_insert rts r i _ (strong.(strong_rfn) _ r')))
+ strong.(strong_R)) strong)
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, StructLtype (hlist_insert_id (unit : Type) rts lts i (weak.(weak_lt) lti2 ri2)) sls)
+ (λ (r' : place_rfn rti), #(plist_insert_id (unit : Type) rts r i (weak.(weak_rfn) r')))
+ weak.(weak_R)) weak)))))
+ ⊢ typed_place π E L l (StructLtype lts sls) (#r) bmin0 (Shared κ) (GetMemberPCtx sls f :: P) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance typed_place_struct_shared_inst π E L {rts} (lts : hlist ltype rts) (r : plist place_rfn rts) sls κ bmin0 f l P :
+ TypedPlace E L π l (StructLtype lts sls) (PlaceIn r) bmin0 (Shared κ) (GetMemberPCtx sls f :: P) | 30 :=
+ λ T, i2p (typed_place_struct_shared lts π E L r sls f κ bmin0 P l T).
+
+ Definition stratify_ltype_struct_iter_cont_t := llctx → iProp Σ → ∀ rts' : list Type, hlist ltype rts' → plist place_rfn rts' → iProp Σ.
+ Definition stratify_ltype_struct_iter (π : thread_id) (E : elctx) (L : llctx) (mu : StratifyMutabilityMode) (md : StratifyDescendUnfoldMode) (ma : StratifyAscendMode) {M} (m : M) (l : loc) (i0 : nat) (sls : struct_layout_spec) {rts} (ltys : hlist ltype rts) (rfns : plist place_rfn rts) (k : bor_kind) (T : stratify_ltype_struct_iter_cont_t) : iProp Σ :=
+ ∀ F sl, ⌜lftE ⊆ F⌠-∗
+ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ⌜struct_layout_spec_has_layout sls sl⌠-∗
+ ⌜i0 ≤ length sls.(sls_fields)⌠-∗
+ ⌜(i0 + length rts = length sls.(sls_fields))%nat⌠-∗
+ ([∗ list] i ↦ p ∈ hpzipl rts ltys rfns, let '(existT rt (lt, r)) := p in
+ ∃ name st, ⌜sls.(sls_fields) !! (i + i0)%nat = Some (name, st)⌠∗
+ (l atst{sls}â‚— name) â—â‚—[Ï€, k] r @ lt) ={F}=∗
+ ∃ (L' : llctx) (R' : iProp Σ) (rts' : list Type) (ltys' : hlist ltype rts') (rfns' : plist place_rfn rts'),
+ ⌜length rts = length rts'⌠∗
+ ([∗ list] i ↦ p; p2 ∈ hpzipl rts ltys rfns; hpzipl rts' ltys' rfns',
+ let '(existT rt (lt, r)) := p in
+ let '(existT rt' (lt', r')) := p2 in
+ ⌜ltype_st lt = ltype_st lt'âŒ) ∗
+ logical_step F (
+ ([∗ list] i ↦ p ∈ hpzipl rts' ltys' rfns', let '(existT rt (lt, r)) := p in
+ ∃ name st, ⌜sls.(sls_fields) !! (i + i0)%nat = Some (name, st)⌠∗
+ (l atst{sls}â‚— name) â—â‚—[Ï€, k] r @ lt) ∗ R') ∗
+ llctx_interp L' ∗
+ T L' R' rts' ltys' rfns'.
+
+ Lemma stratify_ltype_struct_iter_nil π E L mu md ma {M} (m : M) (l : loc) sls k i0 (T : stratify_ltype_struct_iter_cont_t) :
+ T L True [] +[] -[]
+ ⊢ stratify_ltype_struct_iter π E L mu md ma m l i0 sls +[] -[] k T.
+ Proof.
+ iIntros "HT". iIntros (????) "#CTX #HE HL ??? Hl".
+ iModIntro. iExists L, True%I, [], +[], -[].
+ iR. iFrame. simpl. iR. iApply logical_step_intro; eauto.
+ Qed.
+
+ Lemma stratify_ltype_struct_iter_cons π E L mu mdu ma {M} (m : M) (l : loc) sls i0 {rts rt} (ltys : hlist ltype rts) (rfns : plist place_rfn (rt :: rts)) (lty : ltype rt) k T :
+ (∃ r rfns0, ⌜rfns = r -:: rfns0⌠∗
+ stratify_ltype_struct_iter π E L mu mdu ma m l (S i0) sls ltys rfns0 k (λ L2 R2 rts2 ltys2 rs2,
+ (∀ name st, ⌜sls.(sls_fields) !! i0 = Some (name, st)⌠-∗
+ stratify_ltype π E L2 mu mdu ma m (l atst{sls}ₗ name) lty r k (λ L3 R3 rt3 lty3 r3,
+ T L3 (R3 ∗ R2) (rt3 :: rts2) (lty3 +:: ltys2) (r3 -:: rs2)))))
+ ⊢ stratify_ltype_struct_iter π E L mu mdu ma m l i0 sls (lty +:: ltys) (rfns) k T.
+ Proof.
+ iIntros "(%r & %rfns0 & -> & HT)". iIntros (????) "#CTX #HE HL %Halg %Hlen %Hleneq Hl".
+ simpl. iDestruct "Hl" as "(Hl & Hl2)". simpl in *.
+ iMod ("HT" with "[//] [//] CTX HE HL [//] [] [] [Hl2]") as "(%L2' & %R2' & %rts2' & %ltys2' & %rfns2' & %Hlen' & Hst & Hl2 & HL & HT)".
+ { rewrite -Hleneq. iPureIntro. lia. }
+ { rewrite -Hleneq. iPureIntro. lia. }
+ { iApply (big_sepL_mono with "Hl2"). intros ? [? []] ?. by rewrite Nat.add_succ_r. }
+ iDestruct "Hl" as "(%name & %st & %Hlook & Hl)".
+ (*edestruct (lookup_lt_is_Some_2 sls.(sls_fields) i0) as ([name ?] & Hlook); first by lia.*)
+ iMod ("HT" with "[//] [//] [//] CTX HE HL Hl") as "(%L3 & %R3 & %rt' & %lt' & %r' & HL & Hst1 & Hl & HT)".
+ iModIntro. iExists L3, (R3 ∗ R2')%I, _, _, _. iFrame.
+ iSplitR. { rewrite Hlen'. done. }
+ iApply (logical_step_compose with "Hl2"). iApply (logical_step_wand with "Hl").
+ iIntros "(Hl & HR1) (Hl2 & HR2)".
+ simpl. iFrame.
+ iSplitL "Hl". { iExists _, _. iFrame. done. }
+ iApply (big_sepL_mono with "Hl2"). intros ? [? []] ?. by rewrite Nat.add_succ_r.
+ Qed.
+
+ (*
+ Owned:
+ - stratify all components
+ - if we should refold:
+ fold all of them to ofty via cast, then done.
+ TODO: should i really do that? It seems like the subtyping should also be able to deal with that.
+ and at other places, i anyways have cast_ltype.
+ should check if I can.
+
+ Uniq:
+ - Basically, we want to stratify all the components
+ - Then check if all of them obey the place cond
+ - If they do not:
+ + go to OpenedLtype
+ Well, can this happen?
+ Basically, only if we unfold an invariant etc.
+ i.e. only if we use the stratification for unfolding.
+ So I think this should be fine to omit, probably.
+ (otherwise, if it is already unfolded before, this should already be in the Owned mode)
+ - If they do:
+ + if we don't need to refold, leave it
+ + if we want to refold, just require that it is castable.
+
+ Q: do we even need the Uniq case in practice?
+ I guess only for unblocking. So we should have it.
+
+
+ For implementation:
+ basically want to be able to say
+ - I get out a new hlist/plist
+ - elementwise, compared to the old list, I get a place_cond (in Uniq case)
+ Problem with existing stuff: I don't get an output. fold_list/relate_list are meant for proving stuff, not for computing something.
+
+ maybe also compute a list, and each op can emit an element for the list?
+ Or just have a specific stratify_ltype_list.
+ e.g. what do I do with the R?
+ I don't think it will be very re-usable anyways.
+
+
+ How do I do it for arrays?
+ Also a custom judgment?
+
+ However, at least these won't need typeclasses I guess, just need to extend the liRJudgment tactics.
+
+ *)
+
+ (* TODO: stratification instance for StructLtype with optional refolding *)
+
+ (** Focus the initialized fields of a struct, disregarding the padding fields *)
+ Lemma struct_ltype_focus_components π {rts : list Type} (lts : hlist ltype rts) (rs : plist place_rfn rts) sls sl k l :
+ struct_layout_spec_has_layout sls sl →
+ ([∗ list] i↦ty ∈ pad_struct (sl_members sl) (hpzipl rts lts rs) (λ ly : layout, existT (unit : Type) (UninitLtype (UntypedSynType ly), # ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗
+ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx (sl_members sl) i) â—â‚—[ Ï€, k] (projT2 ty).2 @ (projT2 ty).1) -∗
+ ([∗ list] i↦p ∈ hpzipl rts lts rs, let 'existT rt (lt, r) := p in ∃ (name : var_name) (st : syn_type), ⌜sls_fields sls !! i = Some (name, st)⌠∗ l atst{sls}â‚— name â—â‚—[ Ï€, k] r @ lt) ∗
+ (∀ (rts' : list Type) (lts' : hlist ltype rts') rs',
+ ([∗ list] p;p2 ∈ hpzipl rts lts rs;hpzipl rts' lts' rs', let 'existT rt (lt, _) := p in let 'existT rt' (lt', _) := p2 in ⌜ltype_st lt = ltype_st lt'âŒ) -∗
+ ([∗ list] i↦p ∈ hpzipl rts' lts' rs', let 'existT rt (lt, r) := p in ∃ (name : var_name) (st : syn_type), ⌜sls_fields sls !! i = Some (name, st)⌠∗ l atst{sls}â‚— name â—â‚—[ Ï€, k] r @ lt) -∗
+ ([∗ list] i↦ty ∈ pad_struct (sl_members sl) (hpzipl rts' lts' rs') (λ ly : layout, existT (unit : Type) (UninitLtype (UntypedSynType ly), # ())),
+ ∃ ly : layout, ⌜snd <$> sl_members sl !! i = Some ly⌠∗
+ ⌜syn_type_has_layout (ltype_st (projT2 ty).1) ly⌠∗
+ (l +â‚— offset_of_idx (sl_members sl) i) â—â‚—[ Ï€, k] (projT2 ty).2 @ (projT2 ty).1)).
+ Proof.
+ (*
+ iIntros (Halg) "Hl".
+ iInduction rts as [ | rt rts] "IH"; inv_hlist lts; [ destruct rs | destruct rs as [r rs]]; simpl.
+ { iR. iIntros (rts' lts' rs') "Hl'".
+ iPoseProof (big_sepL2_length with "Hl'") as "%Hlen".
+ rewrite hpzipl_length in Hlen. destruct rts'; last done.
+ inv_hlist lts'. destruct rs'. simpl. iIntros "_".
+ iFrame. }
+ intros lt lts. simpl.
+ rewrite pad_struct_cons
+ *)
+
+ (*
+ clear -Hleneq. iInduction rts as [ | rt rts] "IH" forall (rts' lts' rs' i Hleneq); simpl; destruct rts' as [ | rt' rts']; try done;
+ inv_hlist lts; inv_hlist lts'.
+ { destruct rs, rs'; done. }
+ intros lt' lts' lt lts.
+ destruct rs as [r rs], rs' as [r' rs']; simpl.
+ iDestruct "Ha" as "(Ha1 & Ha)".
+ iDestruct "Hst" as "(%Hst & Hst)".
+ iPoseProof ("IH" with "[] [Ha] Hst") as "?".
+ { simpl in *. iPureIntro. lia. }
+ {
+ *)
+ (* NOTE: need to generalize lemma about the initial index i in the induction to get sls stuff through *)
+ Admitted.
+
+ Lemma stratify_ltype_struct_owned {rts} π E L mu mdu ma {M} (m : M) l (lts : hlist ltype rts) (rs : plist place_rfn rts) sls wl T :
+ stratify_ltype_struct_iter π E L mu mdu ma m l 0 sls lts rs (Owned false) (λ L2 R2 rts' lts' rs',
+ T L2 R2 (plist place_rfn rts') (StructLtype lts' sls) (#rs'))
+ ⊢ stratify_ltype π E L mu mdu ma m l (StructLtype lts sls) (#rs) (Owned wl) T.
+ Proof.
+ iIntros "HT". iIntros (???) "#CTX #HE HL Hl".
+ rewrite ltype_own_struct_unfold /struct_ltype_own.
+ iDestruct "Hl" as "(%sl & %Halg & %Hlen & %Hly & Hlb & Hcreds & %r' & <- & Hl)".
+ iMod (maybe_use_credit with "Hcreds Hl") as "(Hcred & Hat & Hl)"; first done.
+ iPoseProof (struct_ltype_focus_components with "Hl") as "(Hl & Hlcl)"; first done.
+ iMod ("HT" with "[//] [//] CTX HE HL [//] [] [] [Hl]") as "(%L2 & %R2 & %rts' & %lts' & %rs' & %Hleneq & Hst & Hstep & HL & HT)".
+ { iPureIntro. lia. }
+ { rewrite Hlen. done. }
+ { iApply (big_sepL_mono with "Hl"). intros ? [? []] ?. rewrite Nat.add_0_r. done. }
+ iModIntro. iExists L2, R2, _, _, _. iFrame. simp_ltypes. iR.
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred2 !> (Ha & $)".
+ iPoseProof ("Hlcl" $! rts' lts' rs' with "Hst [Ha]") as "Hl".
+ { iApply (big_sepL_mono with "Ha"). intros ? [? []] ?. rewrite Nat.add_0_r. eauto. }
+ iModIntro.
+ rewrite ltype_own_struct_unfold /struct_ltype_own.
+ iExists _. iFrame "∗%".
+ iSplitR. { by rewrite -Hleneq. }
+ iExists _. iR. iNext. by iFrame.
+ Qed.
+ Global Instance stratify_ltype_struct_owned_inst {rts} π E L mu mdu ma {M} (m : M) l (lts : hlist ltype rts) (rs : plist place_rfn rts) sls wl :
+ StratifyLtype π E L mu mdu ma m l (StructLtype lts sls) (#rs) (Owned wl) :=
+ λ T, i2p (stratify_ltype_struct_owned π E L mu mdu ma m l lts rs sls wl T).
+
+ (* TODO uniq*)
+
+ Lemma stratify_ltype_ofty_struct {rts} π E L mu ma {M} (ml : M) l (tys : hlist type rts) (r : place_rfn (plist place_rfn rts)) sls b T :
+ stratify_ltype π E L mu StratDoUnfold ma ml l (StructLtype (hmap (λ _, OfTy) tys) sls) r b T
+ ⊢ stratify_ltype π E L mu StratDoUnfold ma ml l (◠(struct_t sls tys)) r b T.
+ Proof.
+ iIntros "Hp". iApply stratify_ltype_eqltype; iFrame.
+ iPureIntro. iIntros (?) "HL CTX HE".
+ iApply struct_t_unfold.
+ Qed.
+ Global Instance stratify_ltype_ofty_prod_inst {rts} π E L mu ma {M} (ml : M) l (tys : hlist type rts) (r : place_rfn (plist place_rfn rts)) sls b :
+ StratifyLtype π E L mu StratDoUnfold ma ml l (◠(struct_t sls tys))%I r b | 30 :=
+ λ T, i2p (stratify_ltype_ofty_struct π E L mu ma ml l tys r sls b T).
+
+ (* needs to have lower priority than the id instance *)
+ Lemma place_ofty_struct {rts} π E L l (tys : hlist type rts) (r : place_rfn (plist place_rfn rts)) sls bmin0 b P T :
+ typed_place π E L l (StructLtype (hmap (λ _, OfTy) tys) sls) r bmin0 b P T
+ ⊢ typed_place π E L l (◠(struct_t sls tys)) r bmin0 b P T.
+ Proof.
+ iIntros "Hp". iApply typed_place_eqltype; last iFrame.
+ iIntros (?) "HL CTX HE".
+ iIntros (??). iApply struct_t_unfold.
+ Qed.
+ Global Instance typed_place_ofty_struct_inst {rts} π E L l (tys : hlist type rts) (r : place_rfn (plist place_rfn rts)) sls bmin0 b P :
+ TypedPlace E L π l (◠(struct_t sls tys))%I r bmin0 b P | 30 :=
+ λ T, i2p (place_ofty_struct π E L l tys r sls bmin0 b P T).
+
+ (** Subtyping *)
+ (* TODO replace foldr with relate_hlist *)
+ Lemma weak_subtype_struct E L {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 sls1 sls2 T :
+ ⌜sls1 = sls2⌠∗
+ ⌜length rts1 = length rts2⌠∗
+ foldr (λ '(existT rt1 (ty1, r1'), existT rt2 (ty2, r2')) T,
+ match r1' with
+ | #r1 => ∃ r2, ⌜r2' = #r2⌠∗ weak_subtype E L r1 r2 ty1 ty2 T
+ | _ => ∃ (Heq : rt1 = rt2), ⌜r1' = rew <-Heq in r2'⌠∗ mut_subtype E L ty1 (rew <- [type] Heq in ty2) T
+ end) T (zip (hpzipl rts1 tys1 rs1) (hpzipl rts2 tys2 rs2))
+ ⊢ weak_subtype E L rs1 rs2 (struct_t sls1 tys1) (struct_t sls2 tys2) T.
+ Proof.
+ iIntros "(-> & %Hlen & Hb)". iIntros (??) "#CTX #HE HL".
+ match goal with |- context[foldr ?P _ _] => set (Q := P) end.
+ iAssert (|={F}=> struct_t_incl_precond tys1 tys2 rs1 rs2 ∗ llctx_interp L ∗ T)%I with "[Hb HL]" as ">(Hp & $ & $)"; first last.
+ { by iApply struct_t_type_incl. }
+ iInduction rts1 as [ | rt1 rts1] "IH" forall (rts2 tys1 tys2 rs1 rs2 Hlen); destruct rts2 as [ | rt2 rts2]; simpl in Hlen; try done;
+ inv_hlist tys2; inv_hlist tys1.
+ { simpl. iFrame. by iApply big_sepL2_nil. }
+ intros ty1 tys1 ty2 tys2.
+ destruct rs1 as [r1 rs1]. destruct rs2 as [r2 rs2].
+ simpl.
+ destruct r1.
+ - iDestruct "Hb" as "(%r2' & -> & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hi & HL & HT)".
+ iMod ("IH" with "[] HT HL") as "(Hi2 & $ & $)"; last by iFrame.
+ iPureIntro; lia.
+ - iDestruct "Hb" as "(%Heq & %Heq' & %Hb & HT)". subst.
+ iPoseProof (full_subtype_acc with "HE HL") as "#Hsub"; first apply Hb.
+ iMod ("IH" with "[] HT HL") as "(Hi2 & $ & $)". { iPureIntro; lia. }
+ rewrite {3}/struct_t_incl_precond; simpl. iFrame.
+ iExists eq_refl. iR. done.
+ Qed.
+ Global Instance weak_subtype_struct_inst E L {rts1 rts2} (tys1 : hlist type rts1) (tys2 : hlist type rts2) rs1 rs2 sls1 sls2 :
+ Subtype E L rs1 rs2 (struct_t sls1 tys1) (struct_t sls2 tys2) | 20 :=
+ λ T, i2p (weak_subtype_struct E L tys1 tys2 rs1 rs2 sls1 sls2 T).
+
+ (* TODO replace foldr with relate_hlist *)
+ Lemma mut_subtype_struct E L {rts} (tys1 tys2 : hlist type rts) sls1 sls2 T :
+ ⌜sls1 = sls2⌠∗ foldr (λ '(existT rt (ty1, ty2)) T, mut_subtype E L ty1 ty2 T) T (hzipl2 _ tys1 tys2)
+ ⊢ mut_subtype E L (struct_t sls1 tys1) (struct_t sls2 tys2) T.
+ Proof.
+ iIntros "(-> & Hb)".
+ iAssert (⌜Forall (λ '(existT x (ty1, ty2)), full_subtype E L ty1 ty2) (hzipl2 rts tys1 tys2)⌠∗ T)%I with "[Hb]" as "(%Hsubt & $)"; first last.
+ { iPureIntro. by apply struct_t_full_subtype. }
+ iInduction rts as [ | rt rts] "IH" forall (tys1 tys2); inv_hlist tys2; inv_hlist tys1.
+ { iFrame. iPureIntro. simpl. done. }
+ intros ty1 tys1 ty2 tys2.
+ rewrite hzipl2_cons. simpl.
+ iDestruct "Hb" as "(%Hsub & Hb)".
+ iPoseProof ("IH" with "Hb") as "(%Hsubt & $)".
+ iPureIntro. constructor; done.
+ Qed.
+ Global Instance mut_subtype_struct_inst E L {rts} (tys1 tys2 : hlist type rts) sls1 sls2 :
+ MutSubtype E L (struct_t sls1 tys1) (struct_t sls2 tys2) | 20 :=
+ λ T, i2p (mut_subtype_struct E L tys1 tys2 sls1 sls2 T).
+
+ (* TODO replace foldr with relate_hlist *)
+ Lemma mut_eqtype_struct E L {rts} (tys1 tys2 : hlist type rts) sls1 sls2 T :
+ ⌜sls1 = sls2⌠∗ foldr (λ '(existT rt (ty1, ty2)) T, mut_eqtype E L ty1 ty2 T) T (hzipl2 _ tys1 tys2)
+ ⊢ mut_eqtype E L (struct_t sls1 tys1) (struct_t sls2 tys2) T.
+ Proof.
+ iIntros "(-> & Hb)".
+ iAssert (⌜Forall (λ '(existT x (ty1, ty2)), full_eqtype E L ty1 ty2) (hzipl2 rts tys1 tys2)⌠∗ T)%I with "[Hb]" as "(%Hsubt & $)"; first last.
+ { iPureIntro. apply full_subtype_eqtype; apply struct_t_full_subtype.
+ - eapply Forall_impl; first done. intros [? []]. apply full_eqtype_subtype_l.
+ - rewrite hzipl2_swap Forall_fmap. eapply Forall_impl; first done.
+ intros [? []]. apply full_eqtype_subtype_r. }
+ iInduction rts as [ | rt rts] "IH" forall (tys1 tys2); inv_hlist tys2; inv_hlist tys1.
+ { iFrame. iPureIntro. simpl. done. }
+ intros ty1 tys1 ty2 tys2.
+ rewrite hzipl2_cons. simpl.
+ iDestruct "Hb" as "(%Hsub & Hb)".
+ iPoseProof ("IH" with "Hb") as "(%Hsubt & $)".
+ iPureIntro. constructor; done.
+ Qed.
+ Global Instance mut_eqtype_struct_inst E L {rts} (tys1 tys2 : hlist type rts) sls1 sls2 :
+ MutEqtype E L (struct_t sls1 tys1) (struct_t sls2 tys2) | 20 :=
+ λ T, i2p (mut_eqtype_struct E L tys1 tys2 sls1 sls2 T).
+
+ (** Subltyping *)
+ (* TODO replace foldr with relate_hlist *)
+ Lemma weak_subltype_struct_owned_in E L {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) rs1 rs2 sls1 sls2 wl T :
+ ⌜sls1 = sls2⌠∗ ⌜length rts1 = length rts2⌠∗ foldr (λ '(existT rt1 (lt1, r1'), existT rt2 (lt2, r2')) T,
+ weak_subltype E L (Owned false) r1' r2' lt1 lt2 T) T (zip (hpzipl rts1 lts1 rs1) (hpzipl rts2 lts2 rs2))
+ ⊢ weak_subltype E L (Owned wl) (#rs1) (#rs2) (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & %Hlen & Ha)" (??) "#CTX #HE HL".
+ iAssert (|={F}=> ([∗ list] lt1; lt2 ∈ hpzipl _ lts1 rs1; hpzipl _ lts2 rs2, ltype_incl (Owned false) (projT2 lt1).2 (projT2 lt2).2 (projT2 lt1).1 (projT2 lt2).1) ∗ llctx_interp L ∗ T)%I with "[Ha HL]" as ">(Ha & $ & $)"; first last.
+ { iApply (struct_ltype_incl_owned_in lts1 lts2). done. }
+ iInduction rts1 as [ | rt1 rts1] "IH" forall (rts2 lts1 lts2 rs1 rs2 Hlen); destruct rts2 as [ | rt2 rts2]; try done;
+ inv_hlist lts2; inv_hlist lts1.
+ { simpl. by iFrame. }
+ intros lt1 lts1 lt2 lts2. simpl in Hlen.
+ destruct rs1 as [r1 rs1]. destruct rs2 as [r2 rs2].
+ simpl. iMod ("Ha" with "[//] CTX HE HL") as "(Hincl1 & HL & HT)".
+ iMod ("IH" with "[] HT HL") as "(Hincl & $ & $)"; first (iPureIntro; lia).
+ by iFrame.
+ Qed.
+ Global Instance weak_subltype_struct_owned_in_inst E L {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) rs1 rs2 sls1 sls2 wl :
+ SubLtype E L (Owned wl) #rs1 #rs2 (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 10 :=
+ λ T, i2p (weak_subltype_struct_owned_in E L lts1 lts2 rs1 rs2 sls1 sls2 wl T).
+
+ (* TODO replace foldr with relate_hlist *)
+ Lemma weak_subltype_struct_owned E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) rs1 rs2 sls1 sls2 wl T :
+ ⌜sls1 = sls2⌠∗ ⌜rs1 = rs2⌠∗ foldr (λ '(existT rt1 (lt1, lt2)) T,
+ mut_subltype E L lt1 lt2 T) T (hzipl2 rts lts1 lts2)
+ ⊢ weak_subltype E L (Owned wl) (rs1) (rs2) (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & -> & HT)" (??) "#CTX #HE HL".
+ iAssert (([∗ list] ltp ∈ hzipl2 rts lts1 lts2, ∀ r, ltype_incl (Owned false) r r (projT2 ltp).1 (projT2 ltp).2) ∗ llctx_interp L ∗ T)%I with "[HT HL]" as "(Ha & $ & $)"; first last.
+ { iApply (struct_ltype_incl_owned lts1 lts2). done. }
+ clear rs2.
+ iInduction rts as [ | rt rts] "IH" forall (lts1 lts2); inv_hlist lts2; inv_hlist lts1.
+ { simpl. iFrame. }
+ intros lt1 lts1 lt2 lts2.
+ simpl. iDestruct "HT" as "(%Hsubt & HT)".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hincl1"; first apply Hsubt.
+ iPoseProof ("IH" with "HT HL") as "(Hincl & $ & $)".
+ iFrame. iIntros (?). iApply "Hincl1".
+ Qed.
+ Global Instance weak_subltype_struct_owned_inst E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) rs1 rs2 sls1 sls2 wl :
+ SubLtype E L (Owned wl) rs1 rs2 (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 11 :=
+ λ T, i2p (weak_subltype_struct_owned E L lts1 lts2 rs1 rs2 sls1 sls2 wl T).
+
+ (* TODO replace foldr with relate_hlist *)
+ Lemma weak_subltype_struct_shared_in E L {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) rs1 rs2 sls1 sls2 κ T :
+ ⌜sls1 = sls2⌠∗ ⌜length rts1 = length rts2⌠∗ foldr (λ '(existT rt1 (lt1, r1'), existT rt2 (lt2, r2')) T,
+ weak_subltype E L (Shared κ) r1' r2' lt1 lt2 T) T (zip (hpzipl rts1 lts1 rs1) (hpzipl rts2 lts2 rs2))
+ ⊢ weak_subltype E L (Shared κ) (#rs1) (#rs2) (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & %Hlen & Ha)" (??) "#CTX #HE HL".
+ iAssert (|={F}=> ([∗ list] lt1; lt2 ∈ hpzipl _ lts1 rs1; hpzipl _ lts2 rs2, ltype_incl (Shared κ) (projT2 lt1).2 (projT2 lt2).2 (projT2 lt1).1 (projT2 lt2).1) ∗ llctx_interp L ∗ T)%I with "[Ha HL]" as ">(Ha & $ & $)"; first last.
+ { iApply (struct_ltype_incl_shared_in lts1 lts2). done. }
+ (* TODO duplicated *)
+ iInduction rts1 as [ | rt1 rts1] "IH" forall (rts2 lts1 lts2 rs1 rs2 Hlen); destruct rts2 as [ | rt2 rts2]; try done;
+ inv_hlist lts2; inv_hlist lts1.
+ { simpl. by iFrame. }
+ intros lt1 lts1 lt2 lts2. simpl in Hlen.
+ destruct rs1 as [r1 rs1]. destruct rs2 as [r2 rs2].
+ simpl. iMod ("Ha" with "[//] CTX HE HL") as "(Hincl1 & HL & HT)".
+ iMod ("IH" with "[] HT HL") as "(Hincl & $ & $)"; first (iPureIntro; lia).
+ by iFrame.
+ Qed.
+ Global Instance weak_subltype_struct_shared_in_inst E L {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) rs1 rs2 sls1 sls2 κ :
+ SubLtype E L (Shared κ) #rs1 #rs2 (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 10 :=
+ λ T, i2p (weak_subltype_struct_shared_in E L lts1 lts2 rs1 rs2 sls1 sls2 κ T).
+
+ (* TODO replace foldr with relate_hlist *)
+ Lemma weak_subltype_struct_shared E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) rs1 rs2 sls1 sls2 κ T :
+ ⌜sls1 = sls2⌠∗ ⌜rs1 = rs2⌠∗ foldr (λ '(existT rt1 (lt1, lt2)) T,
+ mut_subltype E L lt1 lt2 T) T (hzipl2 rts lts1 lts2)
+ ⊢ weak_subltype E L (Shared κ) (rs1) (rs2) (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & -> & HT)" (??) "#CTX #HE HL". iModIntro.
+ iAssert (([∗ list] ltp ∈ hzipl2 rts lts1 lts2, ∀ r, ltype_incl (Shared κ) r r (projT2 ltp).1 (projT2 ltp).2) ∗ llctx_interp L ∗ T)%I with "[HT HL]" as "(Ha & $ & $)"; first last.
+ { iApply (struct_ltype_incl_shared lts1 lts2). done. }
+ (* TODO duplicated *)
+ clear rs2. iInduction rts as [ | rt rts] "IH" forall (lts1 lts2); inv_hlist lts2; inv_hlist lts1.
+ { simpl. iFrame. }
+ intros lt1 lts1 lt2 lts2.
+ simpl. iDestruct "HT" as "(%Hsubt & HT)".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hincl1"; first apply Hsubt.
+ iPoseProof ("IH" with "HT HL") as "(Hincl & $ & $)".
+ iFrame. iIntros (?). iApply "Hincl1".
+ Qed.
+ Global Instance weak_subltype_struct_shared_inst E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) rs1 rs2 sls1 sls2 κ :
+ SubLtype E L (Shared κ) rs1 rs2 (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 11 :=
+ λ T, i2p (weak_subltype_struct_shared E L lts1 lts2 rs1 rs2 sls1 sls2 κ T).
+
+ (* TODO replace foldr with relate_hlist *)
+ Lemma weak_subltype_struct_base E L {rts} (lts1 lts2 : hlist ltype rts) rs1 rs2 sls1 sls2 k T :
+ ⌜sls1 = sls2⌠∗ ⌜rs1 = rs2⌠∗ foldr (λ '(existT rt1 (lt1, lt2)) T,
+ mut_eqltype E L lt1 lt2 T) T (hzipl2 rts lts1 lts2)
+ ⊢ weak_subltype E L k rs1 rs2 (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & -> & HT)" (??) "#CTX #HE HL". iModIntro.
+ iAssert ((∀ k, [∗ list] ltp ∈ hzipl2 rts lts1 lts2, ∀ r, ltype_eq k r r (projT2 ltp).1 (projT2 ltp).2) ∗ llctx_interp L ∗ T)%I with "[HT HL]" as "(Ha & $ & $)"; first last.
+ { iApply (struct_ltype_incl lts1 lts2). done. }
+ clear rs2. iInduction rts as [ | rt rts] "IH" forall (lts1 lts2); inv_hlist lts2; inv_hlist lts1.
+ { simpl. by iFrame. }
+ intros lt1 lts1 lt2 lts2.
+ simpl. iDestruct "HT" as "(%Hsubt & HT)".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hincl1"; first apply Hsubt.
+ iPoseProof ("IH" with "HT HL") as "(Hincl & $ & $)".
+ iFrame. iIntros (?). iSplitR.
+ - iIntros (?). iApply "Hincl1".
+ - iApply "Hincl".
+ Qed.
+ Global Instance weak_subltype_struct_base_inst E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) rs1 rs2 sls1 sls2 k :
+ SubLtype E L k rs1 rs2 (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 20 :=
+ λ T, i2p (weak_subltype_struct_base E L lts1 lts2 rs1 rs2 sls1 sls2 k T).
+
+
+ Program Definition MutEqltypeStructHFR (cap : nat) : HetFoldableRelation (A := Type) (G := ltype) := {|
+ hfr_rel E L i rt lt1 lt2 T := mut_eqltype E L lt1 lt2 T;
+ hfr_cap := cap;
+ hfr_inv := True;
+ hfr_core_rel E L i rt lt1 lt2 := ⌜full_eqltype E L lt1 lt2âŒ%I;
+ hfr_elim_mode := false
+ |}.
+ Next Obligation.
+ iIntros (i0 E L i rt lt1 lt2 T) "(%Hsubt & HT)". by iFrame.
+ Qed.
+ Global Typeclasses Opaque MutEqltypeStructHFR.
+ Global Arguments MutEqltypeStructHFR : simpl never.
+ Lemma mut_subltype_struct E L {rts} (lts1 lts2 : hlist ltype rts) sls1 sls2 T :
+ ⌜sls1 = sls2⌠∗
+ relate_hlist E L [] rts lts1 lts2 0 (MutEqltypeStructHFR (length rts)) T
+ ⊢ mut_subltype E L (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ rewrite /MutEqltypeStructHFR.
+ iIntros "(-> & Ha & $)".
+ iPoseProof ("Ha" with "[] [//]") as "Ha".
+ { simpl. iPureIntro. lia. }
+ simpl.
+ iAssert (⌜Forall (λ lts, full_eqltype E L (projT2 lts).1 (projT2 lts).2) (hzipl2 rts lts1 lts2)âŒ)%I with "[Ha]" as "%Hsubt"; first last.
+ { iPureIntro. by apply (struct_full_subltype _ _ lts1 lts2). }
+ iInduction rts as [ | rt rts] "IH" forall (lts1 lts2); inv_hlist lts2; inv_hlist lts1.
+ { iFrame. simpl; done. }
+ intros lt1 lts1 lt2 lts2. rewrite hzipl2_cons. simpl.
+ iDestruct "Ha" as "(%Hsubt & Ha)". iPoseProof ("IH" with "Ha") as "%Hsubt'".
+ iPureIntro. constructor; done.
+ Qed.
+ Global Instance mut_subltype_struct_inst E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) sls1 sls2 :
+ MutSubLtype E L (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 20 :=
+ λ T, i2p (mut_subltype_struct E L lts1 lts2 sls1 sls2 T).
+
+ Lemma mut_eqltype_struct E L {rts} (lts1 lts2 : hlist ltype rts) sls1 sls2 T :
+ ⌜sls1 = sls2⌠∗
+ relate_hlist E L [] rts lts1 lts2 0 (MutEqltypeStructHFR (length rts)) T
+ ⊢ mut_eqltype E L (StructLtype lts1 sls1) (StructLtype lts2 sls2) T.
+ Proof.
+ rewrite /MutEqltypeStructHFR.
+ iIntros "(-> & Ha & $)".
+ iPoseProof ("Ha" with "[] [//]") as "Ha".
+ { simpl. iPureIntro. lia. }
+ simpl.
+ iAssert (⌜Forall (λ lts, full_eqltype E L (projT2 lts).1 (projT2 lts).2) (hzipl2 rts lts1 lts2)âŒ)%I with "[Ha]" as "%Hsubt"; first last.
+ { iPureIntro. by apply struct_full_eqltype. }
+ iInduction rts as [ | rt rts] "IH" forall (lts1 lts2); inv_hlist lts2; inv_hlist lts1.
+ { iFrame. simpl; done. }
+ intros lt1 lts1 lt2 lts2. rewrite hzipl2_cons. simpl.
+ iDestruct "Ha" as "(%Hsubt & Ha)". iPoseProof ("IH" with "Ha") as "%Hsubt'".
+ iPureIntro. constructor; done.
+ Qed.
+ Global Instance mut_eqltype_struct_inst E L {rts} (lts1 : hlist ltype rts) (lts2 : hlist ltype rts) sls1 sls2 :
+ MutEqLtype E L (StructLtype lts1 sls1) (StructLtype lts2 sls2) | 20 :=
+ λ T, i2p (mut_eqltype_struct E L lts1 lts2 sls1 sls2 T).
+
+ (* Ofty unfolding if necessary *)
+ Lemma weak_subltype_struct_ofty_1_evar E L {rts1 rts2} (lts1 : hlist ltype rts1) (ty2 : type (plist place_rfn rts2)) sls k r1 r2 T :
+ (∃ tys2, ⌜ty2 = struct_t sls tys2⌠∗ weak_subltype E L k r1 r2 (StructLtype lts1 sls) (StructLtype (@OfTy _ _ +<$> tys2) sls) T)
+ ⊢ weak_subltype E L k r1 r2 (StructLtype lts1 sls) (◠ty2) T.
+ Proof.
+ iIntros "(%tys2 & -> & Hsubt)" (??) "#CTX #HE HL".
+ iMod ("Hsubt" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "Hincl").
+ iApply struct_t_unfold_2.
+ Qed.
+ Global Instance weak_subltype_struct_ofty_1_evar_inst E L {rts1 rts2} (lts1 : hlist ltype rts1) (ty2 : type (plist place_rfn rts2)) sls k rs1 rs2 `{!IsProtected ty2} :
+ SubLtype E L k rs1 rs2 (StructLtype lts1 sls) (â— ty2)%I | 30 :=
+ λ T, i2p (weak_subltype_struct_ofty_1_evar E L lts1 ty2 sls k rs1 rs2 T).
+
+ Lemma weak_subltype_struct_ofty_1 E L {rts1 rts2} (lts1 : hlist ltype rts1) (tys2 : hlist type rts2) sls1 sls2 k r1 r2 T :
+ (⌜sls1 = sls2⌠∗ weak_subltype E L k r1 r2 (StructLtype lts1 sls1) (StructLtype (@OfTy _ _ +<$> tys2) sls2) T)
+ ⊢ weak_subltype E L k r1 r2 (StructLtype lts1 sls1) (◠struct_t sls2 tys2) T.
+ Proof.
+ iIntros "(-> & Hsubt)" (??) "#CTX #HE HL".
+ iMod ("Hsubt" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "Hincl").
+ iApply struct_t_unfold_2.
+ Qed.
+ Global Instance weak_subltype_struct_ofty_1_inst E L {rts1 rts2} (lts1 : hlist ltype rts1) (tys2 : hlist type rts2) sls1 sls2 k rs1 rs2 :
+ SubLtype E L k rs1 rs2 (StructLtype lts1 sls1) (â— struct_t sls2 tys2)%I | 20 :=
+ λ T, i2p (weak_subltype_struct_ofty_1 E L lts1 tys2 sls1 sls2 k rs1 rs2 T).
+
+
+ Lemma weak_subltype_struct_ofty_2 E L {rts1 rts2} (tys1 : hlist type rts1) (lts2 : hlist ltype rts2) sls1 sls2 k r1 r2 T :
+ (weak_subltype E L k r1 r2 (StructLtype (@OfTy _ _ +<$> tys1) sls1) (StructLtype lts2 sls2) T)
+ ⊢ weak_subltype E L k r1 r2 (◠struct_t sls1 tys1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "Hsubt" (??) "#CTX #HE HL".
+ iMod ("Hsubt" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "[] Hincl").
+ iApply struct_t_unfold_1.
+ Qed.
+ Definition weak_subltype_struct_ofty_2_inst := [instance weak_subltype_struct_ofty_2].
+ Global Existing Instance weak_subltype_struct_ofty_2_inst | 20.
+
+ Lemma mut_subltype_struct_ofty_1 E L {rts} (lts1 : hlist ltype rts) (ty2 : type (plist place_rfn rts)) sls T :
+ (∃ tys2, ⌜ty2 = struct_t sls tys2⌠∗ mut_subltype E L (StructLtype lts1 sls) (StructLtype (@OfTy _ _ +<$> tys2) sls) T)
+ ⊢ mut_subltype E L (StructLtype lts1 sls) (◠ty2) T.
+ Proof.
+ iIntros "(%tys21 & -> & %Hsubt & $)".
+ iPureIntro.
+ etrans; first apply Hsubt.
+ apply full_eqltype_subltype_l. apply (struct_t_unfold_full_eqltype _ _ tys21).
+ Qed.
+ Global Instance mut_subltype_struct_ofty_1_inst E L {rts} (lts1 : hlist ltype rts) (ty2 : type (plist place_rfn rts)) sls :
+ MutSubLtype E L (StructLtype lts1 sls) (◠ty2)%I := λ T, i2p (mut_subltype_struct_ofty_1 E L lts1 ty2 sls T).
+
+ Lemma mut_subltype_struct_ofty_2 E L {rts} (lts2 : hlist ltype rts) (tys1 : hlist type rts) sls1 sls2 T :
+ (⌜sls1 = sls2⌠∗ mut_subltype E L (StructLtype (@OfTy _ _ +<$> tys1) sls1) (StructLtype lts2 sls1) T)
+ ⊢ mut_subltype E L (◠struct_t sls1 tys1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & %Hsubt & $)".
+ iPureIntro. etrans; last apply Hsubt.
+ apply full_eqltype_subltype_r. apply (struct_t_unfold_full_eqltype _ _ tys1).
+ Qed.
+ Global Instance mut_subltype_struct_ofty_2_inst E L {rts} (lts2 : hlist ltype rts) (tys1 : hlist type rts) sls1 sls2 :
+ MutSubLtype E L (◠struct_t sls1 tys1)%I (StructLtype lts2 sls2) := λ T, i2p (mut_subltype_struct_ofty_2 E L lts2 tys1 sls1 sls2 T).
+
+ Lemma mut_eqltype_struct_ofty_1 E L {rts} (lts1 : hlist ltype rts) (ty2 : type (plist place_rfn rts)) sls T :
+ (∃ tys2, ⌜ty2 = struct_t sls tys2⌠∗ mut_eqltype E L (StructLtype lts1 sls) (StructLtype (@OfTy _ _ +<$> tys2) sls) T)
+ ⊢ mut_eqltype E L (StructLtype lts1 sls) (◠ty2) T.
+ Proof.
+ iIntros "(%tys21 & -> & %Hsubt & $)".
+ iPureIntro. etrans; first apply Hsubt. apply (struct_t_unfold_full_eqltype _ _ tys21).
+ Qed.
+ Global Instance mut_eqltype_struct_ofty_1_inst E L {rts} (lts1 : hlist ltype rts) (ty2 : type (plist place_rfn rts)) sls :
+ MutEqLtype E L (StructLtype lts1 sls) (◠ty2)%I := λ T, i2p (mut_eqltype_struct_ofty_1 E L lts1 ty2 sls T).
+
+ Lemma mut_eqltype_struct_ofty_2 E L {rts} (lts2 : hlist ltype rts) (tys1 : hlist type rts) sls1 sls2 T :
+ (⌜sls1 = sls2⌠∗ mut_eqltype E L (StructLtype (@OfTy _ _ +<$> tys1) sls1) (StructLtype lts2 sls1) T)
+ ⊢ mut_eqltype E L (◠struct_t sls1 tys1) (StructLtype lts2 sls2) T.
+ Proof.
+ iIntros "(-> & %Hsubt & $)".
+ iPureIntro. etrans; last apply Hsubt. symmetry. apply (struct_t_unfold_full_eqltype _ _ tys1).
+ Qed.
+ Global Instance mut_eqltype_struct_ofty_2_inst E L {rts} (lts2 : hlist ltype rts) (tys1 : hlist type rts) sls1 sls2 :
+ MutEqLtype E L (◠struct_t sls1 tys1)%I (StructLtype lts2 sls2) := λ T, i2p (mut_eqltype_struct_ofty_2 E L lts2 tys1 sls1 sls2 T).
+
+ (*
+ Lemma subsume_place_struct_uninit π E L wl l {rts} (lts : hlist ltype rts) (rs : plist place_rfn rts) (sls : struct_layout_spec) (st : syn_type) T :
+ ⌜st = sls⌠∗ (* TODO: maybe make this more flexible? *)
+ foldr (λ '((existT rt1 (lt1, r1)), (x, st)) T,
+ λ L, subsume_full E L (l atst{sls}â‚— x â—â‚—[Ï€, Owned false] r1 @ lt1) (l atst{sls}â‚— x â—â‚—[Ï€, Owned false] .@ â— uninit st) T)
+ T (zip (hpzipl rts lts rs) (sls_fields sls)) L -∗
+ subsume_full E L (l â—â‚—[Ï€, Owned wl] #rs @ StructLtype lts sls) (l â—â‚—[Ï€, Owned wl] .@ â— uninit st) T.
+ Proof.
+ (* TODO *)
+ Abort.
+
+ Lemma subsume_place_struct π E L wl l {rts1 rts2} (lts1 : hlist ltype rts1) (lts2 : hlist ltype rts2) (rs1 : plist place_rfn rts1) (rs2 : plist place_rfn rts2) sls1 sls2 T :
+ ⌜sls1 = sls2⌠∗ foldr (λ '((existT rt1 (lt1, r1), existT rt2 (lt2, r2)), (x, st)) T,
+ λ L, subsume_full E L (l atst{sls1}â‚— x â—â‚—[Ï€, Owned false] r1 @ lt1) (l atst{sls1}â‚— x â—â‚—[Ï€, Owned false] r2 @ lt2) T)
+ T (zip (zip (hpzipl rts1 lts1 rs1) (hpzipl rts2 lts2 rs2)) (sls_fields sls1)) L -∗
+ subsume_full E L (l â—â‚—[Ï€, Owned wl] #rs1 @ StructLtype lts1 sls1) (l â—â‚—[Ï€, Owned wl] #rs2 @ StructLtype lts2 sls2) T.
+ Proof.
+ (* TODO *)
+ Abort.
+ *)
+ (* TODO: owned subtype instances for deinit *)
+
+ (** CastLtypeToType *)
+ Definition hlist_list_of {A} {F : A → Type} (l : list A) (hl : hlist F l) := l.
+ Fixpoint cast_ltype_to_type_iter (E : elctx) (L : llctx) {rts} (lts : hlist ltype rts) : (hlist type rts → iProp Σ) → iProp Σ :=
+ match lts as rts2 return (hlist type (hlist_list_of _ rts2) → iProp Σ) → iProp Σ with
+ | +[] => λ T, T +[]
+ | lt +:: lts => λ T,
+ cast_ltype_to_type E L lt (λ ty,
+ cast_ltype_to_type_iter E L lts (λ tys, T (ty +:: tys)))
+ end.
+ Local Lemma cast_ltype_to_type_iter_elim E L {rts} (lts : hlist ltype rts) T :
+ cast_ltype_to_type_iter E L lts T -∗
+ ∃ tys : hlist type rts, T tys ∗ ⌜Forall (λ '(existT x (lt1, lt2)), full_eqltype E L lt1 lt2) (hzipl2 rts lts ((λ X : Type, OfTy) +<$> tys))âŒ.
+ Proof.
+ iIntros "HT".
+ iInduction rts as [ | rt rts] "IH"; inv_hlist lts; simpl.
+ { iExists _. iFrame. iPureIntro. done. }
+ intros lt lts. simpl.
+ iDestruct "HT" as "(%ty & %Heqt & HT)".
+ iPoseProof ("IH" with "HT") as "(%tys & HT & %Heqts)".
+ iExists _. iFrame. iPureIntro. simpl. econstructor; done.
+ Qed.
+ Lemma cast_ltype_to_type_struct E L {rts} (lts : hlist ltype rts) sls T :
+ cast_ltype_to_type_iter E L lts (λ tys, T (struct_t sls tys))
+ ⊢ cast_ltype_to_type E L (StructLtype lts sls) T.
+ Proof.
+ iIntros "HT".
+ (*Search "struct" "eq".*)
+ iPoseProof (cast_ltype_to_type_iter_elim with "HT") as "(%tys & HT & %Heqts)".
+ iExists _. iFrame. iPureIntro.
+ etrans; last apply struct_t_unfold_full_eqltype.
+ eapply (struct_full_eqltype _ _ lts).
+ eapply Forall_impl; first apply Heqts. intros [? []]; done.
+ Qed.
+ Global Instance cast_ltype_to_type_struct_inst E L {rts} (lts : hlist ltype rts) sls :
+ CastLtypeToType E L (StructLtype lts sls) := λ T, i2p (cast_ltype_to_type_struct E L lts sls T).
+
+ Lemma struct_zst_empty_typed π sls sl :
+ struct_layout_spec_has_layout sls sl →
+ sls.(sls_fields) = [] →
+ sl.(sl_members) = [] →
+ ⊢ zst_val â—áµ¥{Ï€} -[] @ struct_t sls +[].
+ Proof.
+ intros Hsl Hfields Hmem.
+ rewrite /ty_own_val/=.
+ iExists sl. iR. rewrite Hfields. iR.
+ iSplitR. { iPureIntro. rewrite /has_layout_val /ly_size /layout_of Hmem //. }
+ by rewrite Hmem.
+ Qed.
+
+ (** Struct initialization *)
+ (* options:
+ - fold_list
+ + this might just be nicer.
+ + can't work, because we need to execute the WP.
+ - foldr
+ - custom fixpoint for easier induction
+ *)
+ Fixpoint struct_init_fold π E L (fields : list (string * expr)) (sts : list (string * syn_type)) (T : ∀ (L : llctx) (rts : list Type), list val → hlist type rts → plist id rts → iProp Σ) : iProp Σ :=
+ match fields, sts with
+ | [], [] =>
+ T L [] [] +[] -[]
+ | (name, init) :: fields, (name2, st) :: sts =>
+ (* first check recursively, otherwise Coq takes forever to check the definition. *)
+ struct_init_fold π E L fields sts (λ L2 rts vs tys rs,
+ typed_val_expr π E L2 init (λ L3 v rt ty r,
+ ⌜name = name2⌠∗ ⌜ty.(ty_syn_type) = st⌠∗
+ T L3 (rt :: rts) (v :: vs) (ty +:: tys) (r -:: rs)))%I
+ | _, _ => False
+ end.
+
+ (*
+ Lemma struct_init_fold_elim π E L fields sts T :
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ struct_init_fold π E L fields sts T -∗
+ ∃ (vs : list val) (rts : list Type) (tys : hlist type rts) (rs : plist id rs),
+ ([∗ list] a; b ∈ fields; sts,
+ let
+ True).
+ ⌜fields .*1 = sts.*1⌠∗
+ .
+ *)
+
+ (* TODO Move *)
+ Definition typed_val_expr_cont_t := llctx → val → ∀ (rt : Type), type rt → rt → iProp Σ.
+ (*Local Lemma typed_struct_init' π E L *)
+ Lemma type_struct_init π E L (sls : struct_layout_spec) (fields : list (string * expr)) (T : typed_val_expr_cont_t) :
+ ⌜struct_layout_spec_is_layoutable sls⌠∗
+ struct_init_fold π E L fields sls.(sls_fields) (λ L2 rts vs tys rs,
+ ∀ v, T L2 v _ (struct_t sls tys) (pmap (λ _ a, #a) rs))
+ ⊢ typed_val_expr π E L (StructInit sls fields) T.
+ Proof.
+ iIntros "(%Hly & HT)". destruct Hly as (sl & Hsl).
+ iIntros (?) "#CTX #HE HL Hc".
+ rewrite /StructInit/StructInit' /use_struct_layout_alg' Hsl /=.
+ specialize (use_struct_layout_alg_inv _ _ Hsl) as (field_lys & Halg & Hfields).
+ specialize (struct_layout_alg_has_fields _ _ _ Halg) as ->.
+ move: Halg Hfields. remember (sl_members sl) as all_lys eqn: Hall_lys => Halg Hfields.
+
+ (* TODO: figure out how to prove this nicely. *)
+ (* point: I only need it in the last step, in the struct_t part. *)
+ (* I should generalize the wp reasoning and only use the struct stuff in the last part.
+ rather: I should just specify the value I get, and then the rest works with the v.
+ *)
+
+
+ (*
+ iInduction all_lys as [ | ly all_lys] "IH" forall (sl Hsl Hall_lys Halg).
+ - simpl in *. iApply (wp_concat _ _ []). iNext. iIntros "Hcred".
+ apply Forall2_nil_inv_r in Hfields.
+ rewrite Hfields. destruct fields as [ | [] ]; simpl; last done.
+ iApply ("Hc" with "HL [] HT"). iApply struct_zst_empty_typed; done.
+ -
+ *)
+ Admitted.
+
+ (* TODO prove_place_cond *)
+
+ (* TODO resolve hgost *)
+
+End rules.
+
+(* Need this for unification to figure out how to apply typed_place lemmas -- if the plist simplifies, unification will be stuck *)
+Arguments plist : simpl never.
+
+From refinedrust Require Import int.
+Section test.
+ Context `{!typeGS Σ}.
+
+ Definition test_rt : list Type := [Z: Type; Z : Type].
+ Definition test_lts : hlist ltype test_rt := (â— int i32)%I +:: (â— int i32)%I +:: +[].
+ Definition test_rfn : plist place_rfn test_rt := #32 -:: #22 -:: -[].
+
+ Lemma bla : hnth (UninitLtype UnitSynType) test_lts 1 = (â— int i32)%I.
+ Proof. simpl. done. Abort.
+ Lemma bla : pnth (#()) test_rfn 1 = #22.
+ Proof. simpl. done. Abort.
+
+ Lemma bla : hlist_insert_id (unit : Type) _ test_lts 1 (â— int i32)%I = test_lts.
+ Proof.
+ simpl. rewrite /hlist_insert_id. simpl.
+ (*rewrite /list_insert_lnth. *)
+ (*generalize (list_insert_lnth test_rt unit 1).*)
+ (*simpl. intros ?. rewrite (UIP_refl _ _ e). done.*)
+ Abort.
+
+ Lemma bla : hlist_insert _ test_lts 1 _ (â— int i32)%I = test_lts.
+ Proof.
+ simpl. done.
+ Abort.
+
+ Lemma bla : plist_insert _ test_rfn 1 _ (#22) = test_rfn.
+ Proof.
+ simpl. done.
+ Abort.
+
+ Lemma bla : plist_insert_id (unit : Type) _ test_rfn 1 (#22) = test_rfn.
+ Proof.
+ simpl. cbn. done.
+ (*rewrite /plist_insert_id. cbn. *)
+ (*generalize (list_insert_lnth test_rt unit 1).*)
+ (*simpl. intros ?. rewrite (UIP_refl _ _ e). done.*)
+ Abort.
+
+ (* Options:
+ - some simplification machinery via tactic support
+ li_tactic. should just rewrite a bit.
+ - some simplification machinery via SimplifyHyp instances or so?
+ not the right way to do it. Rather specialized SimplifyHypVal or so.
+ - some simplification machinery via a new SimplifyLtype thing and have rules for judgments for that?
+ How do we capture a progress condition? via .. try to simplify, then require that it is Some. This is like SimplifyHyp
+ This seems unnecessarily expensive, since we usually need not be able to do it.
+
+
+ *)
+End test.
+
diff --git a/theories/rust_typing/program_rules.v b/theories/rust_typing/program_rules.v
new file mode 100644
index 0000000000000000000000000000000000000000..b5176e755a257de4362952d1b3e44f4edae65033
--- /dev/null
+++ b/theories/rust_typing/program_rules.v
@@ -0,0 +1,3514 @@
+From stdpp Require Import gmap.
+From refinedrust Require Export base type lft_contexts annotations ltypes programs.
+From refinedrust Require Import ltype_rules.
+From caesium Require Import lang proofmode derived lifting.
+Set Default Proof Using "Type".
+
+ (* TODO move *)
+ Lemma big_sepL_lft_incl_incl `{!typeGS Σ} E L κs κ :
+ elctx_interp E -∗ llctx_interp L -∗
+ ([∗ list] κ' ∈ κs, ⌜lctx_lft_incl E L κ' κâŒ) -∗
+ ([∗ list] κ' ∈ κs, κ' ⊑ κ).
+ Proof.
+ iIntros "#HE HL #Hincl".
+ iInduction κs as [ | κ' κs] "IH"; first done.
+ simpl. iDestruct "Hincl" as "(%Hincl & Hincl)".
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#$"; first apply Hincl.
+ iApply ("IH" with "Hincl HL").
+ Qed.
+
+
+Section typing.
+ Context `{typeGS Σ}.
+ (* NOTE: find_in_context instances should always have a sep conj in their premise, even if the LHS is just [True].
+ This is needed by the liFindInContext/ liFindHypOrTrue automation!
+ *)
+
+ (** Instances so that Lithium knows what to search for when needing to provide something *)
+ (** For locations and values, we use the ones that also find a refinement type, since it may be desirable to change it (consider e.g. changing to uninit) *)
+ Global Instance related_to_loc l Ï€ b {rt} (lt : ltype rt) (r : place_rfn rt) : RelatedTo (l â—â‚—[Ï€, b] r @ lt) | 100 :=
+ {| rt_fic := FindLocP l π |}.
+ Global Instance related_to_val v Ï€ {rt} (ty : type rt) (r : rt) : RelatedTo (v â—áµ¥{Ï€} r @ ty) | 100 :=
+ {| rt_fic := FindValP v π|}.
+ (* TODO: need a relatedto for shared ownership? *)
+
+ Global Instance related_to_named_lfts M : RelatedTo (named_lfts M) | 100 :=
+ {| rt_fic := FindNamedLfts |}.
+ Global Instance related_to_gvar_pobs {rt} γ (r : rt) : RelatedTo (gvar_pobs γ r) | 100 :=
+ {| rt_fic := FindGvarPobsP γ |}.
+
+ Global Instance related_to_credit_store n m : RelatedTo (credit_store n m) | 100 :=
+ {| rt_fic := FindCreditStore |}.
+
+ Global Instance related_to_freeable l n q k : RelatedTo (freeable_nz l n q k) | 100 :=
+ {| rt_fic := FindFreeable l |}.
+
+ Global Instance related_to_loc_in_bounds l pre suf : RelatedTo (loc_in_bounds l pre suf) | 100 :=
+ {| rt_fic := FindLocInBounds l |}.
+
+ (* TODO instances needed for the other things? *)
+
+ (** Value ownership *)
+ Lemma find_in_context_type_val_id v π T :
+ (∃ rt (ty : type rt) r, v â—áµ¥{Ï€} r @ ty ∗ T (existT rt (ty, r)))
+ ⊢ find_in_context (FindVal v π) T.
+ Proof. iDestruct 1 as (rt ty r) "[Hl HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_type_val_id_inst π v :
+ FindInContext (FindVal v π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_val_id v π T).
+
+ Lemma find_in_context_type_valp_id v π T :
+ (∃ rt (ty : type rt) r, v â—áµ¥{Ï€} r @ ty ∗ T (v â—áµ¥{Ï€} r @ ty))
+ ⊢ find_in_context (FindValP v π) T.
+ Proof. iDestruct 1 as (rt ty r) "(Hl & HT)". iExists (v â—áµ¥{Ï€} r @ ty)%I => /=. iFrame. Qed.
+ Global Instance find_in_context_type_valp_id_inst π v :
+ FindInContext (FindValP v π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_valp_id v π T).
+
+ Lemma find_in_context_type_valp_loc l π T :
+ (∃ rt (lt : ltype rt) r, l â—â‚—[Ï€, Owned false] r @ lt ∗ T (l â—â‚—[Ï€, Owned false] r @ lt))
+ ⊢ find_in_context (FindValP (val_of_loc l) π) T.
+ Proof. iDestruct 1 as (rt lt r) "(Hl & HT)". iExists (l â—â‚—[Ï€, Owned false] r @ lt)%I. iFrame. done. Qed.
+ Global Instance find_in_context_type_valp_loc_inst π l :
+ FindInContext (FindValP (val_of_loc l) π) FICSyntactic | 5 :=
+ λ T, i2p (find_in_context_type_valp_loc l π T).
+
+ Lemma find_in_context_type_val_with_rt_id {rt} v π T :
+ (∃ (ty : type rt) r, v â—áµ¥{Ï€} r @ ty ∗ T (ty, r))
+ ⊢ find_in_context (FindValWithRt rt v π) T.
+ Proof. iDestruct 1 as (ty r) "[Hl HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_type_val_with_rt_id_inst {rt} π v :
+ FindInContext (FindValWithRt rt v π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_val_with_rt_id v π T).
+
+ (* TODO: generalize to different rt to handle typaram instantiation?*)
+ Lemma own_val_subsume_id v π {rt} (r1 r2 : rt) (ty1 ty2 : type rt) T :
+ ⌜r1 = r2⌠∗ ⌜ty1 = ty2⌠∗ T
+ ⊢ subsume (Σ := Σ) (v â—áµ¥{Ï€} r1 @ ty1) (v â—áµ¥{Ï€} r2 @ ty2) T.
+ Proof.
+ iIntros "(-> & -> & $)"; eauto.
+ Qed.
+ Definition own_val_subsume_id_inst v π {rt} (r1 r2 : rt) (ty1 ty2 : type rt) :
+ Subsume (v â—áµ¥{Ï€} r1 @ ty1) (v â—áµ¥{Ï€} r2 @ ty2) :=
+ λ T, i2p (own_val_subsume_id v π r1 r2 ty1 ty2 T).
+
+ (** Location ownership *)
+ Lemma find_in_context_type_loc_id l π T:
+ (∃ rt (lt : ltype rt) r (b : bor_kind), l â—â‚—[Ï€, b] r @ lt ∗ T (existT rt (lt, r, b)))
+ ⊢ find_in_context (FindLoc l π) T.
+ Proof. iDestruct 1 as (rt lt r b) "[Hl HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_type_loc_id_inst π l :
+ FindInContext (FindLoc l π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_loc_id l π T).
+
+ Lemma find_in_context_type_opt_loc_id l π T:
+ (∃ rt (lt : ltype rt) r (b : bor_kind), l â—â‚—[Ï€, b] r @ lt ∗ T (Some (existT rt (lt, r, b))))
+ ⊢ find_in_context (FindOptLoc l π) T.
+ Proof. iDestruct 1 as (rt lt r b) "[Hl HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_type_opt_loc_id_inst π l :
+ FindInContext (FindOptLoc l π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_opt_loc_id l π T).
+ Lemma find_in_context_type_opt_loc_none l π T:
+ (True ∗ T None)
+ ⊢ find_in_context (FindOptLoc l π) T.
+ Proof. iDestruct 1 as "[_ HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_type_opt_loc_none_inst π l :
+ FindInContext (FindOptLoc l π) FICSyntactic | 10 :=
+ λ T, i2p (find_in_context_type_opt_loc_none l π T).
+
+ Lemma find_in_context_type_locp_loc l π T :
+ (∃ rt (lt : ltype rt) r (b : bor_kind), l â—â‚—[Ï€, b] r @ lt ∗ T (l â—â‚—[Ï€, b] r @ lt))
+ ⊢ find_in_context (FindLocP l π) T.
+ Proof. iDestruct 1 as (rt lt r b) "[Hl HT]". iExists (l â—â‚—[Ï€, b] r @ lt)%I => /=. iFrame. Qed.
+ Global Instance find_in_context_type_locp_loc_inst π l :
+ FindInContext (FindLocP l π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_locp_loc l π T).
+ Lemma find_in_context_type_locp_val (l : loc) π T :
+ (∃ rt (ty : type rt) r , l â—áµ¥{Ï€} r @ ty ∗ T (l â—áµ¥{Ï€} r @ ty))
+ ⊢ find_in_context (FindLocP l π) T.
+ Proof. iDestruct 1 as (rt ty r) "[Hl HT]". iExists (l â—áµ¥{Ï€} r @ ty)%I => /=. iFrame. Qed.
+ (* NOTE: important: has lower priority! If there's a location assignment available, should just use that. *)
+ Global Instance find_in_context_type_locp_val_inst π l :
+ FindInContext (FindLocP l π) FICSyntactic | 2 :=
+ λ T, i2p (find_in_context_type_locp_val l π T).
+
+ Lemma find_in_context_type_loc_with_rt_id {rt} l π T:
+ (∃ (lt : ltype rt) r (b : bor_kind), l â—â‚—[Ï€, b] r @ lt ∗ T (lt, r, b))
+ ⊢ find_in_context (FindLocWithRt rt l π) T.
+ Proof. iDestruct 1 as (lt r b) "[Hl HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_type_loc_with_rt_id_inst {rt} π l :
+ FindInContext (FindLocWithRt rt l π) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_type_loc_with_rt_id l π T).
+
+ (* used for unifying evars *)
+ Lemma own_shr_subsume_id v π {rt} (r1 r2 : rt) (κ1 κ2 : lft) (ty : type rt) T :
+ ⌜r1 = r2⌠∗ ⌜κ1 = κ2⌠∗ T
+ ⊢ subsume (Σ := Σ) (v â—â‚—{Ï€, κ1} r1 @ ty) (v â—â‚—{Ï€, κ2} r2 @ ty) T.
+ Proof.
+ iIntros "(-> & -> & $)"; eauto.
+ Qed.
+ Definition own_shr_subsume_id_inst v π {rt} (r1 r2 : rt) (κ1 κ2 : lft) (ty : type rt) :
+ Subsume (v â—â‚—{Ï€, κ1} r1 @ ty) (v â—â‚—{Ï€, κ2} r2 @ ty) :=
+ λ T, i2p (own_shr_subsume_id v π r1 r2 κ1 κ2 ty T).
+
+ (** NamedLfts *)
+ Lemma subsume_named_lfts M M' T :
+ ⌜M = M'⌠∗ T ⊢ subsume (Σ := Σ) (named_lfts M) (named_lfts M') T.
+ Proof. iIntros "(-> & $) $". Qed.
+ Global Instance subsume_named_lfts_inst M M' : Subsume (named_lfts M) (named_lfts M') :=
+ λ T, i2p (subsume_named_lfts M M' T).
+
+ Lemma find_in_context_named_lfts T:
+ (∃ M, named_lfts M ∗ T M) ⊢
+ find_in_context FindNamedLfts T.
+ Proof. iDestruct 1 as (M) "[Hn HT]". iExists _ => /=. iFrame. Qed.
+ Global Instance find_in_context_named_lfts_inst :
+ FindInContext FindNamedLfts FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_named_lfts T).
+
+ (** CreditStore *)
+ Lemma subsume_credit_store n m n' m' T :
+ ⌜n = n'⌠∗ ⌜m = m'⌠∗ T ⊢ subsume (Σ := Σ) (credit_store n m) (credit_store n' m') T.
+ Proof.
+ iIntros "(<- & <- & HT) $ //".
+ Qed.
+ Global Instance subsume_credit_store_inst n m n' m' : Subsume (credit_store n m) (credit_store n' m') :=
+ λ T, i2p (subsume_credit_store n m n' m' T).
+
+ Lemma find_in_context_credit_store T :
+ (∃ n m, credit_store n m ∗ T (n, m)) ⊢
+ find_in_context FindCreditStore T.
+ Proof.
+ iDestruct 1 as (n m) "[Hc HT]". iExists (n, m). by iFrame.
+ Qed.
+ Global Instance find_in_context_credit_store_inst :
+ FindInContext FindCreditStore FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_credit_store T).
+
+ (** FindOptLftDead *)
+ Lemma subsume_lft_dead κ1 κ2 T :
+ ⌜κ1 = κ2⌠∗ T ⊢ subsume (Σ := Σ) ([†κ1]) ([†κ2]) T.
+ Proof. iIntros "(-> & $)". eauto. Qed.
+ Global Instance subsume_lft_dead_inst κ1 κ2 :
+ Subsume ([†κ1]) ([†κ2]) := λ T, i2p (subsume_lft_dead κ1 κ2 T).
+
+ Lemma find_in_context_opt_lft_dead κ T :
+ [†κ] ∗ T true
+ ⊢ find_in_context (FindOptLftDead κ) T.
+ Proof.
+ iIntros "(Hdead & HT)". iExists true. iFrame. done.
+ Qed.
+ Global Instance find_in_context_opt_lft_dead_inst κ :
+ FindInContext (FindOptLftDead κ) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_opt_lft_dead κ T).
+
+ (* dummy instance in case we don't find it *)
+ Lemma find_in_context_opt_lft_dead_none κ T :
+ True ∗ T false
+ ⊢ find_in_context (FindOptLftDead κ) T.
+ Proof.
+ iIntros "(_ & HT)". iExists false. iFrame. simpl. done.
+ Qed.
+ Global Instance find_in_context_opt_lft_dead_none_inst κ :
+ FindInContext (FindOptLftDead κ) FICSyntactic | 10 :=
+ λ T, i2p (find_in_context_opt_lft_dead_none κ T).
+
+ (** Freeable *)
+ Lemma subsume_freeable l1 q1 n1 k1 l2 q2 n2 k2 T :
+ ⌜l1 = l2⌠∗ ⌜n1 = n2⌠∗ ⌜q1 = q2⌠∗ ⌜k1 = k2⌠∗ T
+ ⊢ subsume (freeable_nz l1 n1 q1 k1) (freeable_nz l2 n2 q2 k2) T.
+ Proof.
+ iIntros "(-> & -> & -> & -> & $)". eauto.
+ Qed.
+ Global Instance subsume_freeable_inst l1 q1 n1 k1 l2 q2 n2 k2 :
+ Subsume (freeable_nz l1 n1 q1 k1) (freeable_nz l2 n2 q2 k2) :=
+ λ T, i2p (subsume_freeable l1 q1 n1 k1 l2 q2 n2 k2 T).
+
+ Lemma find_in_context_freeable l T :
+ (∃ q n k, freeable_nz l n q k ∗ T (n, q, k))
+ ⊢ find_in_context (FindFreeable l) T.
+ Proof.
+ iDestruct 1 as (q n k) "(Ha & HT)".
+ iExists (n, q, k). by iFrame.
+ Qed.
+ Global Instance find_in_context_freeable_inst l :
+ FindInContext (FindFreeable l) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_freeable l T).
+
+ Lemma simplify_hyp_freeable l n q k T :
+ ((freeable_nz l n q k) -∗ T)
+ ⊢ simplify_hyp (freeable l n q k) T.
+ Proof.
+ iIntros "Ha Hf". iApply "Ha".
+ destruct n; done.
+ Qed.
+ Global Instance simplify_hyp_freeable_inst l n q k :
+ SimplifyHyp (freeable l n q k) (Some 0%N) :=
+ λ T, i2p (simplify_hyp_freeable l n q k T).
+
+
+ (** FindOptGvarRel *)
+ Lemma find_in_context_opt_gvar_rel γ T :
+ (∃ rt (γ' : gname) (R : rt → rt → Prop), Rel2 γ' γ R ∗ T (inl (existT rt (γ', R))))
+ ⊢ find_in_context (FindOptGvarRel γ) T.
+ Proof.
+ iIntros "(%rt & %γ' & %R & Hobs & HT)".
+ iExists _ => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_opt_gvar_rel_inst γ :
+ FindInContext (FindOptGvarRel γ) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_opt_gvar_rel γ T).
+
+ (* we have a dummy instance with lower priority for the case that we cannot find an observation in the context *)
+ Lemma find_in_context_opt_gvar_rel_dummy γ T :
+ (True ∗ T (inr ())) ⊢ find_in_context (FindOptGvarRel γ) T.
+ Proof.
+ iIntros "[_ HT]".
+ iExists _ => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_gvar_rel_dummy_inst γ :
+ FindInContext (FindOptGvarRel γ) FICSyntactic | 10 :=
+ λ T, i2p (find_in_context_opt_gvar_rel_dummy γ T).
+
+ Lemma subsume_gvar_rel {rt} γ1' γ1 γ2' γ2 (R1 R2 : rt → rt → Prop ) T :
+ ⌜γ1' = γ2'⌠∗ ⌜γ1 = γ2⌠∗ ⌜∀ x1 x2, R1 x1 x2 ↔ R2 x1 x2⌠∗ T ⊢ subsume (Σ := Σ) (Rel2 γ1' γ1 R1) (Rel2 γ2' γ2 R2) T.
+ Proof.
+ iIntros "(-> & -> & %HR & $)".
+ iIntros "Hrel". iDestruct "Hrel" as "(% & % & ? & ? & %HR')".
+ iExists _, _. iFrame. iPureIntro. by apply HR.
+ Qed.
+ Global Instance subsume_gvar_rel_inst {rt} γ1' γ1 γ2' γ2 (R1 R2 : rt → rt → Prop) : Subsume (Rel2 γ1' γ1 R1) (Rel2 γ2' γ2 R2) :=
+ λ T, i2p (subsume_gvar_rel γ1' γ1 γ2' γ2 R1 R2 T).
+
+ (** FindOptGvarPobs *)
+ Lemma find_in_context_opt_gvar_pobs γ T :
+ (∃ rt (r : rt), gvar_pobs γ r ∗ T (inl (existT rt r)))
+ ⊢ find_in_context (FindOptGvarPobs γ) T.
+ Proof.
+ iIntros "(%rt & %r & Hobs & HT)".
+ iExists _ => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_opt_gvar_pobs_inst γ :
+ FindInContext (FindOptGvarPobs γ) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_opt_gvar_pobs γ T).
+
+ (* we have a dummy instance with lower priority for the case that we cannot find an observation in the context *)
+ Lemma find_in_context_opt_gvar_pobs_dummy γ T :
+ (True ∗ T (inr ())) ⊢ find_in_context (FindOptGvarPobs γ) T.
+ Proof.
+ iIntros "[_ HT]".
+ iExists _ => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_gvar_pobs_dummy_inst γ :
+ FindInContext (FindOptGvarPobs γ) FICSyntactic | 10 :=
+ λ T, i2p (find_in_context_opt_gvar_pobs_dummy γ T).
+
+ (** FindGvarPobs *)
+ Lemma find_in_context_gvar_pobs γ T :
+ (∃ rt (r : rt), gvar_pobs γ r ∗ T ((existT rt r)))
+ ⊢ find_in_context (FindGvarPobs γ) T.
+ Proof.
+ iIntros "(%rt & %r & Hobs & HT)".
+ iExists _ => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_gvar_pobs_inst γ :
+ FindInContext (FindGvarPobs γ) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_gvar_pobs γ T).
+
+ Lemma find_in_context_gvar_pobs_p_pobs γ T :
+ (∃ rt (r : rt), gvar_pobs γ r ∗ T (gvar_pobs γ r))
+ ⊢ find_in_context (FindGvarPobsP γ) T.
+ Proof.
+ iIntros "(%rt & %r & Hobs & HT)".
+ iExists (gvar_pobs γ r) => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_gvar_pobs_p_pobs_inst γ :
+ FindInContext (FindGvarPobsP γ) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_gvar_pobs_p_pobs γ T).
+
+ Lemma find_in_context_gvar_pobs_p_obs γ T :
+ (∃ rt (r : rt), gvar_obs γ r ∗ T (gvar_obs γ r))
+ ⊢ find_in_context (FindGvarPobsP γ) T.
+ Proof.
+ iIntros "(%rt & %r & Hobs & HT)".
+ iExists (gvar_obs γ r) => /=. iFrame.
+ Qed.
+ Global Instance find_in_context_gvar_pobs_p_obs_inst γ :
+ FindInContext (FindGvarPobsP γ) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_gvar_pobs_p_obs γ T).
+
+ Lemma subsume_gvar_pobs {rt} γ (r1 r2 : rt) T :
+ ⌜r1 = r2⌠∗ T ⊢ subsume (Σ := Σ) (gvar_pobs γ r1) (gvar_pobs γ r2) T.
+ Proof. iIntros "(-> & $) $". Qed.
+ Global Instance subsume_gvar_pobs_inst {rt} γ (r1 r2 : rt) : Subsume (gvar_pobs γ r1) (gvar_pobs γ r2) :=
+ λ T, i2p (subsume_gvar_pobs γ r1 r2 T).
+
+ Lemma subsume_full_gvar_obs_pobs E L {rt} step γ (r1 r2 : rt) T :
+ (⌜r1 = r2⌠∗ (gvar_pobs γ r2 -∗ T L (True)%I)) ⊢ subsume_full E L step (gvar_obs γ r1) (gvar_pobs γ r2) T.
+ Proof.
+ iIntros "(-> & HT)".
+ iIntros (???) "#CTX #HE HL Hobs". iMod (gvar_obs_persist with "Hobs") as "#Hobs".
+ iExists _, _. iPoseProof ("HT" with "Hobs") as "$". iFrame.
+ iApply maybe_logical_step_intro. eauto with iFrame.
+ Qed.
+ Global Instance subsume_full_gvar_obs_pobs_inst E L {rt} step γ (r1 r2 : rt) : SubsumeFull E L step (gvar_obs γ r1) (gvar_pobs γ r2) :=
+ λ T, i2p (subsume_full_gvar_obs_pobs E L step γ r1 r2 T).
+
+ (** FindInherit *)
+ Lemma find_in_context_inherit {K} κ (key : K) P T :
+ Inherit κ key P ∗ T () ⊢
+ find_in_context (FindInherit κ key P) T.
+ Proof.
+ iIntros "(Hinh & HT)". iExists (). by iFrame.
+ Qed.
+ Global Instance find_in_context_inherit_inst {K} κ (key : K) P :
+ FindInContext (FindInherit κ key P) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_inherit κ key P T).
+
+ (** FindLocInBounds *)
+ Lemma find_in_context_loc_in_bounds l T :
+ (∃ pre suf, loc_in_bounds l pre suf ∗ T (loc_in_bounds l pre suf))
+ ⊢ find_in_context (FindLocInBounds l) T.
+ Proof. iDestruct 1 as (pre suf) "[??]". iExists (loc_in_bounds _ _ _) => /=. iFrame. Qed.
+ Global Instance find_in_context_loc_in_bounds_inst l :
+ FindInContext (FindLocInBounds l) FICSyntactic | 1 :=
+ λ T, i2p (find_in_context_loc_in_bounds l T).
+
+ Lemma find_in_context_loc_in_bounds_loc l T :
+ (∃ Ï€ k rt (lt : ltype rt) r, l â—â‚—[Ï€, k] r @ lt ∗ T (l â—â‚—[Ï€, k] r @ lt))
+ ⊢ find_in_context (FindLocInBounds l) T.
+ Proof. iDestruct 1 as (?????) "[??]". iExists (ltype_own _ _ _ _ _) => /=. iFrame. Qed.
+ Global Instance find_in_context_loc_in_bounds_loc_inst l :
+ FindInContext (FindLocInBounds l) FICSyntactic | 10 :=
+ λ T, i2p (find_in_context_loc_in_bounds_loc l T).
+
+ Lemma subsume_loc_in_bounds (l1 l2 : loc) (pre1 suf1 pre2 suf2 : nat) T :
+ ⌜l1.1 = l2.1⌠∗ ⌜(l1.2 + pre2 ≤ l2.2 + pre1)%Z⌠∗ ⌜(l2.2 + suf2 ≤ l1.2 + suf1)%Z⌠∗ T
+ ⊢ subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) T.
+ Proof.
+ iIntros "(% & % & % & $)". by iApply loc_in_bounds_offset.
+ Qed.
+ Global Instance subsume_loc_in_bounds_inst (l1 l2 : loc) (pre1 suf1 pre2 suf2 : nat) :
+ Subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) | 100 :=
+ λ T, i2p (subsume_loc_in_bounds l1 l2 pre1 suf1 pre2 suf2 T).
+
+ Lemma subsume_loc_in_bounds_evar1 (l1 l2 : loc) (pre1 suf1 pre2 suf2 : nat) T `{!IsProtected pre2} :
+ ⌜pre1 = pre2⌠∗ subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre1 suf2) T
+ ⊢ subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) T.
+ Proof. iIntros "(-> & $)". Qed.
+ Global Instance subsume_loc_in_bounds_evar1_inst (l1 l2 : loc) (pre1 suf1 pre2 suf2 : nat) `{!IsProtected pre2} :
+ Subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) | 20 :=
+ λ T, i2p (subsume_loc_in_bounds_evar1 l1 l2 pre1 suf1 pre2 suf2 T).
+ Lemma subsume_loc_in_bounds_evar2 (l1 l2 : loc) (pre1 suf1 pre2 suf2 : nat) T `{!IsProtected suf2} :
+ ⌜suf1 = suf2⌠∗ subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf1) T
+ ⊢ subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) T.
+ Proof. iIntros "(-> & $)". Qed.
+ Global Instance subsume_loc_in_bounds_evar2_inst (l1 l2 : loc) (pre1 suf1 pre2 suf2 : nat) `{!IsProtected suf2} :
+ Subsume (loc_in_bounds l1 pre1 suf1) (loc_in_bounds l2 pre2 suf2) | 20 :=
+ λ T, i2p (subsume_loc_in_bounds_evar2 l1 l2 pre1 suf1 pre2 suf2 T).
+
+ (* TODO: maybe generalize this to have a TC or so so? *)
+ Lemma subsume_place_loc_in_bounds π (l1 l2 : loc) {rt} (lt : ltype rt) k r (pre suf : nat) T :
+ ⌜l1 = l2⌠∗ ⌜pre = 0%nat⌠∗ li_tactic (compute_layout_goal (ltype_st lt)) (λ ly,
+ ⌜suf ≤ ly_size ly⌠∗ (l1 â—â‚—[Ï€, k] r @ lt -∗ T))
+ ⊢ subsume (l1 â—â‚—[Ï€, k] r @ lt) (loc_in_bounds l2 pre suf) T.
+ Proof.
+ rewrite /compute_layout_goal. iIntros "(-> & -> & %ly & %Halg & %Ha & HT)".
+ iIntros "Ha". iPoseProof (ltype_own_loc_in_bounds with "Ha") as "#Hb"; first done.
+ iPoseProof ("HT" with "Ha") as "$".
+ iApply (loc_in_bounds_shorten_suf with "Hb"). lia.
+ Qed.
+ Global Instance subsume_place_loc_in_bounds_inst π (l1 l2 : loc) {rt} (lt : ltype rt) k r (pre suf : nat) :
+ Subsume (l1 â—â‚—[Ï€, k] r @ lt) (loc_in_bounds l2 pre suf) :=
+ λ T, i2p (subsume_place_loc_in_bounds π l1 l2 lt k r pre suf T).
+
+ (** Simplify instances *)
+ Lemma simplify_goal_lft_dead_list κs T :
+ ([∗ list] κ ∈ κs, [†κ]) ∗ T ⊢ simplify_goal (lft_dead_list κs) T.
+ Proof.
+ rewrite /simplify_goal. iFrame. eauto.
+ Qed.
+ Global Instance simplify_goal_lft_dead_list_inst κs :
+ SimplifyGoal (lft_dead_list κs) (Some 0%N) := λ T, i2p (simplify_goal_lft_dead_list κs T).
+
+ (** ** SubsumeFull instances *)
+ (** We have low-priority instances to escape into subtyping judgments *)
+ (* TODO should make compatible with mem_casts? *)
+ (*
+ Lemma subsume_full_own_val {rt1 rt2} π E L step v (ty1 : type rt1) (ty2 : type rt2) r1 r2 T :
+ weak_subtype E L r1 r2 ty1 ty2 (T L True) -∗
+ subsume_full E L step (v â—áµ¥{Ï€} r1 @ ty1) (v â—áµ¥{Ï€} r2 @ ty2) T.
+ Proof.
+ iIntros "HT" (F ?) "#CTX #HE HL Hv".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & HL & HT)".
+ iDestruct "Hincl" as "(_ & _ & #Hincl & _)".
+ iExists _, True%I. iFrame.
+ iApply maybe_logical_step_intro. rewrite right_id.
+ by iPoseProof ("Hincl" with "Hv") as "$".
+ Qed.
+ (* low priority, more specific instances should trigger first *)
+ Global Instance subsume_full_own_val_inst {rt1 rt2} π E L step v (ty1 : type rt1) (ty2 : type rt2) r1 r2 :
+ SubsumeFull E L step (v â—áµ¥{Ï€} r1 @ ty1) (v â—áµ¥{Ï€} r2 @ ty2) | 100 :=
+ λ T, i2p (subsume_full_own_val π E L step v ty1 ty2 r1 r2 T).
+ *)
+
+ Lemma subsume_full_value_evar π E L step v {rt} (ty : type rt) (r1 r2 : rt) T :
+ ⌜r1 = r2⌠∗ T L True%I
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} r1 @ ty) (v â—áµ¥{Ï€} r2 @ ty) T.
+ Proof.
+ iIntros "(-> & HT)". by iApply subsume_full_id.
+ Qed.
+ Global Instance subsume_full_value_evar_inst π E L step v {rt} (ty : type rt) (r1 r2 : rt) :
+ SubsumeFull E L step (v â—áµ¥{Ï€} r1 @ ty) (v â—áµ¥{Ï€} r2 @ ty) | 5 :=
+ λ T, i2p (subsume_full_value_evar π E L step v ty r1 r2 T).
+
+ Lemma subsume_full_owned_subtype π E L step v {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 T :
+ owned_subtype π E L false r1 r2 ty1 ty2 (λ L', T L' True%I)
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} r1 @ ty1) (v â—áµ¥{Ï€} r2 @ ty2) T.
+ Proof.
+ iIntros "HT" (???) "#CTX #HE HL Hv".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & Hincl & HL & HT)".
+ iDestruct "Hincl" as "(_ & _ & Hincl)".
+ iPoseProof ("Hincl" with "Hv") as "Hv".
+ iExists _, _. iFrame. iApply maybe_logical_step_intro.
+ by iFrame.
+ Qed.
+ Global Instance subsume_full_uninit_owned_subtype_inst π E L step v {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 :
+ SubsumeFull E L step (v â—áµ¥{Ï€} r1 @ ty1)%I (v â—áµ¥{Ï€} r2 @ ty2)%I | 100 :=
+ λ T, i2p (subsume_full_owned_subtype π E L step v ty1 ty2 r1 r2 T).
+
+ (* TODO: how does the evar thing work here? *)
+ Lemma subsume_full_own_loc_bk_evar {rt1 rt2} π E L step l (lt1 : ltype rt1) (lt2 : ltype rt2) b1 b2 r1 r2 T `{!IsProtected b2}:
+ ⌜b1 = b2⌠∗ subsume_full E L step (l â—â‚—[Ï€, b1] r1 @ lt1) (l â—â‚—[Ï€, b2] r2 @ lt2) T
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, b1] r1 @ lt1) (l â—â‚—[Ï€, b2] r2 @ lt2) T.
+ Proof. iIntros "(-> & HT)". done. Qed.
+ Global Instance subsume_full_own_loc_bk_evar_inst {rt1 rt2} π E L step l (lt1 : ltype rt1) (lt2 : ltype rt2) r1 r2 b1 b2 `{!IsProtected b2}:
+ SubsumeFull E L step (l â—â‚—[Ï€, b1] r1 @ lt1) (l â—â‚—[Ï€, b2] r2 @ lt2) | 1000 :=
+ λ T, i2p (subsume_full_own_loc_bk_evar π E L step l lt1 lt2 b1 b2 r1 r2 T).
+
+ Lemma subsume_full_own_loc_owned {rt1 rt2} π E L l (lt1 : ltype rt1) (lt2 : ltype rt2) r1 r2 T :
+ owned_subltype_step π E L r1 r2 lt1 lt2 T
+ ⊢ subsume_full E L true (l â—â‚—[Ï€, Owned false] r1 @ lt1) (l â—â‚—[Ï€, Owned false] r2 @ lt2) T.
+ Proof.
+ iIntros "HT" (???) "#CTX #HE HL Hl".
+ iMod ("HT" with "[//] CTX HE HL Hl") as "(%L' & %R & Hstep & %Hly & HL & HT)".
+ iExists L', R. by iFrame.
+ Qed.
+ Global Instance subsume_full_own_loc_owned_inst {rt1 rt2} π E L l (lt1 : ltype rt1) (lt2 : ltype rt2) r1 r2 :
+ SubsumeFull E L true (l â—â‚—[Ï€, Owned false] r1 @ lt1) (l â—â‚—[Ï€, Owned false] r2 @ lt2) | 1001 :=
+ λ T, i2p (subsume_full_own_loc_owned π E L l lt1 lt2 r1 r2 T).
+
+ (* TODO should make compatible with location simplification *)
+ Lemma subsume_full_own_loc {rt1 rt2} π E L step l (lt1 : ltype rt1) (lt2 : ltype rt2) b1 b2 r1 r2 T :
+ ⌜lctx_bor_kind_direct_incl E L b2 b1⌠∗ weak_subltype E L b2 r1 r2 lt1 lt2 (T L True%I)
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, b1] r1 @ lt1) (l â—â‚—[Ï€, b2] r2 @ lt2) T.
+ Proof.
+ iIntros "(%Hincl & HT)" (F ??) "#CTX #HE HL Hl".
+ iPoseProof (lctx_bor_kind_direct_incl_use with "HE HL") as "#Hincl"; first done.
+ iPoseProof (ltype_bor_kind_direct_incl with "Hincl Hl") as "Hl".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl' & HL & HT)".
+ iMod (ltype_incl_use with "Hincl' Hl") as "Hl"; first done.
+ iExists _, True%I. iFrame. iApply maybe_logical_step_intro. by iFrame.
+ Qed.
+ Global Instance subsume_full_own_loc_inst {rt1 rt2} π E L step l (lt1 : ltype rt1) (lt2 : ltype rt2) r1 r2 b1 b2 :
+ SubsumeFull E L step (l â—â‚—[Ï€, b1] r1 @ lt1) (l â—â‚—[Ï€, b2] r2 @ lt2) | 1002 :=
+ λ T, i2p (subsume_full_own_loc π E L step l lt1 lt2 b1 b2 r1 r2 T).
+
+ (** ** Subtyping instances: [weak_subtype] *)
+ Lemma weak_subtype_id E L {rt} (ty : type rt) r T :
+ T ⊢ weak_subtype E L r r ty ty T.
+ Proof.
+ iIntros "$" (??) "?? $". iApply type_incl_refl.
+ Qed.
+ Global Instance weak_subtype_refl_inst E L {rt} (ty : type rt) r :
+ Subtype E L r r ty ty := λ T, i2p (weak_subtype_id E L ty r T).
+
+ Lemma weak_subtype_evar1 E L {rt} (ty : type rt) r r2 T :
+ ⌜r = r2⌠∗ T ⊢ weak_subtype E L r r2 ty ty T.
+ Proof.
+ iIntros "(<- & $)" (??) "?? $". iApply type_incl_refl.
+ Qed.
+ (* We want this to work even if [r2] has shape e.g. [Z.of_nat ?evar], so we do not actually require this to be an evar.
+ Instead, we have a super low priority so that more specific instances will get picked first. *)
+ Global Instance weak_subtype_evar1_inst E L {rt} (ty : type rt) r r2 :
+ Subtype E L r r2 ty ty | 200 := λ T, i2p (weak_subtype_evar1 E L ty r r2 T).
+
+ Lemma weak_subtype_evar2 E L {rt} (ty ty2 : type rt) r r2 T :
+ ⌜ty = ty2⌠∗ weak_subtype E L r r2 ty ty T ⊢ weak_subtype E L r r2 ty ty2 T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subtype_evar2_inst E L {rt} (ty : type rt) r r2 `{!IsProtected ty2} :
+ Subtype E L r r2 ty ty2 | 100 := λ T, i2p (weak_subtype_evar2 E L ty ty2 r r2 T).
+
+ (** ** Subtyping instances: [mut_subtype] *)
+ Lemma mut_subtype_id E L {rt} (ty : type rt) T :
+ T ⊢ mut_subtype E L ty ty T.
+ Proof.
+ iIntros "$". iPureIntro. reflexivity.
+ Qed.
+ Global Instance mut_subtype_refl_inst E L {rt} (ty : type rt) :
+ MutSubtype E L ty ty := λ T, i2p (mut_subtype_id E L ty T).
+
+ Lemma mut_subtype_evar E L {rt} (ty ty2 : type rt) T :
+ ⌜ty = ty2⌠∗ T ⊢ mut_subtype E L ty ty2 T.
+ Proof. iIntros "(<- & $)". iPureIntro. reflexivity. Qed.
+ Global Instance mut_subtype_evar_inst E L {rt} (ty : type rt) `{!IsProtected ty2} :
+ MutSubtype E L ty ty2 | 100 := λ T, i2p (mut_subtype_evar E L ty ty2 T).
+
+ (** ** Subtyping instances: [mut_eqtype] *)
+ Lemma mut_eqtype_id E L {rt} (ty : type rt) T :
+ T ⊢ mut_eqtype E L ty ty T.
+ Proof.
+ iIntros "$". iPureIntro. reflexivity.
+ Qed.
+ Global Instance mut_eqtype_refl_inst E L {rt} (ty : type rt) :
+ MutEqtype E L ty ty := λ T, i2p (mut_eqtype_id E L ty T).
+
+ Lemma mut_eqtype_evar E L {rt} (ty ty2 : type rt) T :
+ ⌜ty = ty2⌠∗ T ⊢ mut_eqtype E L ty ty2 T.
+ Proof. iIntros "(<- & $)". iPureIntro. reflexivity. Qed.
+ Global Instance mut_eqtype_evar_inst E L {rt} (ty : type rt) `{!IsProtected ty2} :
+ MutEqtype E L ty ty2 | 100 := λ T, i2p (mut_eqtype_evar E L ty ty2 T).
+
+
+ (** ** Subtyping instances: [weak_subltype] *)
+ (* Instances for [weak_subltype] include:
+ - identity
+ - folding/unfolding
+ - structural lifting
+ - lifetime subtyping; below Uniq, we can only replace by equivalences. Thus, we need to prove subtyping in both directions. We may want to have a dedicated judgment for that.
+ We, however, cannot trigger [resolve_ghost], as it needs to open stuff up and thus needs steps.
+
+ The instances, especially for folding/unfolding, should use the structure of the second lt (the target) as guidance for incrementally manipulating the first one.
+ After making the heads match, structurally descend.
+ *)
+
+ Lemma weak_subltype_id E L {rt} (lt : ltype rt) k r T :
+ T ⊢ weak_subltype E L k r r lt lt T.
+ Proof. iIntros "$" (??) "_ _ $". iApply ltype_incl_refl. Qed.
+ Global Instance weak_subltype_refl_inst E L {rt} (lt : ltype rt) k r : SubLtype E L k r r lt lt | 1 :=
+ λ T, i2p (weak_subltype_id E L lt k r T).
+
+ Lemma weak_subltype_evar1 E L {rt} (lt1 : ltype rt) k r1 r2 T :
+ ⌜r1 = r2⌠∗ T ⊢ weak_subltype E L k r1 r2 lt1 lt1 T.
+ Proof.
+ iIntros "(<- & HT)" (??) "#CTX #HE HL". iFrame. iApply ltype_incl_refl.
+ Qed.
+ (*Global Instance weak_subltype_evar1_inst E L {rt} (lt1 : ltype rt) k r1 r2 :*)
+ (*SubLtype E L k r1 r2 (lt1)%I (lt1)%I | 1 :=*)
+ (*λ T, i2p (weak_subltype_evar1 E L lt1 k r1 r2 T).*)
+ Global Instance weak_subltype_evar1_inst E L {rt} (lt1 : ltype rt) k r1 r2 :
+ SubLtype E L k r1 r2 (lt1)%I (lt1)%I | 1000 :=
+ λ T, i2p (weak_subltype_evar1 E L lt1 k r1 r2 T).
+
+ Lemma weak_subltype_evar2 E L {rt} (lt1 lt2 : ltype rt) k r1 r2 T :
+ ⌜lt1 = lt2⌠∗ weak_subltype E L k r1 r2 lt1 lt1 T ⊢ weak_subltype E L k r1 r2 lt1 lt2 T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subltype_evar2_inst E L {rt} (lt1 lt2 : ltype rt) k r1 r2 `{!IsProtected lt2} :
+ SubLtype E L k r1 r2 (lt1)%I (lt2)%I | 100 :=
+ λ T, i2p (weak_subltype_evar2 E L lt1 lt2 k r1 r2 T).
+
+ (* Escape into the stronger subtyping judgment. Note: should not be used when lt2 is an evar. *)
+ Lemma weak_subltype_base E L {rt} (lt1 lt2 : ltype rt) k r1 r2 T :
+ ⌜r1 = r2⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ weak_subltype E L k r1 r2 lt1 lt2 T.
+ Proof.
+ iIntros "(<- & %Hsub & HT)" (??) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hsub"; first done.
+ iFrame. iPoseProof ("Hsub" $! _ _) as "(Ha1 & _)". done.
+ Qed.
+ Global Instance weak_subltype_base_inst E L {rt} (lt1 lt2 : ltype rt) k r1 r2 :
+ SubLtype E L k r1 r2 (lt1)%I (lt2)%I | 200 :=
+ λ T, i2p (weak_subltype_base E L lt1 lt2 k r1 r2 T).
+
+ Lemma weak_subltype_ofty_ofty_owned_in E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) wl r1 r2 T :
+ (∃ r2', ⌜r2 = #r2'⌠∗ weak_subtype E L r1 r2' ty1 ty2 T)
+ ⊢ weak_subltype E L (Owned wl) (#r1) r2 (◠ty1) (◠ty2) T.
+ Proof.
+ iIntros "(%r2' & -> & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ by iApply type_ltype_incl_owned_in.
+ Qed.
+ Global Instance weak_subltype_ofty_ofty_owned_in_inst E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) wl r1 r2 : SubLtype E L (Owned wl) #r1 r2 (â— ty1)%I (â— ty2)%I | 10 :=
+ λ T, i2p (weak_subltype_ofty_ofty_owned_in E L ty1 ty2 wl r1 r2 T).
+
+ Lemma weak_subltype_ofty_ofty_shared_in E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) κ r1 r2 T :
+ (∃ r2', ⌜r2 = #r2'⌠∗ weak_subtype E L r1 r2' ty1 ty2 T)
+ ⊢ weak_subltype E L (Shared κ) (#r1) (r2) (◠ty1) (◠ty2) T.
+ Proof.
+ iIntros "(%r2' & -> & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ by iApply type_ltype_incl_shared_in.
+ Qed.
+ Global Instance weak_subltype_ofty_ofty_shared_in_inst E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) κ r1 r2 : SubLtype E L (Shared κ) #r1 r2 (◠ty1)%I (◠ty2)%I | 10 :=
+ λ T, i2p (weak_subltype_ofty_ofty_shared_in E L ty1 ty2 κ r1 r2 T).
+
+ (* Note: no similar rule for Uniq -- we can just get strong subtyping through the base lemmas *)
+
+ (** ** Subtyping instances: [mut_eqltype] *)
+ Lemma mut_eqltype_id E L {rt} (lt : ltype rt) T :
+ T ⊢ mut_eqltype E L lt lt T.
+ Proof. iIntros "$". iPureIntro. reflexivity. Qed.
+ Global Instance mut_eqltype_refl_inst E L {rt} (lt : ltype rt) : MutEqLtype E L lt lt | 1 :=
+ λ T, i2p (mut_eqltype_id E L lt T).
+
+ Lemma mut_eqltype_base_evar E L {rt} (lt1 lt2 : ltype rt) T :
+ ⌜lt1 = lt2⌠∗ T
+ ⊢ mut_eqltype E L lt1 lt2 T.
+ Proof.
+ iIntros "(<- & $)". iPureIntro. reflexivity.
+ Qed.
+ Global Instance mut_eqltype_base_evar_inst E L {rt} (lt1 lt2 : ltype rt) `{!IsProtected lt2} :
+ MutEqLtype E L (lt1)%I (lt2)%I | 100 := λ T, i2p (mut_eqltype_base_evar E L lt1 lt2 T).
+
+ Lemma mut_eqltype_ofty E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) T :
+ mut_eqtype E L ty1 ty2 T
+ ⊢ mut_eqltype E L (◠ty1) (◠ty2) T.
+ Proof.
+ iIntros "(%Heqt & $)".
+ iPureIntro. eapply full_eqtype_eqltype; done.
+ Qed.
+ Global Instance mut_eqltype_ofty_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) :
+ MutEqLtype E L (◠ty1)%I (◠ty2)%I | 5 := λ T, i2p (mut_eqltype_ofty E L ty1 ty2 T).
+
+ (** ** Subtyping instances: [mut_subltype] *)
+ Lemma mut_subltype_id E L {rt} (lt : ltype rt) T :
+ T ⊢ mut_subltype E L lt lt T.
+ Proof. iIntros "$". iPureIntro. reflexivity. Qed.
+ Global Instance mut_subltype_refl_inst E L {rt} (lt : ltype rt) : MutSubLtype E L lt lt | 1 :=
+ λ T, i2p (mut_subltype_id E L lt T).
+
+ Lemma mut_subltype_base_evar E L {rt} (lt1 lt2 : ltype rt) T :
+ ⌜lt1 = lt2⌠∗ T
+ ⊢ mut_subltype E L lt1 lt2 T.
+ Proof.
+ iIntros "(<- & $)". iPureIntro. reflexivity.
+ Qed.
+ Global Instance mut_subltype_base_evar_inst E L {rt} (lt1 lt2 : ltype rt) `{!IsProtected lt2} :
+ MutSubLtype E L (lt1)%I (lt2)%I | 100 := λ T, i2p (mut_subltype_base_evar E L lt1 lt2 T).
+
+ (** ** Subtyping instances: [owned_subltype_step] *)
+
+ (** ** casts *)
+ Lemma cast_ltype_to_type_id E L {rt} (ty : type rt) T :
+ T ty ⊢ cast_ltype_to_type E L (◠ty) T.
+ Proof.
+ iIntros "HT". iExists ty. iFrame "HT". done.
+ Qed.
+ Global Instance cast_ltype_to_type_id_inst E L {rt} (ty : type rt) :
+ CastLtypeToType E L (â— ty)%I :=
+ λ T, i2p (cast_ltype_to_type_id E L ty T).
+
+
+ (** ** prove_place_cond *)
+ Lemma prove_place_cond_ofty_refl E L bmin {rt} (ty : type rt) T :
+ T (ResultWeak eq_refl) ⊢ prove_place_cond E L bmin (◠ty) (◠ty) T.
+ Proof.
+ iIntros "HT" (F ?) "#CTX HE $". iExists (ResultWeak eq_refl). iFrame.
+ iApply typed_place_cond_ty_refl_ofty.
+ Qed.
+ (* high-priority instance for reflexivity *)
+ Global Instance prove_place_cond_ofty_refl_inst E L bmin {rt} (ty : type rt) :
+ ProvePlaceCond E L bmin (◠ty)%I (◠ty)%I | 2 := λ T, i2p (prove_place_cond_ofty_refl E L bmin ty T).
+
+ Lemma prove_place_cond_trivial E L bmin {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) T :
+ ⌜ltype_st lt1 = ltype_st lt2⌠∗ T ResultStrong ⊢ prove_place_cond E L bmin lt1 lt2 T.
+ Proof.
+ iIntros "(Hst & HT)" (F ?) "#CTX HE $".
+ iExists ResultStrong. by iFrame.
+ Qed.
+ (* very low-priority instance *)
+ Global Instance prove_place_cond_trivial_inst E L bmin {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ ProvePlaceCond E L bmin lt1 lt2 | 200 := λ T, i2p (prove_place_cond_trivial E L bmin lt1 lt2 T).
+
+ (** Lemmas to eliminate BlockedLtype on either side *)
+ Lemma prove_place_cond_blocked_r_Uniq E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ κ' γ T :
+ ⌜lctx_lft_incl E L κ' κ⌠∗ prove_place_cond E L (Uniq κ γ) lt (◠ty) T ⊢
+ prove_place_cond E L (Uniq κ γ) lt (BlockedLtype ty κ') T.
+ Proof.
+ iIntros "(%Hincl & HT)".
+ iIntros (F ?) "#CTX HE HL".
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hincl"; first done.
+ iMod ("HT" with "[//] CTX HE HL") as "($ & %upd & Hcond & HT)".
+ iExists upd. iFrame.
+ destruct upd.
+ - subst rt2. simpl. iDestruct "Hcond" as "(%Heq & Heq & Hub)".
+ rewrite (UIP_refl _ _ Heq).
+ iExists eq_refl. cbn. simp_ltypes.
+ iSplitL "Heq"; first done.
+ iApply imp_unblockable_shorten'; first done.
+ iApply blocked_imp_unblockable.
+ - simp_ltypes. done.
+ Qed.
+ Global Instance prove_place_cond_blocked_r_Uniq_inst E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ κ' γ :
+ ProvePlaceCond E L (Uniq κ γ) lt (BlockedLtype ty κ') | 5 := λ T, i2p (prove_place_cond_blocked_r_Uniq E L ty lt κ κ' γ T).
+
+ Lemma prove_place_cond_blocked_r_Owned E L {rt rt2} (lt : ltype rt2) (ty : type rt) κ' wl T :
+ prove_place_cond E L (Owned wl) lt (BlockedLtype ty κ') T ⊢
+ prove_place_cond E L (Owned wl) lt (BlockedLtype ty κ') T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "($ & %upd & Hcond & HT)".
+ iExists upd. by iFrame.
+ Qed.
+ Global Instance prove_place_cond_blocked_r_Owned_inst E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ' wl :
+ ProvePlaceCond E L (Owned wl) lt (BlockedLtype ty κ') | 5 := λ T, i2p (prove_place_cond_blocked_r_Owned E L lt ty κ' wl T).
+ (* no shared lemma *)
+
+ Lemma prove_place_cond_blocked_l_Uniq E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ κ' γ T :
+ prove_place_cond E L (Uniq κ γ) (◠ty)%I lt T ⊢
+ prove_place_cond E L (Uniq κ γ) (BlockedLtype ty κ') lt T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "($ & (%upd & Hcond & T))".
+ iExists _. iModIntro. iFrame.
+ simpl. destruct upd as [ Heq0 | ].
+ - iDestruct "Hcond" as "(%Heq & #Heq & #Hub)"; subst rt2.
+ rewrite (UIP_refl _ _ Heq).
+ iExists eq_refl. cbn. simp_ltypes.
+ iSplitL; done.
+ - by iFrame.
+ Qed.
+ Global Instance prove_place_cond_blocked_l_Uniq_inst E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ κ' γ :
+ ProvePlaceCond E L (Uniq κ γ) (BlockedLtype ty κ') lt | 5 := λ T, i2p (prove_place_cond_blocked_l_Uniq E L ty lt κ κ' γ T).
+
+ Lemma prove_place_cond_blocked_l_Owned E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ' wl T :
+ prove_place_cond E L (Owned wl) (◠ty)%I lt T ⊢
+ prove_place_cond E L (Owned wl) (BlockedLtype ty κ') lt T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "($ & (%upd & Hcond & T))".
+ iExists upd. iFrame. done.
+ Qed.
+ Global Instance prove_place_cond_blocked_l_Owned_inst E L {rt rt2} (ty : type rt) (lt : ltype rt2) κ' wl :
+ ProvePlaceCond E L (Owned wl) (BlockedLtype ty κ') lt | 5 := λ T, i2p (prove_place_cond_blocked_l_Owned E L ty lt κ' wl T).
+
+ Lemma prove_place_cond_coreable_r_Owned E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs wl T :
+ prove_place_cond E L (Owned wl) lt1 lt2 T ⊢
+ prove_place_cond E L (Owned wl) lt1 (CoreableLtype κs lt2) T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "($ & %upd & Hcond & HT)".
+ iExists upd. by iFrame.
+ Qed.
+ Global Instance prove_place_cond_coreable_r_Owned_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs wl :
+ ProvePlaceCond E L (Owned wl) lt1 (CoreableLtype κs lt2) | 5 := λ T, i2p (prove_place_cond_coreable_r_Owned E L lt1 lt2 κs wl T).
+ (* κ needs to outlive all the κ' ∈ κs *)
+ Lemma prove_place_cond_coreable_r_Uniq E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs κ γ T :
+ ([∗ list] κ' ∈ κs, ⌜lctx_lft_incl E L κ' κâŒ) ∗ prove_place_cond E L (Uniq κ γ) lt1 lt2 T
+ ⊢ prove_place_cond E L (Uniq κ γ) lt1 (CoreableLtype κs lt2) T.
+ Proof.
+ iIntros "(#Hal & HT)". iIntros (F ?) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(HL & %upd & Hcond & HT)".
+ iPoseProof (big_sepL_lft_incl_incl with "HE HL Hal") as "#Hincl".
+ iFrame "HL". iExists upd. iFrame.
+ destruct upd.
+ - simpl; subst rt2. iDestruct "Hcond" as "(%Heq & Heq & Hub)".
+ rewrite (UIP_refl _ _ Heq). iExists eq_refl. cbn.
+ simp_ltypes. iSplitL "Heq"; first done.
+ iApply imp_unblockable_shorten; last iApply coreable_ltype_imp_unblockable.
+ iModIntro. iIntros "(#Hdead & _)". iApply big_sepL_fupd.
+ iApply big_sepL_intro. iIntros "!>" (? κ' Hlook).
+ iPoseProof (big_sepL_lookup with "Hincl") as "#Hincl0"; first done.
+ by iApply (lft_incl_dead with "Hincl0 Hdead").
+ - simp_ltypes. done.
+ Qed.
+ Global Instance prove_place_cond_coreable_r_Uniq_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs κ γ :
+ ProvePlaceCond E L (Uniq κ γ) lt1 (CoreableLtype κs lt2) | 5 := λ T, i2p (prove_place_cond_coreable_r_Uniq E L lt1 lt2 κs κ γ T).
+
+ Lemma prove_place_cond_coreable_l_Owned E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs wl T :
+ prove_place_cond E L (Owned wl) lt1 lt2 T
+ ⊢ prove_place_cond E L (Owned wl) (CoreableLtype κs lt1) lt2 T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "($ & %upd & Hcond & HT)".
+ iExists upd. by iFrame.
+ Qed.
+ Global Instance prove_place_cond_coreable_l_Owned_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs wl :
+ ProvePlaceCond E L (Owned wl) (CoreableLtype κs lt1) lt2 | 5 := λ T, i2p (prove_place_cond_coreable_l_Owned E L lt1 lt2 κs wl T).
+
+ Lemma prove_place_cond_coreable_l_Uniq E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs κ γ T :
+ prove_place_cond E L (Uniq κ γ) lt1 lt2 T
+ ⊢ prove_place_cond E L (Uniq κ γ) (CoreableLtype κs lt1) lt2 T.
+ Proof.
+ iIntros "HT". iIntros (F ?) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(HL & %upd & Hcond & HT)".
+ iFrame. iExists upd. iFrame.
+ destruct upd.
+ - subst rt2. iDestruct "Hcond" as "(%Heq & Heq & Hub)".
+ rewrite (UIP_refl _ _ Heq).
+ iExists eq_refl. cbn. simp_ltypes. by iFrame.
+ - simp_ltypes. done.
+ Qed.
+ Global Instance prove_place_cond_coreable_l_Uniq_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κs κ γ :
+ ProvePlaceCond E L (Uniq κ γ) (CoreableLtype κs lt1) lt2 | 5 := λ T, i2p (prove_place_cond_coreable_l_Uniq E L lt1 lt2 κs κ γ T).
+
+ (* TODO: lemmas for shrblocked *)
+
+ (* NOTE: unfolding lemmas should have lower priority than the primitive ones. *)
+
+ (** find obs *)
+ Import EqNotations.
+ Lemma find_observation_direct (rt : Type) γ (T : find_observation_cont_t rt) :
+ find_in_context (FindOptGvarPobs γ) (λ res,
+ match res with
+ | inr _ => find_observation rt γ FindObsModeRel T
+ | inl (existT rt' r) => ∃ (Heq : rt' = rt), T (Some (rew Heq in r))
+ end)%I
+ ⊢ find_observation rt γ FindObsModeDirect T.
+ Proof.
+ iDestruct 1 as ([[rt' r] | ]) "(Hobs & HT)"; simpl.
+ - iDestruct "HT" as (->) "HT". iIntros (??). iModIntro.
+ iLeft. eauto with iFrame.
+ - iIntros (??). by iApply "HT".
+ Qed.
+ Global Instance find_observation_direct_inst (rt : Type) γ :
+ FindObservation rt γ FindObsModeDirect := λ T, i2p (find_observation_direct rt γ T).
+
+ Lemma find_observation_rel (rt : Type) γ (T : find_observation_cont_t rt) :
+ find_in_context (FindOptGvarRel γ) (λ res,
+ match res with
+ | inr _ => T None
+ | inl (existT rt' (γ', R)) => ∃ (Heq : rt' = rt),
+ find_observation rt' γ' FindObsModeDirect (λ or,
+ match or with
+ | None => False
+ | Some r => ∀ r', ⌜R r r'⌠-∗ T (Some $ rew Heq in r')
+ end)
+ end)%I
+ ⊢ find_observation rt γ FindObsModeRel T.
+ Proof.
+ iDestruct 1 as ([[rt' [γ' R]] | ]) "(Hobs & HT)"; simpl.
+ - iDestruct "HT" as (->) "HT".
+ iIntros (??). iMod ("HT" with "[//]") as "HT".
+ iDestruct "HT" as "[(%r & Hobs' & HT) | []]".
+ iPoseProof (Rel2_use_pobs with "Hobs' Hobs") as "(%r2 & Hobs & %HR)".
+ iSpecialize ("HT" with "[//]").
+ iMod (gvar_obs_persist with "Hobs") as "Hobs".
+ iModIntro. iLeft. eauto with iFrame.
+ - iIntros (??). iRight. done.
+ Qed.
+ Global Instance find_observation_rel_inst (rt : Type) γ :
+ FindObservation rt γ FindObsModeRel := λ T, i2p (find_observation_rel rt γ T).
+
+ (** ** resolve_ghost *)
+ (* One note: these instances do not descend recursively -- that is the task of the stratify_ltype call that is triggering the resolution. resolve_ghost instances should always resolve at top-level, or at the level of atoms of stratify_ltype's traversal (in case of user-defined types) *)
+ Import EqNotations.
+
+ (* a trivial low-priority instance, in case no other instance triggers.
+ In particular, we should also make sure that custom instances for user-defined types get priority. *)
+ Lemma resolve_ghost_id {rt} π E L l (lt : ltype rt) rm lb k r (T : llctx → place_rfn rt → iProp Σ → bool → iProp Σ) :
+ match rm, r with
+ | ResolveTry, PlaceIn _ => T L r True true
+ | ResolveTry, PlaceGhost _ => T L r True false
+ | ResolveAll, PlaceIn _ => T L r True true
+ | ResolveAll, PlaceGhost _ => False
+ end
+ ⊢ resolve_ghost π E L rm lb l lt k r T.
+ Proof.
+ iIntros "HT" (F ??) "#CTX #HE HL Hl".
+ destruct rm.
+ - destruct r; last done.
+ iExists L, _, True%I, _. iFrame.
+ iApply maybe_logical_step_intro. by iFrame.
+ - destruct r.
+ + iExists L, _, True%I, _. iFrame. iApply maybe_logical_step_intro. by iFrame.
+ + iExists L, _, True%I, _. iFrame. iApply maybe_logical_step_intro. by iFrame.
+ Qed.
+ Global Instance resolve_ghost_id_inst {rt} π E L l (lt : ltype rt) rm lb k r :
+ ResolveGhost π E L rm lb l lt k r | 200 := λ T, i2p (resolve_ghost_id π E L l lt rm lb k r T).
+
+ Lemma resolve_ghost_ofty_Owned {rt} π E L l (ty : type rt) γ rm lb wl T :
+ find_observation rt γ FindObsModeDirect (λ or,
+ match or with
+ | None => ⌜rm = ResolveTry⌠∗ T L (PlaceGhost γ) True false
+ | Some r => T L (PlaceIn $ r) True true
+ end)
+ ⊢ resolve_ghost π E L rm lb l (◠ty)%I (Owned wl) (PlaceGhost γ) T.
+ Proof.
+ iIntros "HT". iIntros (F ??) "#CTX #HE HL Hl".
+ iMod ("HT" with "[//]") as "HT". iDestruct "HT" as "[(%r & Hobs & HT) | (-> & HT)]".
+ - rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & ? & ? & ? & ? & ? & %r' & Hrfn & Hb)".
+ (* don't really need the cred here *)
+ iDestruct "Hrfn" as "(Hauth & _)".
+ iPoseProof (gvar_pobs_agree with "Hauth Hobs") as "->".
+ iModIntro. iExists L, _, True%I, _. iFrame.
+ iApply maybe_logical_step_intro. simpl. iSplitL; last done.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. eauto with iFrame.
+ - iExists L, _, True%I, _. iFrame. iApply maybe_logical_step_intro. eauto with iFrame.
+ Qed.
+ Global Instance resolve_ghost_ofty_owned_inst {rt} π E L l (ty : type rt) γ wl rm lb :
+ ResolveGhost π E L rm lb l (◠ty)%I (Owned wl) (PlaceGhost γ) | 7 := λ T, i2p (resolve_ghost_ofty_Owned π E L l ty γ rm lb wl T).
+
+ Lemma resolve_ghost_ofty_Uniq {rt} π E L l (ty : type rt) γ rm lb κ γ' T :
+ find_observation rt γ FindObsModeDirect (λ or,
+ match or with
+ | None => ⌜rm = ResolveTry⌠∗ T L (PlaceGhost γ) True false
+ | Some r => T L (PlaceIn $ r) True true
+ end)
+ ⊢ resolve_ghost π E L rm lb l (◠ty)%I (Uniq κ γ') (PlaceGhost γ) T.
+ Proof.
+ iIntros "HT". iIntros (F ??) "#CTX #HE HL Hl".
+ iMod ("HT" with "[//]") as "HT". iDestruct "HT" as "[(%r & Hobs & HT) | (-> & HT)]".
+ - rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & ? & ? & ? & ? & ? & ? & Hrfn & Hb)".
+ (* don't actually need the cred here *)
+ iDestruct "Hrfn" as "(_ & Hrfn)".
+ iDestruct "Hrfn" as "(%v1 & %v2 & Hauth & Hobs' & %HR)".
+ iPoseProof (gvar_pobs_agree with "Hauth Hobs") as "->".
+ simpl. subst.
+ iModIntro. iExists L, _, True%I, _. iFrame.
+ iApply maybe_logical_step_intro. iSplitL; last done.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. eauto with iFrame.
+ - iExists L, _, True%I, _. iFrame. iApply maybe_logical_step_intro. eauto with iFrame.
+ Qed.
+ Global Instance resolve_ghost_ofty_uniq_inst {rt} π E L l (ty : type rt) γ κ γ' rm lb :
+ ResolveGhost π E L rm lb l (◠ty)%I (Uniq κ γ') (PlaceGhost γ) | 7 := λ T, i2p (resolve_ghost_ofty_Uniq π E L l ty γ rm lb κ γ' T).
+
+
+ (** ** Extraction *)
+ (* We register a few post-hooks for actually extracting stuff. *)
+ Lemma stratify_ltype_extract_mutltype π E L {rt} (lt : ltype rt) r κ γ l (wl : bool) (T : stratify_ltype_post_hook_cont_t) :
+ match ltype_uniq_extractable lt with
+ | None =>
+ T L True%I _ (MutLtype lt κ) (#(r, γ))
+ | Some κm =>
+ prove_with_subtype E L false ProveDirect (£ (Nat.b2n wl)) (λ L' κs R,
+ (R -∗ T L' (MaybeInherit κm InheritGhost (place_rfn_interp_mut_extracted r γ)) _ (◠uninit PtrSynType)%I (#())))
+ end
+ ⊢ stratify_ltype_post_hook π E L (StratifyExtractOp κ) l (MutLtype lt κ) (#(r, γ)) (Owned wl) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL Hl".
+ destruct (ltype_uniq_extractable lt) as [ κm | ] eqn:Hextract; first last.
+ { iExists L, True%I, _, _, _. iFrame. done. }
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & %κs & %R & >(Hcred & HR)& HL & HT)".
+ iMod (ltype_uniq_extractable_deinit_mut' with "Hcred Hl") as "(Hl & Hrfn)"; [done.. | | ].
+ { left. done. }
+ iSpecialize ("HT" with "HR").
+ iPoseProof (MaybeInherit_update (place_rfn_interp_mut_extracted r γ) with "[] Hrfn") as "Ha".
+ { iIntros (?) "Ha". iMod (place_rfn_interp_mut_extract with "Ha") as "?". done. }
+ iExists _, _, _, _, _. iFrame.
+ iFrame. simp_ltypes. done.
+ Qed.
+ Global Instance stratify_ltype_extract_mutltype_inst π E L {rt} (lt : ltype rt) r κ γ l (wl : bool) :
+ StratifyLtypePostHook π E L (StratifyExtractOp κ) l (MutLtype lt κ) (#(r, γ)) (Owned wl) :=
+ λ T, i2p (stratify_ltype_extract_mutltype π E L lt r κ γ l wl T).
+
+ Lemma stratify_ltype_extract_shrltype π E L {rt} (lt : ltype rt) r κ l (wl : bool) (T : stratify_ltype_post_hook_cont_t) :
+ prove_with_subtype E L false ProveDirect (£ (Nat.b2n wl)) (λ L' κs R, (R -∗ T L' (True) _ (◠uninit PtrSynType)%I (#())))
+ ⊢ stratify_ltype_post_hook π E L (StratifyExtractOp κ) l (ShrLtype lt κ) r (Owned wl) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL Hl".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & %κs & %R & >(Hcred & HR)& HL & HT)".
+ iMod (ltype_deinit_shr' with "Hcred Hl") as "Hl"; [done.. | | ].
+ { left. done. }
+ iSpecialize ("HT" with "HR").
+ iExists _, _, _, _, _. iFrame.
+ iFrame. simp_ltypes. done.
+ Qed.
+ Global Instance stratify_ltype_extract_shrltype_inst π E L {rt} (lt : ltype rt) r κ l (wl : bool) :
+ StratifyLtypePostHook π E L (StratifyExtractOp κ) l (ShrLtype lt κ) r (Owned wl) :=
+ λ T, i2p (stratify_ltype_extract_shrltype π E L lt r κ l wl T).
+
+
+ (** ** ltype stratification *)
+ (* TODO change the ResolveTry and also make it a parameter of stratify *)
+
+ (* when we recursively want to descend, we cannot let the resolution use the logical step *)
+ Lemma stratify_ltype_resolve_ghost_rec {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) b r T :
+ resolve_ghost π E L ResolveTry false l lt b r (λ L1 r R progress,
+ if progress then
+ stratify_ltype π E L1 mu mdu ma ml l lt r b
+ (λ L2 R' rt' lt' r', T L2 (R ∗ R') rt' lt' r')
+ else
+ (* otherwise treat this as a leaf *)
+ R -∗ stratify_ltype_post_hook π E L1 ml l lt r b T)
+ ⊢ stratify_ltype π E L mu mdu ma ml l lt r b T.
+ Proof.
+ iIntros "Hres". iIntros (???) "#CTX #HE HL Hl".
+ iMod ("Hres" with "[] [] CTX HE HL Hl") as "(%L1 & %r1 & %R & %prog & >(Hl & HR) & HL & HP)"; [done.. | ].
+ destruct prog.
+ - iPoseProof ("HP" with "[//] [//] CTX HE HL Hl") as ">Hb".
+ iDestruct "Hb" as "(%L2 & %R' & %rt' & %lt' & %r' & HL & Hcond & Hb & HT)".
+ iModIntro. iExists L2, _, rt', lt', r'. iFrame "Hcond HT HL".
+ iApply (logical_step_wand with "Hb"). iIntros "($ & $)". done.
+ - by iApply (stratify_ltype_id _ _ _ mu mdu ma with "(HP HR) [//] [//] CTX HE HL").
+ Qed.
+ (* at a leaf, we can use the logical step to do the resolution -- this allows to descend deeper into the type, which is useful for custom user-defined types *)
+ Lemma stratify_ltype_resolve_ghost_leaf {rt} π E L mu mdu ma {M} (ml : M) rm l (lt : ltype rt) b r T :
+ resolve_ghost π E L rm true l lt b r (λ L1 r R progress, T L1 R _ lt r)
+ ⊢ stratify_ltype π E L mu mdu ma ml l lt r b T.
+ Proof.
+ iIntros "Hres". iIntros (???) "#CTX #HE HL Hl".
+ iMod ("Hres" with "[] [] CTX HE HL Hl") as "(%L1 & %r1 & %R & %prog & Hl & HL & HR)"; [done.. | ].
+ simpl. iModIntro. iExists L1, _, _, lt, r1.
+ iFrame. done.
+ Qed.
+
+ (* This should have a lower priority than the leaf instances we call for individual [ml] -- those should instead use [stratify_ltype_resolve_ghost_leaf]. *)
+ Global Instance stratify_ltype_resolve_ghost_inst {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) b γ :
+ StratifyLtype π E L mu mdu ma ml l lt (PlaceGhost γ) b | 100 := λ T, i2p (stratify_ltype_resolve_ghost_rec π E L mu mdu ma ml l lt b (PlaceGhost γ) T).
+
+ Lemma stratify_ltype_blocked {rt} π E L mu mdu ma {M} (ml : M) l (ty : type rt) κ r b T :
+ find_in_context (FindOptLftDead κ) (λ found,
+ if found then stratify_ltype π E L mu mdu ma ml l (◠ty)%I r b T
+ else stratify_ltype_post_hook π E L ml l (BlockedLtype ty κ) r b T)
+ ⊢ stratify_ltype π E L mu mdu ma ml l (BlockedLtype ty κ) r b T.
+ Proof.
+ rewrite /FindOptLftDead.
+ iIntros "(%found & Hdead & Hp)". destruct found.
+ - iIntros (???) "#(LFT & TIME & LLCTX) #HE HL Hl".
+ iMod (unblock_blocked with "Hdead Hl") as "Hl"; first done.
+ iPoseProof ("Hp" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hl") as ">Hb".
+ iDestruct "Hb" as "(%L' & %R & %rt' & %lt' & %r' & Hl & Hstep & HT)".
+ iModIntro. iExists L', R, rt', lt', r'. iFrame.
+ - by iApply stratify_ltype_id.
+ Qed.
+ (* No instance here, as we may not always want to do that. *)
+
+ (* TODO: also make this one optional *)
+ Lemma stratify_ltype_coreable {rt} π E L mu mdu ma {M} (ml : M) l (lt_full : ltype rt) κs r b T :
+ lft_dead_list κs ∗ stratify_ltype π E L mu mdu ma ml l (ltype_core lt_full) r b T
+ ⊢ stratify_ltype π E L mu mdu ma ml l (CoreableLtype κs lt_full) r b T.
+ Proof.
+ iIntros "(#Hdead & Hstrat)".
+ iIntros (F ??) "#CTX #HE HL Hl".
+ iMod (unblock_coreable with "Hdead Hl") as "Hl"; first done.
+ iMod ("Hstrat" with "[//] [//] CTX HE HL Hl") as "Ha".
+ iDestruct "Ha" as "(%L2 & %R & %rt' & %lt' & %r' & HL & %Hst & Hstep & HT)".
+ iModIntro. iExists _, _, _, _, _. iFrame.
+ iPureIntro. rewrite -Hst ltype_core_syn_type_eq. by simp_ltypes.
+ Qed.
+ (* No instance here, as we may not always want to do that. *)
+
+ Lemma stratify_ltype_shrblocked {rt} π E L mu mdu ma {M} (ml : M) l (ty : type rt) κ r b T :
+ find_in_context (FindOptLftDead κ) (λ found,
+ if found then stratify_ltype π E L mu mdu ma ml l (◠ty)%I r b T
+ else stratify_ltype_post_hook π E L ml l (ShrBlockedLtype ty κ) r b T)
+ ⊢ stratify_ltype π E L mu mdu ma ml l (ShrBlockedLtype ty κ) r b T.
+ Proof.
+ rewrite /FindOptLftDead.
+ iIntros "(%found & Hdead & Hstrat)". destruct found.
+ - iIntros (F ??) "#CTX #HE HL Hl".
+ iMod (unblock_shrblocked with "Hdead Hl") as "Hl"; first done.
+ iMod ("Hstrat" with "[//] [//] CTX HE HL Hl") as "Ha".
+ iDestruct "Ha" as "(%L2 & %R & %rt' & %lt' & %r' & HL & %Hst & Hstep & HT)".
+ iModIntro. iExists _, _, _, _, _. iFrame.
+ iPureIntro. done.
+ - by iApply stratify_ltype_id.
+ Qed.
+ (* No instance here, as we may not always want to do that. *)
+
+ (* TODO: need some machinery to simplify the ltype_core in the conclusions. *)
+ (* NOTE: we make the assumption that, even for fully-owned places, we want to keep the invariant structure, and not just unfold it completely and forget about the invariants. This is why we keep it open when the refinement type is different, even though we could in principle also close it to any lt_cur'.
+
+ Is there a better criterion for this than the refinement type?
+ - currently, prove_place_cond requires the refinement type to be the same, even for Owned.
+ - for some of the subtyping we may want to allow the subtyping to actually be heterogeneous.
+
+ Points in the design space:
+ - [aggressive] just fold every time we can, by always proving a subtyping.
+ - [aggressive unless Owned] fold every time as long as the place cond is provable.
+ + in particular: fold if we can get back a lifetime token.
+ - [relaxed]
+ -
+
+ Some thoughts on stuff that would be good:
+ - make stratification more syntax-guided, i.e. have a "goal" ltype?
+ + this would make the behavior when we moved stuff out beforehand much more predictable, eg. for value_t: don't just have a general rule for stratifying value every time, but only when we actually want to have something there.
+
+
+ *)
+ Lemma stratify_ltype_opened_Owned {rt_cur rt_inner rt_full} π E L mu mdu ma {M} (ml : M) l
+ (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre Cpost : rt_inner → rt_full → iProp Σ) r wl (T : stratify_ltype_cont_t) :
+ stratify_ltype π E L mu mdu ma ml l lt_cur r (Owned false) (λ L' R rt_cur' lt_cur' (r' : place_rfn rt_cur'),
+ if decide (ma = StratNoRefold)
+ then (* keep it open *)
+ T L' R _ (OpenedLtype lt_cur' lt_inner lt_full Cpre Cpost) r'
+ else
+ (* fold the invariant *)
+ ∃ ri,
+ (* show that the core of lt_cur' is a subtype of lt_inner and then fold to lt_full *)
+ weak_subltype E L' (Owned false) (r') (#ri) (ltype_core lt_cur') lt_inner (
+ (* re-establish the invariant *)
+ ∃ rf, prove_with_subtype E L' true ProveWithStratify (Cpre ri rf) (λ L'' κs R2,
+ (* either fold to coreable, or to the core of lt_full *)
+ match ltype_blocked_lfts lt_cur', κs with
+ | [], [] =>
+ (T L'' (Cpost ri rf ∗ R2 ∗ R) rt_full (ltype_core lt_full) (#rf))
+ | κs', _ =>
+ (T L'' (Cpost ri rf ∗ R2 ∗ R) rt_full (CoreableLtype (κs' ++ κs) lt_full) (#rf))
+ end)))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r (Owned wl) T.
+ Proof.
+ iIntros "Hstrat". iIntros (F ??) "#CTX #HE HL Hl".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & #Hlb & %Hst1 & %Hst2 & Hl & Hcl)".
+ iMod ("Hstrat" with "[//] [//] CTX HE HL Hl") as "(%L2 & %R & %rt_cur' & %lt_cur' & %r' & HL & %Hst & Hstep & HT)".
+ destruct (decide (ma = StratNoRefold)) as [-> | ].
+ - (* don't fold *)
+ iModIntro.
+ iExists _, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. simp_ltypes. done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro.
+ iIntros "(Hl & $)".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iExists ly. iFrame.
+ rewrite -Hst.
+ iSplitR. { done. }
+ iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. done.
+ - (* fold it again *)
+ iDestruct "HT" as "(%ri & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & HL & %rf & HT)".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L3 & %κs & %R2 & Hstep' & HL & HT)".
+ iPoseProof (imp_unblockable_blocked_dead lt_cur') as "(_ & #Hb)".
+ set (κs' := ltype_blocked_lfts lt_cur').
+ destruct (decide (κs = [] ∧ κs' = [])) as [[-> ->] | ].
+ + iExists L3, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. rewrite ltype_core_syn_type_eq. rewrite -Hst2 -Hst1 //. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iPoseProof (logical_step_mask_mono _ F with "Hcl") as "Hcl"; first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep'").
+ iApply logical_step_intro.
+ iIntros "!> (Hpre & $) Hcl (Hl & $)".
+ iPoseProof ("Hb" with "[] Hl") as "Hl". { by iApply big_sepL_nil. }
+ iMod (fupd_mask_mono with "Hl") as "Hl"; first done.
+ rewrite ltype_own_core_equiv.
+ iMod (ltype_incl_use with "Hincl Hl") as "Hl"; first done.
+ simpl.
+ iPoseProof ("Hcl" with "Hpre") as "(Hpost & Hvs')".
+ iMod (fupd_mask_mono with "(Hvs' [] Hl)") as "Ha"; first done.
+ { by iApply lft_dead_list_nil. }
+ rewrite ltype_own_core_equiv. by iFrame.
+ + iAssert (T L3 (Cpost ri rf ∗ R2 ∗ R) rt_full (CoreableLtype (κs' ++ κs) lt_full) #rf)%I with "[HT]" as "HT".
+ { destruct κs, κs'; naive_solver. }
+ iExists L3, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro.
+ simp_ltypes. rewrite -Hst2 -Hst1. done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iPoseProof (logical_step_mask_mono _ F with "Hcl") as "Hcl"; first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep'").
+ iApply logical_step_intro.
+ iIntros "!> (Hpre & $) Hcl (Hl & $)".
+ rewrite ltype_own_coreable_unfold /coreable_ltype_own.
+ iPoseProof ("Hcl" with "Hpre") as "($ & Hvs')".
+ iModIntro.
+ iExists ly.
+ iSplitR. { rewrite -Hst2 -Hst1. done. }
+ iSplitR; first done. iSplitR; first done.
+ iIntros "Hdead".
+ rewrite lft_dead_list_app. iDestruct "Hdead" as "(Hdead' & Hdead)".
+ (* unblock lt_cur' *)
+ iPoseProof (imp_unblockable_blocked_dead lt_cur') as "(_ & #Hub)".
+ iMod ("Hub" with "Hdead' Hl") as "Hl".
+ (* shift to lt_inner *)
+ rewrite !ltype_own_core_equiv.
+ iMod (ltype_incl_use with "Hincl Hl") as "Hl"; first done.
+ (* shift to the core of lt_full *)
+ iMod ("Hvs'" with "Hdead Hl") as "Hl".
+ eauto.
+ Qed.
+ Global Instance stratify_ltype_opened_owned_inst {rt_cur rt_inner rt_full} π E L mu mdu ma {M} (ml : M) l
+ (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre Cpost : rt_inner → rt_full → iProp Σ) r wl:
+ StratifyLtype π E L mu mdu ma ml l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r (Owned wl) := λ T, i2p (stratify_ltype_opened_Owned π E L mu mdu ma ml l lt_cur lt_inner lt_full Cpre Cpost r wl T).
+
+ (* NOTE what happens with the inclusion sidecondition for the κs when we shorten the outer reference?
+ - we should not shorten after unfolding (that also likely doesn't work with OpenedLtype -- we cannot arbitrarily modify the lt_inner/lt_full)
+ - if we are borrowing at a lifetime which doesn't satisfy this at the borrow time, that is a bug, as we are violating the contract of the outer reference.
+ So: this sidecondition does not restrict us in any way. *)
+ Lemma stratify_ltype_opened_Uniq {rt_cur rt_inner rt_full} π E L mu mdu ma {M} (ml : M) l
+ (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre Cpost : rt_inner → rt_full → iProp Σ) r κ γ T :
+ stratify_ltype π E L mu mdu ma ml l lt_cur r (Owned false) (λ L' R rt_cur' lt_cur' (r' : place_rfn rt_cur'),
+ if decide (ma = StratNoRefold)
+ then (* keep it open *)
+ T L' R _ (OpenedLtype lt_cur' lt_inner lt_full Cpre Cpost) r'
+ else
+ (* fold the invariant *)
+ ∃ ri,
+ (* show that lt_cur' is a subtype of lt_inner and then fold to lt_full *)
+ weak_subltype E L' (Owned false) (r') (#ri) (lt_cur') lt_inner (
+ (* re-establish the invariant *)
+ (* TODO: should be modulo unblocking *)
+ ∃ rf,
+ prove_with_subtype E L' true ProveWithStratify (Cpre ri rf) (λ L'' κs R2,
+ (* either fold to coreable, or to the core of lt_full *)
+ match κs, ltype_blocked_lfts lt_cur' with
+ | [], [] =>
+ (T L'' (Cpost ri rf ∗ R2 ∗ R) rt_full (ltype_core lt_full) (#rf))
+ | _, κs' =>
+ (* inclusion sidecondition: require that all the blocked stuff ends before κ *)
+ ([∗ list] κ' ∈ κs ++ κs', ⌜lctx_lft_incl E L'' κ' κâŒ) ∗
+ (T L'' (Cpost ri rf ∗ R2 ∗ R) rt_full (CoreableLtype (κs ++ κs') lt_full) (#rf))
+ end)))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r (Uniq κ γ) T.
+ Proof.
+ iIntros "Hstrat". iIntros (F ??) "#CTX #HE HL Hl".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & #Hlb & %Hst1 & %Hst2 & Hl & Hcl)".
+ iMod ("Hstrat" with "[//] [//] CTX HE HL Hl") as "(%L2 & %R & %rt_cur' & %lt_cur' & %r' & HL & %Hst & Hstep & HT)".
+ destruct (decide (ma = StratNoRefold)).
+ - (* don't fold *)
+ iModIntro. iExists _, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. simp_ltypes. done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro.
+ iIntros "(Hl & $)".
+ rewrite ltype_own_opened_unfold /opened_ltype_own.
+ iExists ly. iFrame.
+ rewrite -Hst.
+ iSplitR. { done. }
+ iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. done.
+ - (* fold it again *)
+ iDestruct "HT" as "(%ri & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & %rf & HT)".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L3 & %κs & %R2 & Hstep' & HL & HT)".
+ iPoseProof (imp_unblockable_blocked_dead lt_cur') as "#(_ & Hub)".
+ set (κs' := ltype_blocked_lfts lt_cur').
+ destruct (decide (κs = [] ∧ κs' = [])) as [[-> ->] | ].
+ + iExists L3, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. rewrite ltype_core_syn_type_eq. rewrite -Hst2 -Hst1 //. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iPoseProof (logical_step_mask_mono _ F with "Hcl") as "Hcl"; first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep'").
+ iApply logical_step_intro.
+ iIntros "!> (Hpre & $) Hcl (Hl & $)".
+ (* instantiate own_lt_cur' with ownership of lt_cur' *)
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod ("Hcl" $! (λ Ï€ _ l, l â—â‚—[Ï€, Owned false] r' @ lt_cur')%I [] with "Hpre [] Hl []") as "Ha".
+ { by iApply big_sepL_nil. }
+ { iModIntro. iIntros "_ Hb".
+ iMod ("Hub" with "[] Hb") as "Hb". { iApply big_sepL_nil. done. }
+ rewrite !ltype_own_core_equiv.
+ iApply (ltype_incl_use_core with "Hincl Hb"); first done. }
+ iDestruct "Ha" as "($ & Hobs & Hcl)".
+ iMod ("Hcl" with "[] Hobs") as "Hl".
+ { iApply big_sepL_nil. done. }
+ iMod "Hcl_F" as "_". rewrite ltype_own_core_equiv. done.
+ + iAssert (([∗ list] κ' ∈ κs ++ κs', ⌜lctx_lft_incl E L3 κ' κâŒ) ∗ T L3 (Cpost ri rf ∗ R2 ∗ R) rt_full (CoreableLtype (κs ++ κs') lt_full) (PlaceIn rf))%I with "[HT]" as "HT".
+ { destruct κs, κs'; naive_solver. }
+ iDestruct "HT" as "(#Hincl1 & HT)".
+ iPoseProof (big_sepL_lft_incl_incl with "HE HL Hincl1") as "#Hincl2".
+ iExists L3, _, _, _, _. iFrame.
+ iSplitR. { iPureIntro. simp_ltypes. rewrite -Hst2 -Hst1. done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hstep").
+ iPoseProof (logical_step_mask_mono _ F with "Hcl") as "Hcl"; first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep'").
+ iApply logical_step_intro.
+ iIntros "!> (Hpre & $) Hcl (Hl & $)".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod ("Hcl" $! (λ Ï€ _ l, l â—â‚—[Ï€, Owned false] r' @ lt_cur')%I (κs ++ κs') with "[Hpre] [] Hl []") as "Ha".
+ { rewrite lft_dead_list_app. iIntros "(Hdead & _)". by iApply "Hpre". }
+ { done. }
+ { iModIntro. iIntros "#Hdead Hb".
+ rewrite lft_dead_list_app. iDestruct "Hdead" as "(_ & Hdead)".
+ iMod ("Hub" with "Hdead Hb") as "Hb".
+ rewrite !ltype_own_core_equiv.
+ iApply (ltype_incl_use_core with "Hincl Hb"); first done. }
+ iDestruct "Ha" as "($ & Hobs & Hcl)".
+ iMod "Hcl_F" as "_".
+ iModIntro. rewrite ltype_own_coreable_unfold /coreable_ltype_own.
+ iExists ly. rewrite -Hst2 -Hst1. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done. iFrame.
+ Qed.
+ Global Instance stratify_ltype_opened_uniq_inst {rt_cur rt_inner rt_full} π E L mu mdu ma {M} (ml : M) l
+ (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full)
+ (Cpre Cpost : rt_inner → rt_full → iProp Σ) r κ γ :
+ StratifyLtype π E L mu mdu ma ml l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r (Uniq κ γ) := λ T, i2p (stratify_ltype_opened_Uniq π E L mu mdu ma ml l lt_cur lt_inner lt_full Cpre Cpost r κ γ T).
+
+ Lemma stratify_ltype_shadowed_shared {rt_cur rt_full} π E L mu mdu ma {M} (ml : M) l
+ (lt_cur : ltype rt_cur) (lt_full : ltype rt_full) (r_cur : place_rfn rt_cur) r_full κ T :
+ stratify_ltype π E L mu mdu ma ml l lt_cur r_cur (Shared κ) (λ L' R rt_cur' lt_cur' (r_cur' : place_rfn rt_cur'),
+ if decide (ma = StratNoRefold)
+ then (* keep it open *)
+ T L' R rt_full (ShadowedLtype lt_cur' r_cur' lt_full) r_full
+ else
+ (T L' R rt_full (lt_full) (r_full))
+ )
+ ⊢ stratify_ltype π E L mu mdu ma ml l (ShadowedLtype lt_cur r_cur lt_full) r_full (Shared κ) T.
+ Proof.
+ iIntros "Hstrat".
+ iIntros (???) "#CTX #HE HL Hl".
+ rewrite ltype_own_shadowed_unfold /shadowed_ltype_own. iDestruct "Hl" as "(%Hst & Hcur & Hfull)".
+ iMod ("Hstrat" with "[//] [//] CTX HE HL Hcur") as "(%L' & %R & %rt' & %lt' & %r' & HL & %Hst' & Ha & HT)".
+ iModIntro. case_decide.
+ - iExists _, _, _, _, _. iFrame. simp_ltypes.
+ iR. iApply (logical_step_wand with "Ha").
+ iIntros "(Ha & $)". rewrite ltype_own_shadowed_unfold /shadowed_ltype_own.
+ iSplitR. { rewrite -Hst'//. }
+ iFrame.
+ - iExists _, _, _, _, _. iFrame. simp_ltypes.
+ iR. iApply (logical_step_wand with "Ha").
+ iIntros "(Ha & $)". iFrame.
+ Qed.
+ Global Instance stratify_ltype_shadowed_shared_inst {rt_cur rt_full} π E L mu mdu ma {M} (ml : M) l
+ (lt_cur : ltype rt_cur) (lt_full : ltype rt_full) (r_cur : place_rfn rt_cur) (r_full : place_rfn rt_full) κ :
+ StratifyLtype π E L mu mdu ma ml l (ShadowedLtype lt_cur r_cur lt_full) r_full (Shared κ) := λ T, i2p (stratify_ltype_shadowed_shared π E L mu mdu ma ml l lt_cur lt_full r_cur r_full κ T).
+
+
+ (* NOTE: instances for descending below MutLty, etc., are in the respective type's files. *)
+
+ (** Unblock stratification: We define instances for the leaves of the unblocking stratifier *)
+ (* On an ofty leaf, do a ghost resolution.
+ This will also trigger resolve_ghost instances for custom-user defined types.
+ This needs to have a lower priority than custom user-defined instances (e.g. for [â— value_t]), so we give it a high cost. *)
+ Global Instance stratify_ltype_unblock_ofty_in_inst {rt} π E L mu mdu ma l (ty : type rt) (r : place_rfn rt) b :
+ StratifyLtype π E L mu mdu ma StratifyUnblockOp l (◠ty)%I r b | 100 :=
+ λ T, i2p (stratify_ltype_resolve_ghost_leaf π E L mu mdu ma StratifyUnblockOp ResolveAll l (◠ty)%I b r T).
+
+ (* Note: instance needs to have a higher priority than the resolve_ghost instance -- we should first unblock *)
+ Global Instance stratify_ltype_unblock_blocked_inst {rt} π E L mu mdu ma l (ty : type rt) b r κ :
+ StratifyLtype π E L mu mdu ma StratifyUnblockOp l (BlockedLtype ty κ) r b | 5 := λ T, i2p (stratify_ltype_blocked π E L mu mdu ma StratifyUnblockOp l ty κ r b T).
+ Global Instance stratify_ltype_unblock_shrblocked_inst {rt} π E L mu mdu ma l (ty : type rt) b r κ :
+ StratifyLtype π E L mu mdu ma StratifyUnblockOp l (ShrBlockedLtype ty κ) r b | 5 := λ T, i2p (stratify_ltype_shrblocked π E L mu mdu ma StratifyUnblockOp l ty κ r b T).
+ Global Instance stratify_ltype_unblock_coreable_inst {rt} π E L mu mdu ma l (lt : ltype rt) b r κs :
+ StratifyLtype π E L mu mdu ma StratifyUnblockOp l (CoreableLtype κs lt) r b | 5 := λ T, i2p (stratify_ltype_coreable π E L mu mdu ma StratifyUnblockOp l lt κs r b T).
+
+ (** Extract stratification: we also want to Unblock here *)
+ Global Instance stratify_ltype_extract_blocked_inst {rt} π E L mu mdu ma l (ty : type rt) b r κ κ' :
+ StratifyLtype π E L mu mdu ma (StratifyExtractOp κ') l (BlockedLtype ty κ) r b | 5 := λ T, i2p (stratify_ltype_blocked π E L mu mdu ma (StratifyExtractOp κ') l ty κ r b T).
+ Global Instance stratify_ltype_extract_shrblocked_inst {rt} π E L mu mdu ma l (ty : type rt) b r κ κ' :
+ StratifyLtype π E L mu mdu ma (StratifyExtractOp κ') l (ShrBlockedLtype ty κ) r b | 5 := λ T, i2p (stratify_ltype_shrblocked π E L mu mdu ma (StratifyExtractOp κ') l ty κ r b T).
+ Global Instance stratify_ltype_extract_coreable_inst {rt} π E L mu mdu ma l (lt : ltype rt) b r κs κ' :
+ StratifyLtype π E L mu mdu ma (StratifyExtractOp κ') l (CoreableLtype κs lt) r b | 5 := λ T, i2p (stratify_ltype_coreable π E L mu mdu ma (StratifyExtractOp κ') l lt κs r b T).
+
+ (** ** place typing *)
+
+ (** *** Instances for unblocking & updating refinements *)
+ (** Note: all of these instances should have higher priority than the id instances,
+ so that the client of [typed_place] does not have to do this.
+ TODO: can we find an elegant way to do this for nested things (eliminate a stratify_ltype)?
+ e.g. when something below is blocked and we need to unblock it, or we need to update the refinement.
+ currently, the client has to do this...
+ Problem why we can't directly do it: we need at least one step of computation to do it, and typed_place does not always take a step.
+ *)
+
+ (* TODO: some of this is really duplicated with stratify, in particular the unblocking and the ltype unfolding. Could we have an instance that just escapes into a shallow version of stratify that requires no logstep in order avoid duplication? *)
+
+ (* TODO: we probably want to generalize this to not immediately require a dead token for κ,
+ but rather have a "dead" context and spawn a sidecondition for inclusion in one of the dead lifetimes? *)
+ Lemma typed_place_blocked_unblock {rt} π E L l (ty : type rt) κ (r : place_rfn rt) bmin0 b P T :
+ ⌜bor_kind_writeable bmin0⌠∗ [†κ] ∗ typed_place π E L l (◠ty) r bmin0 b P T
+ ⊢ typed_place π E L l (BlockedLtype ty κ) r bmin0 b P T.
+ Proof.
+ iIntros "(%Hw & Hdead & Hp)". iIntros (????) "#(LFT & TIME & LLCTX) #HE HL Hincl0 Hl HΦ".
+ iApply fupd_place_to_wp.
+ iMod (unblock_blocked with "Hdead Hl") as "Hl"; first done.
+ iModIntro.
+ iApply ("Hp" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hincl0 Hl").
+ iIntros (L' κs l2 b2 bmin rti tyli ri strong weak) "Hincl1 Hl2 Hs HT HL".
+ iApply ("HΦ" $! _ _ _ _ _ _ _ _ _ _ with "Hincl1 Hl2 [Hs] HT HL").
+ iSplit.
+ - destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 Hcond".
+ iMod ("Hs" with "Hl2 Hcond") as "(Hl & Hcond & HR)".
+ iFrame. done.
+ - destruct weak as [ weak | ]; last done.
+ iIntros (ltyi2 ri2 bmin') "Hincl Hl2 Hcond".
+ iMod ("Hs" with "Hincl Hl2 Hcond") as "(Hl & Hcond & Htoks & HR)".
+ iFrame. iModIntro.
+ iDestruct "Hcond" as "(Ht & Hr)". iSplit.
+ + destruct bmin0; [done.. | ].
+ unfold typed_place_cond_ty. simp_ltypes. done.
+ + done.
+ Qed.
+ Global Instance typed_place_blocked_unblock_inst {rt} π E L l (ty : type rt) κ (r : place_rfn rt) bmin0 b P:
+ TypedPlace E L π l (BlockedLtype ty κ) r bmin0 b P | 5 := λ T, i2p (typed_place_blocked_unblock π E L l ty κ r bmin0 b P T).
+
+ Lemma typed_place_shrblocked_unblock {rt} π E L l (ty : type rt) κ (r : place_rfn rt) bmin0 b P T :
+ ⌜bor_kind_writeable bmin0⌠∗ [†κ] ∗ typed_place π E L l (◠ty) r bmin0 b P T
+ ⊢ typed_place π E L l (ShrBlockedLtype ty κ) r bmin0 b P T.
+ Proof.
+ iIntros "(%Hw & Hdead & Hp)". iIntros (????) "#(LFT & TIME & LLCTX) #HE HL Hincl0 Hl HΦ".
+ iApply fupd_place_to_wp.
+ iMod (unblock_shrblocked with "Hdead Hl") as "Hl"; first done.
+ iModIntro.
+ iApply ("Hp" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hincl0 Hl").
+ iIntros (L' κs l2 b2 bmin rti tyli ri strong weak) "Hincl1 Hl2 Hs HT HL".
+ iApply ("HΦ" $! _ _ _ _ _ _ _ _ _ _ with "Hincl1 Hl2 [Hs] HT HL").
+ iSplit.
+ - destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 Hcond".
+ iMod ("Hs" with "Hl2 Hcond") as "(Hl & Hcond & HR)".
+ iFrame. done.
+ - destruct weak as [ weak | ]; last done.
+ iIntros (ltyi2 ri2 bmin') "Hincl Hl2 Hcond".
+ iMod ("Hs" with "Hincl Hl2 Hcond") as "(Hl & Hcond & Htoks & HR)".
+ iFrame. iModIntro.
+ iDestruct "Hcond" as "(Ht & Hr)". iSplit.
+ + destruct bmin0; [done.. | ].
+ unfold typed_place_cond_ty. simp_ltypes. done.
+ + done.
+ Qed.
+ Global Instance typed_place_shrblocked_unblock_inst {rt} π E L l (ty : type rt) κ (r : place_rfn rt) bmin0 b P:
+ TypedPlace E L π l (ShrBlockedLtype ty κ) r bmin0 b P | 5 := λ T, i2p (typed_place_shrblocked_unblock π E L l ty κ r bmin0 b P T).
+
+ Lemma typed_place_coreable_unblock {rt} π E L l (lt : ltype rt) κs (r : place_rfn rt) bmin0 b P T :
+ ⌜bor_kind_writeable bmin0⌠∗ lft_dead_list κs ∗ typed_place π E L l (ltype_core lt) r bmin0 b P T
+ ⊢ typed_place π E L l (CoreableLtype κs lt) r bmin0 b P T.
+ Proof.
+ iIntros "(%Hw & Hdead & Hp)". iIntros (????) "#(LFT & TIME & LLCTX) #HE HL Hincl0 Hl HΦ".
+ iApply fupd_place_to_wp.
+ iMod (unblock_coreable with "Hdead Hl") as "Hl"; first done.
+ iModIntro.
+ iApply ("Hp" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hincl0 Hl").
+ iIntros (L' κs' l2 b2 bmin rti tyli ri strong weak) "Hincl1 Hl2 Hs HT HL".
+ iApply ("HΦ" $! _ _ _ _ _ _ _ _ _ _ with "Hincl1 Hl2 [Hs] HT HL").
+ iSplit.
+ - destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 Hcond".
+ iMod ("Hs" with "Hl2 Hcond") as "(Hl & Hcond & HR)".
+ iFrame. rewrite ltype_st_coreable. rewrite ltype_core_syn_type_eq. done.
+ - destruct weak as [ weak | ]; last done.
+ iIntros (ltyi2 ri2 bmin') "Hincl Hl2 Hcond".
+ iMod ("Hs" with "Hincl Hl2 Hcond") as "(Hl & Hcond & Htoks & HR)".
+ iFrame. iModIntro.
+ iDestruct "Hcond" as "(Ht & Hr)". iSplit.
+ + destruct bmin0; simpl; [simp_ltypes; done | done | ].
+ unfold typed_place_cond_ty. simp_ltypes. done.
+ + done.
+ Qed.
+ Global Instance typed_place_coreable_unblock_inst {rt} π E L l (lt : ltype rt) κs r bmin0 b P :
+ TypedPlace E L π l (CoreableLtype κs lt) r bmin0 b P | 5 :=
+ λ T, i2p (typed_place_coreable_unblock π E L l lt κs r bmin0 b P T).
+
+ Lemma typed_place_resolve_ghost {rt} π E L l (lt : ltype rt) bmin0 b γ P T :
+ ⌜lctx_bor_kind_alive E L b⌠∗ ⌜bor_kind_writeable bmin0⌠∗
+ resolve_ghost π E L ResolveAll false l lt b (PlaceGhost γ) (λ L' r R progress,
+ introduce_with_hooks E L' R (λ L'', typed_place π E L'' l lt r bmin0 b P T))
+ ⊢ typed_place π E L l lt (PlaceGhost γ) bmin0 b P T.
+ Proof.
+ iIntros "(% & %Hw & Hres)". iIntros (????) "#CTX #HE HL Hincl0 Hl HΦ".
+ iApply fupd_place_to_wp.
+ iMod ("Hres" with "[] [] CTX HE HL Hl") as "(%L' & %r & %R & %prog & Hstep & HL & HP)"; [done.. | ].
+ iMod "Hstep" as "(Hl & HR)".
+ iMod ("HP" with "[] HE HL HR") as "(%L'' & HL & HP)"; first done.
+ iModIntro. iApply ("HP" with "[//] [//] CTX HE HL Hincl0 Hl").
+ iIntros (L1 κs l2 b2 bmin rti tyli ri strong weak) "Hincl1 Hl2 Hs HT HL".
+ iApply ("HΦ" $! _ _ _ _ _ _ _ _ _ _ with "Hincl1 Hl2 [Hs] HT HL").
+ iSplit.
+ - destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 Hcond".
+ iMod ("Hs" with "Hl2 Hcond") as "(Hl & Hcond & HR)".
+ iFrame. done.
+ - destruct weak as [ weak | ]; last done.
+ iIntros (ltyi2 ri2 bmin') "Hincl Hl2 Hcond".
+ iMod ("Hs" with "Hincl Hl2 Hcond") as "(Hl & Hcond & Htoks & HR)".
+ iFrame. iModIntro.
+ iDestruct "Hcond" as "(Ht & Hr)". iSplit; first done.
+ destruct bmin0; done.
+ Qed.
+ (* this needs to have a lower priority than place_blocked_unblock *)
+ Global Instance typed_place_resolve_ghost_inst {rt} π E L l (lt : ltype rt) bmin0 b γ P :
+ TypedPlace E L π l lt (PlaceGhost γ) bmin0 b P | 8 := λ T, i2p (typed_place_resolve_ghost π E L l lt bmin0 b γ P T).
+
+ (** *** Place access instances *)
+
+ Import EqNotations.
+
+ (* generic instance constructors for descending below ofty *)
+ Lemma typed_place_ofty_access_val_owned π E L {rt} l (ty : type rt) (r : rt) bmin0 wl P T :
+ ty.(ty_has_op_type) PtrOp MCCopy →
+ (∀ F v, ⌜lftE ⊆ F⌠-∗
+ v â—áµ¥{Ï€} r @ ty ={F}=∗
+ ∃ (l2 : loc) (rt2 : Type) (lt2 : ltype rt2) r2 b2, ⌜v = l2⌠∗
+ v â—áµ¥{Ï€} r @ ty ∗ l2 â—â‚—[Ï€, b2] r2 @ lt2 ∗
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' [] li b3 bmin rti ltyi ri
+ (match strong with
+ | Some strong => Some $ mk_strong (λ _, _) (λ _ _ _, â— ty) (λ _ _, #r) (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)
+ | None => None
+ end)
+ (match weak with
+ | Some weak => Some $ mk_weak (λ _ _, â— ty) (λ _, #r) (λ ltyi2 ri2, llft_elt_toks κs ∗ l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)
+ | None =>
+ match strong with
+ | Some strong => Some $ mk_weak (λ _ _, â— ty) (λ _, #r) (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)
+ | None => None
+ end
+ end)
+ ))
+ ⊢
+ typed_place π E L l (◠ty) (PlaceIn r) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iIntros (Hot) "HT".
+ iIntros (????) "#CTX #HE HL #Hincl Hl Hcont". iApply fupd_place_to_wp.
+ iPoseProof (ofty_ltype_acc_owned ⊤ with "Hl") as "(%ly & %Halg & %Hly & Hsc & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ simpl. iModIntro.
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply (wp_logical_step with "TIME Hcl"); [done.. | ].
+ specialize (ty_op_type_stable Hot) as Halg'.
+ assert (ly = ot_layout PtrOp) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ iApply (wp_deref with "Hl"); [by right | | done | done | ].
+ { by rewrite val_to_of_loc. }
+ iNext. iIntros (st) "Hl Hcred Ha".
+ iMod ("HT" with "[] Hv") as "(%l2 & %rt2 & %lt2 & %r2 & %b2 & -> & Hv & Hl2 & HT)"; first done.
+ iMod ("Ha" with "Hl [//] Hsc Hv") as "Hl".
+ iModIntro.
+ iExists l2. rewrite mem_cast_id_loc. iSplitR; first done.
+ iApply ("HT" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hl2").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L2 κs l3 b3 bmin rti ltyi ri strong weak) "#Hincl1 Hl3 Hcl HT HL".
+ iApply ("Hcont" with "[//] Hl3 [Hcl Hl] HT HL").
+ iSplit.
+ - (* strong *) iDestruct "Hcl" as "[Hcl _]". simpl.
+ destruct strong as [ strong | ]; simpl; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 %Hst".
+ iMod ("Hcl" with "Hl2 [//]") as "(Hl' & % & Hstrong)".
+ iModIntro. iFrame. done.
+ - (* weak *)
+ destruct weak as [weak | ]; simpl.
+ + iDestruct "Hcl" as "[_ Hcl]". simpl.
+ iIntros (ltyi2 ri2 ?) "#Hincl3 Hl2 Hcond".
+ iMod ("Hcl" with "Hincl3 Hl2 Hcond") as "(Hl' & Hcond & Htoks & Hweak)".
+ iModIntro. iFrame. iSplitL.
+ { iApply typed_place_cond_refl. done. }
+ rewrite /llft_elt_toks. done.
+ + destruct strong as [ strong | ]; simpl; last done.
+ iDestruct "Hcl" as "[Hcl _]".
+ iIntros (ltyi2 ri2 ?) "#Hincl3 Hl2 Hcond".
+ iPoseProof (typed_place_cond_syn_type_eq with "Hcond") as "%Hst".
+ iMod ("Hcl" with "Hl2 [//]") as "(Hl' & %Hst' & Hweak)".
+ iFrame. iModIntro.
+ iSplitL. { iApply typed_place_cond_refl. done. }
+ rewrite /llft_elt_toks. done.
+ Qed.
+
+ (* TODO generalize this similarly as the one above? *)
+ Lemma typed_place_ofty_access_val_uniq π E L {rt} l (ty : type rt) (r : rt) bmin0 κ γ P T :
+ ty.(ty_has_op_type) PtrOp MCCopy →
+ ⌜lctx_lft_alive E L κ⌠∗
+ (∀ F v, ⌜lftE ⊆ F⌠-∗
+ v â—áµ¥{Ï€} r @ ty ={F}=∗
+ ∃ (l2 : loc) (rt2 : Type) (lt2 : ltype rt2) r2 b2, ⌜v = l2⌠∗
+ v â—áµ¥{Ï€} r @ ty ∗ l2 â—â‚—[Ï€, b2] r2 @ lt2 ∗
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' κs li b3 bmin rti ltyi ri
+ (option_map (λ strong, mk_strong (λ _, _) (λ _ _ _, ◠ty) (λ _ _, PlaceIn r)
+ (* give back ownership through R *)
+ (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (option_map (λ weak, mk_weak (λ _ _, ◠ty) (λ _, PlaceIn r)
+ (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ ))
+ ⊢ typed_place π E L l (◠ty) (PlaceIn r) bmin0 (Uniq κ γ) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iIntros (Hot) "(%Hal & HT)".
+ iIntros (????) "#CTX #HE HL #Hincl Hl Hcont". iApply fupd_place_to_wp.
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iMod (fupd_mask_subseteq lftE) as "HF_cl"; first done.
+ iMod (Hal with "HE HL") as "(%q' & Htok & HL_cl2)"; first done.
+ iPoseProof (ofty_ltype_acc_uniq lftE with "CTX Htok HL_cl2 Hl") as "(%ly & %Halg & %Hly & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iMod "HF_cl" as "_".
+ simpl. iModIntro.
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply (wp_logical_step with "TIME Hcl"); [done.. | ].
+ specialize (ty_op_type_stable Hot) as Halg'.
+ assert (ly = ot_layout PtrOp) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ iApply (wp_deref with "Hl"); [by right | | done | done | ].
+ { by rewrite val_to_of_loc. }
+ iNext. iIntros (st) "Hl Hcred [Ha _]".
+ iMod ("HT" with "[] Hv") as "(%l2 & %rt2 & %lt2 & %r2 & %b2 & -> & Hv & Hl2 & HT)"; first done.
+ iMod (fupd_mask_mono with "(Ha Hl Hv)") as "(Hl & HL)"; first done.
+ iPoseProof ("HL_cl" with "HL") as "HL".
+ iModIntro.
+ iExists l2. rewrite mem_cast_id_loc. iSplitR; first done.
+ iApply ("HT" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hl2").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L2 κs l3 b3 bmin rti ltyi ri strong weak) "#Hincl1 Hl3 Hcl HT HL".
+ iApply ("Hcont" with "[//] Hl3 [Hcl Hl] HT HL").
+ iSplit.
+ - (* strong *) iDestruct "Hcl" as "[Hcl _]". simpl.
+ destruct strong as [ strong | ]; simpl; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 %Hst".
+ iMod ("Hcl" with "Hl2 [//]") as "(Hl' & % & Hstrong)".
+ iModIntro. iFrame. done.
+ - (* weak *) iDestruct "Hcl" as "[_ Hcl]". simpl.
+ destruct weak as [weak | ]; simpl; last done.
+ iIntros (ltyi2 ri2 ?) "#Hincl3 Hl2 Hcond".
+ iMod ("Hcl" with "Hincl3 Hl2 Hcond") as "(Hl' & Hcond & Htoks & Hweak)".
+ iModIntro. iFrame.
+ iApply typed_place_cond_refl. done.
+ Qed.
+
+ (* NOTE: we need to require it to be a simple type to get this generic lemma *)
+ Lemma typed_place_ofty_access_val_shared π E L {rt} l (ty : simple_type rt) (r : rt) bmin0 κ P T :
+ ty.(ty_has_op_type) PtrOp MCCopy →
+ ⌜lctx_lft_alive E L κ⌠∗
+ (∀ F v, ⌜lftE ⊆ F⌠-∗
+ v â—áµ¥{Ï€} r @ ty ={F}=∗
+ ∃ (l2 : loc) (rt2 : Type) (lt2 : ltype rt2) r2 b2, ⌜v = l2⌠∗
+ v â—áµ¥{Ï€} r @ ty ∗ l2 â—â‚—[Ï€, b2] r2 @ lt2 ∗
+ typed_place π E L l2 lt2 r2 b2 b2 P (λ L' κs li b3 bmin rti ltyi ri strong weak,
+ T L' κs li b3 bmin rti ltyi ri
+ (option_map (λ strong, mk_strong (λ _, _) (λ _ _ _, ◠ty) (λ _ _, PlaceIn r)
+ (* give back ownership through R *)
+ (λ rti2 ltyi2 ri2, l2 â—â‚—[Ï€, b2] strong.(strong_rfn) _ ri2 @ strong.(strong_lt) _ ltyi2 ri2 ∗ strong.(strong_R) _ ltyi2 ri2)) strong)
+ (option_map (λ weak, mk_weak (λ _ _, ◠ty) (λ _, PlaceIn r)
+ (λ ltyi2 ri2, l2 â—â‚—[Ï€, b2] weak.(weak_rfn) ri2 @ weak.(weak_lt) ltyi2 ri2 ∗ weak.(weak_R) ltyi2 ri2)) weak)
+ ))
+ ⊢ typed_place π E L l (◠ty) (PlaceIn r) bmin0 (Shared κ) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iIntros (Hot) "(%Hal & HT)".
+ iIntros (????) "#CTX #HE HL #Hincl #Hl Hcont". iApply fupd_place_to_wp.
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iMod (Hal with "HE HL") as "(%q' & Htok & HL_cl2)"; first done.
+ iPoseProof (ofty_ltype_acc_shared ⊤ with "Hl") as "(%ly & %Halg & %Hly & Hlb & >Hb)"; first done.
+ rewrite simple_type_shr_equiv. iDestruct "Hb" as "(%v & %ly' & % & %Hly' & Hloc & Hv)".
+ assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iMod (frac_bor_acc with "LFT Hloc Htok") as "(%q0 & >Hloc & Hl_cl)"; first done.
+ simpl. iModIntro.
+ specialize (ty_op_type_stable Hot) as Halg'.
+ assert (ly = ot_layout PtrOp) as -> by by eapply syn_type_has_layout_inj.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "#>%Hlyv"; first done.
+ iApply wp_fupd.
+ iApply (wp_deref with "Hloc"); [by right | | done | done | ].
+ { by rewrite val_to_of_loc. }
+ iNext. iIntros (st) "Hloc Hcred".
+ iMod ("HT" with "[] Hv") as "(%l2 & %rt2 & %lt2 & %r2 & %b2 & -> & Hv & Hl2 & HT)"; first done.
+ iMod ("Hl_cl" with "Hloc") as "Htok".
+ iMod ("HL_cl2" with "Htok") as "HL". iPoseProof ("HL_cl" with "HL") as "HL".
+ iModIntro.
+ iExists l2. rewrite mem_cast_id_loc. iSplitR; first done.
+ iApply ("HT" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hl2").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L2 κs l3 b3 bmin rti ltyi ri strong weak) "#Hincl1 Hl3 Hcl HT HL".
+ iApply ("Hcont" with "[//] Hl3 [Hcl Hv] HT HL").
+ iSplit.
+ - (* strong *) iDestruct "Hcl" as "[Hcl _]". simpl.
+ destruct strong as [ strong | ]; simpl; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 %Hst".
+ iMod ("Hcl" with "Hl2 [//]") as "(Hl' & % & Hstrong)".
+ iModIntro. iFrame. iSplitR; done.
+ - (* weak *) iDestruct "Hcl" as "[_ Hcl]". simpl.
+ destruct weak as [weak | ]; simpl; last done.
+ iIntros (ltyi2 ri2 ?) "#Hincl3 Hl2 Hcond".
+ iMod ("Hcl" with "Hincl3 Hl2 Hcond") as "(Hl' & Hcond & Htoks & Hweak)".
+ iModIntro. iFrame. iSplitR; first done.
+ iApply typed_place_cond_refl. done.
+ Qed.
+
+ (* instances for Opened *)
+ (* NOTE: these should have a higher priority than place id, because we always want to descend below Opened when accessing a place, in order to get the actual current type *)
+ Lemma typed_place_opened_owned π E L {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost r bmin0 l wl P T :
+ typed_place π E L l lt_cur r bmin0 (Owned false) P (λ L' κs l2 b2 bmin rti ltyi ri strong weak,
+ T L' κs l2 b2 bmin rti ltyi ri
+ (option_map (λ strong, mk_strong strong.(strong_rt)
+ (λ rti2 ltyi2 ri2, OpenedLtype (strong.(strong_lt) _ ltyi2 ri2) lt_inner lt_full Cpre Cpost)
+ (λ rti2 ri2, strong.(strong_rfn) _ ri2)
+ strong.(strong_R)) strong)
+ (* no weak access possible -- we currently don't have the machinery to restore and fold invariants at this point, though we could in principle enable this *)
+ None)
+ ⊢ typed_place π E L l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r bmin0 (Owned wl) P T.
+ Proof.
+ iIntros "HT". iIntros (Φ F ??) "#CTX #HE HL #Hincl0 Hl HR".
+ iPoseProof (opened_ltype_acc_owned with "Hl") as "(Hl & Hcl)".
+ iApply ("HT" with "[//] [//] CTX HE HL [] Hl").
+ { destruct bmin0; done. }
+ iIntros (L' ??????? strong weak) "? Hl Hv".
+ iApply ("HR" with "[$] Hl").
+ iSplit; last done.
+ destruct strong as [ strong | ]; last done.
+ iIntros (???) "Hl Hst".
+ iDestruct "Hv" as "[Hv _]".
+ iMod ("Hv" with "Hl Hst") as "(Hl & %Hst & $)".
+ iPoseProof ("Hcl" with "Hl [//]") as "Hl".
+ cbn. eauto with iFrame.
+ Qed.
+ Global Instance typed_place_opened_owned_inst π E L {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost r bmin0 l wl P :
+ TypedPlace E L π l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r bmin0 (Owned wl) P | 5 :=
+ λ T, i2p (typed_place_opened_owned π E L lt_cur lt_inner lt_full Cpre Cpost r bmin0 l wl P T).
+
+ Lemma typed_place_opened_uniq π E L {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost r bmin0 l κ γ P T :
+ typed_place π E L l lt_cur r bmin0 (Owned false) P (λ L' κs l2 b2 bmin rti ltyi ri strong weak,
+ T L' κs l2 b2 bmin rti ltyi ri
+ (option_map (λ strong, mk_strong strong.(strong_rt)
+ (λ rti2 ltyi2 ri2, OpenedLtype (strong.(strong_lt) _ ltyi2 ri2) lt_inner lt_full Cpre Cpost)
+ (λ rti2 ri2, strong.(strong_rfn) _ ri2)
+ strong.(strong_R)) strong)
+ (* no weak access possible -- we currently don't have the machinery to restore and fold invariants at this point, though we could in principle enable this *)
+ None)
+ ⊢ typed_place π E L l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r bmin0 (Uniq κ γ) P T.
+ Proof.
+ iIntros "HT". iIntros (Φ F ??) "#CTX #HE HL #Hincl0 Hl HR".
+ iPoseProof (opened_ltype_acc_uniq with "Hl") as "(Hl & Hcl)".
+ iApply ("HT" with "[//] [//] CTX HE HL [] Hl").
+ { destruct bmin0; done. }
+ iIntros (L' ??????? strong weak) "? Hl Hv".
+ iApply ("HR" with "[$] Hl").
+ iSplit; last done.
+ destruct strong as [ strong | ]; last done.
+ iIntros (???) "Hl Hst".
+ iDestruct "Hv" as "[Hv _]".
+ iMod ("Hv" with "Hl Hst") as "(Hl & %Hst & $)".
+ iPoseProof ("Hcl" with "Hl [//]") as "Hl".
+ cbn. eauto with iFrame.
+ Qed.
+ Global Instance typed_place_opened_uniq_inst π E L {rt_cur rt_inner rt_full} (lt_cur : ltype rt_cur) (lt_inner : ltype rt_inner) (lt_full : ltype rt_full) Cpre Cpost r bmin0 l κ γ P :
+ TypedPlace E L π l (OpenedLtype lt_cur lt_inner lt_full Cpre Cpost) r bmin0 (Uniq κ γ) P | 5 :=
+ λ T, i2p (typed_place_opened_uniq π E L lt_cur lt_inner lt_full Cpre Cpost r bmin0 l κ γ P T).
+
+ Lemma typed_place_shadowed_shared π E L {rt_cur rt_full} (lt_cur : ltype rt_cur) (lt_full : ltype rt_full) r_cur (r_full : place_rfn rt_full) bmin0 l κ P (T : place_cont_t rt_full) :
+ typed_place π E L l lt_cur (#r_cur) bmin0 (Shared κ) P (λ L' κs l2 b2 bmin rti ltyi ri strong weak,
+ T L' κs l2 b2 bmin rti ltyi ri
+ (option_map (λ strong, mk_strong (λ _, rt_full) (λ rti ltyi ri, ShadowedLtype (strong.(strong_lt) _ ltyi ri) (strong.(strong_rfn) _ ri) lt_full) (λ _ _, r_full) strong.(strong_R)) strong)
+ (* no weak updates due to place cond *)
+ None
+ (*(option_map (λ weak, mk_weak (λ ltyi ri, ShadowedLtype (weak.(weak_lt) ltyi ri) (weak.(weak_rfn) ri) lt_full) (λ _, r_full) weak.(weak_R)) weak)*)
+ )
+ ⊢ typed_place π E L l (ShadowedLtype lt_cur (#r_cur) lt_full) r_full bmin0 (Shared κ) P T.
+ Proof.
+ iIntros "HT".
+ iIntros (????) "#CTX #HE HL Hincl Hl Hc".
+ iPoseProof (shadowed_ltype_acc_cur with "Hl") as "(Hcur & Hcl)".
+ iApply ("HT" with "[//] [//] CTX HE HL Hincl Hcur").
+ iIntros (L' κs l2 b2 bmin rti ltyi ri strong weak) "Hincl' Hl Hcc".
+ iApply ("Hc" with "Hincl' Hl").
+ iSplit; last done. simpl.
+ destruct strong as [ strong | ]; simpl; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl %Hst".
+ iDestruct "Hcc" as "[ Hcc _]".
+ iMod ("Hcc" with "Hl [//]") as "(Hl & %Hst' & $)".
+ iPoseProof ("Hcl" with "[] Hl") as "Hl".
+ { done. }
+ iFrame.
+ simp_ltypes. done.
+ Qed.
+ Global Instance typed_place_shadowed_shr_inst π E L {rt_cur rt_full} (lt_cur : ltype rt_cur) (lt_full : ltype rt_full) r_cur r_full bmin0 l κ P :
+ TypedPlace E L π l (ShadowedLtype lt_cur #r_cur lt_full) r_full bmin0 (Shared κ) P | 5 :=
+ λ T, i2p (typed_place_shadowed_shared π E L lt_cur lt_full r_cur r_full bmin0 l κ P T).
+
+ (** typing of expressions *)
+ Lemma typed_val_expr_wand E L e π T1 T2 :
+ typed_val_expr π E L e T1 -∗
+ (∀ L' v rt ty r, T1 L' v rt ty r -∗ T2 L' v rt ty r) -∗
+ typed_val_expr π E L e T2.
+ Proof.
+ iIntros "He HT" (Φ) "#LFT #HE HL HΦ".
+ iApply ("He" with "LFT HE HL"). iIntros (L' v rt ty r) "HL Hv Hty".
+ iApply ("HΦ" with "HL Hv"). by iApply "HT".
+ Qed.
+
+ Lemma typed_if_wand E L v (P T1 T2 T1' T2' : iProp Σ):
+ typed_if E L v P T1 T2 -∗
+ ((T1 -∗ T1') ∧ (T2 -∗ T2')) -∗
+ typed_if E L v P T1' T2'.
+ Proof.
+ iIntros "Hif HT Hv". iDestruct ("Hif" with "Hv") as (b ?) "HC".
+ iExists _. iSplit; first done. destruct b.
+ - iDestruct "HT" as "[HT _]". by iApply "HT".
+ - iDestruct "HT" as "[_ HT]". by iApply "HT".
+ Qed.
+
+ Lemma typed_bin_op_wand E L π v1 P1 Q1 v2 P2 Q2 op ot1 ot2 T:
+ typed_bin_op π E L v1 Q1 v2 Q2 op ot1 ot2 T -∗
+ (P1 -∗ Q1) -∗
+ (P2 -∗ Q2) -∗
+ typed_bin_op π E L v1 P1 v2 P2 op ot1 ot2 T.
+ Proof.
+ iIntros "H Hw1 Hw2 H1 H2".
+ iApply ("H" with "[Hw1 H1]"); [by iApply "Hw1"|by iApply "Hw2"].
+ Qed.
+
+ Lemma typed_un_op_wand E L π v P Q op ot T:
+ typed_un_op π E L v Q op ot T -∗
+ (P -∗ Q) -∗
+ typed_un_op π E L v P op ot T.
+ Proof.
+ iIntros "H Hw HP". iApply "H". by iApply "Hw".
+ Qed.
+
+ Definition uncurry_rty {T} (f : ∀ rt, type rt → rt → T) : sigT (λ rt, type rt * rt)%type → T :=
+ λ '(existT rt (ty, r)), f rt ty r.
+
+ Lemma type_val_context v π T :
+ (find_in_context (FindVal v π) (uncurry_rty T)) ⊢ typed_value v π T.
+ Proof.
+ iDestruct 1 as ([rt [ty r]]) "[Hv HT]". simpl in *.
+ iIntros "LFT". iExists _, _, _. iFrame.
+ Qed.
+ Global Instance type_val_context_inst v π :
+ TypedValue v π | 100 := λ T, i2p (type_val_context v π T).
+
+ Lemma type_val E L v π T :
+ typed_value v π (T L v) ⊢ typed_val_expr π E L (Val v) T.
+ Proof.
+ iIntros "Hv" (Φ) "#LFT #HE HL HΦ".
+ iDestruct ("Hv" with "LFT") as "(%rt & %ty & %r & Hty & HT)".
+ iApply wp_value. iApply ("HΦ" with "HL Hty HT").
+ Qed.
+
+ Lemma type_call E L π T ef eκs es:
+ (∃ M, named_lfts M ∗
+ li_tactic (compute_map_lookups_nofail_goal M eκs) (λ eκs',
+ named_lfts M -∗
+ typed_val_expr π E L ef (λ L' vf rtf tyf rf,
+ foldr (λ e T L'' vl tys, typed_val_expr π E L'' e (λ L''' v rt ty r, T L''' (vl ++ [v]) (tys ++ [existT rt (ty, r)])))
+ (λ L'' vl tys, typed_call Ï€ E L'' eκs' vf (vf â—áµ¥{Ï€} rf @ tyf) vl tys T)
+ es L' [] [])))
+ ⊢ typed_val_expr π E L (CallE ef eκs es) T.
+ Proof.
+ rewrite /compute_map_lookups_nofail_goal.
+ iIntros "(%M & Hnamed & %eκs' & _ & He)". iIntros (Φ) "#CTX #HE HL HΦ".
+ rewrite /CallE.
+ iApply wp_call_bind. iApply ("He" with "Hnamed CTX HE HL"). iIntros (L' vf rtf tyf rf) "HL Hvf HT".
+ iAssert ([∗ list] v;rty∈[];([] : list $ @sigT Type (λ rt, (type rt * rt)%type)), let '(existT rt (ty, r)) := rty in v â—áµ¥{Ï€} r @ ty)%I as "-#Htys". { done. }
+ move: {2 3 5} ([] : list val) => vl.
+ generalize (@nil (@sigT Type (fun rt : Type => prod (@type Σ H rt) rt))) at 2 3 as tys; intros tys.
+ iInduction es as [|e es] "IH" forall (L' vl tys) => /=. 2: {
+ iApply ("HT" with "CTX HE HL"). iIntros (L'' v rt ty r) "HL Hv Hnext". iApply ("IH" with "HΦ HL Hvf Hnext").
+ iFrame. by iApply big_sepL2_nil.
+ }
+ by iApply ("HT" with "Hvf Htys CTX HE HL").
+ Qed.
+
+ Lemma type_bin_op E L o e1 e2 ot1 ot2 π T :
+ typed_val_expr π E L e1 (λ L1 v1 rt1 ty1 r1, typed_val_expr π E L1 e2 (λ L2 v2 rt2 ty2 r2,
+ typed_bin_op Ï€ E L2 v1 (v1 â—áµ¥{Ï€} r1 @ ty1) v2 (v2 â—áµ¥{Ï€} r2 @ ty2) o ot1 ot2 T))
+ ⊢ typed_val_expr π E L (BinOp o ot1 ot2 e1 e2) T.
+ Proof.
+ iIntros "He1" (Φ) "#LFT #HE HL HΦ".
+ wp_bind. iApply ("He1" with "LFT HE HL"). iIntros (L1 v1 rt1 ty1 r1) "HL Hv1 He2".
+ wp_bind. iApply ("He2" with "LFT HE HL"). iIntros (L2 v2 rt2 ty2 r2) "HL Hv2 Hop".
+ iApply ("Hop" with "Hv1 Hv2 LFT HE HL HΦ").
+ Qed.
+
+ Lemma type_un_op E L o e ot π T :
+ typed_val_expr Ï€ E L e (λ L' v rt ty r, typed_un_op Ï€ E L' v (v â—áµ¥{Ï€} r @ ty) o ot T)
+ ⊢ typed_val_expr π E L (UnOp o ot e) T.
+ Proof.
+ iIntros "He" (Φ) "#LFT #HE HL HΦ".
+ wp_bind. iApply ("He" with "LFT HE HL"). iIntros (L' v rt ty r) "HL Hv Hop".
+ by iApply ("Hop" with "Hv LFT HE HL").
+ Qed.
+
+ Lemma type_ife E L e1 e2 e3 π T:
+ typed_val_expr Ï€ E L e1 (λ L' v rt ty r, typed_if E L' v (v â—áµ¥{Ï€} r @ ty) (typed_val_expr Ï€ E L' e2 T) (typed_val_expr Ï€ E L' e3 T))
+ ⊢ typed_val_expr π E L (IfE BoolOp e1 e2 e3) T.
+ Proof.
+ iIntros "He1" (Φ) "#LFT #HE HL HΦ".
+ wp_bind. iApply ("He1" with "LFT HE HL"). iIntros (L1 v1 rt1 ty1 r1) "HL Hv1 Hif".
+ iDestruct ("Hif" with "Hv1") as "HT".
+ iDestruct "HT" as (b) "(% & HT)".
+ iApply wp_if_bool; [done|..]. iIntros "!> Hcred".
+ destruct b; by iApply ("HT" with "LFT HE HL").
+ Qed.
+
+ Lemma type_annot_expr E L n {A} (a : A) e π T:
+ typed_val_expr Ï€ E L e (λ L' v rt ty r, typed_annot_expr Ï€ E L' n a v (v â—áµ¥{Ï€} r @ ty) T)
+ ⊢ typed_val_expr π E L (AnnotExpr n a e) T.
+ Proof.
+ iIntros "He" (Φ) "#LFT #HE HL HΦ".
+ wp_bind. iApply ("He" with "LFT HE HL"). iIntros (L' v rt ty r) "HL Hv HT".
+ iDestruct ("HT" with "LFT HE HL Hv") as "HT".
+ iInduction n as [|n] "IH" forall (Φ). {
+ rewrite /AnnotExpr/=.
+ iApply fupd_wp.
+ iMod "HT" as "(%L2 & % & % & % & HL & Hv & Hf)".
+ iApply wp_value.
+ iApply ("HΦ" with "[$] [$] [$]").
+ }
+ rewrite annot_expr_S_r. wp_bind.
+ iApply wp_skip. iIntros "!> Hcred".
+ iApply fupd_wp. iMod "HT".
+ iMod (lc_fupd_elim_later with "Hcred HT") as ">HT". iModIntro.
+ iApply ("IH" with "HΦ HT").
+ Qed.
+
+ Lemma type_logical_and E L e1 e2 π T:
+ typed_val_expr Ï€ E L e1 (λ L1 v1 rt1 ty1 r1, typed_if E L1 v1 (v1 â—áµ¥{Ï€} r1 @ ty1)
+ (typed_val_expr Ï€ E L1 e2 (λ L2 v2 rt2 ty2 r2, typed_if E L2 v2 (v2 â—áµ¥{Ï€} r2 @ ty2)
+ (typed_value (val_of_bool true) π (T L2 (val_of_bool true))) (typed_value (val_of_bool false) π (T L2 (val_of_bool false)))))
+ (typed_value (val_of_bool false) π (T L1 (val_of_bool false))))
+ ⊢ typed_val_expr π E L (e1 &&{BoolOp, BoolOp, u8} e2)%E T.
+ Proof.
+ iIntros "HT". rewrite /LogicalAnd. iApply type_ife.
+ iApply (typed_val_expr_wand with "HT"). iIntros (L1 v rt ty r) "HT".
+ iApply (typed_if_wand with "HT"). iSplit; iIntros "HT".
+ 2: { iApply type_val. by rewrite !val_of_bool_i2v. }
+ iApply type_ife.
+ iApply (typed_val_expr_wand with "HT"). iIntros (L2 v2 rt2 ty2 r2) "HT".
+ iApply (typed_if_wand with "HT"). iSplit; iIntros "HT"; iApply type_val; by rewrite !val_of_bool_i2v.
+ Qed.
+
+ Lemma type_logical_or E L e1 e2 π T:
+ typed_val_expr Ï€ E L e1 (λ L1 v1 rt1 ty1 r1, typed_if E L1 v1 (v1 â—áµ¥{Ï€} r1 @ ty1)
+ (typed_value (val_of_bool true) π (T L1 (val_of_bool true)))
+ (typed_val_expr Ï€ E L1 e2 (λ L2 v2 rt2 ty2 r2, typed_if E L2 v2 (v2 â—áµ¥{Ï€} r2 @ ty2)
+ (typed_value (val_of_bool true) π (T L2 (val_of_bool true))) (typed_value (val_of_bool false) π (T L2 (val_of_bool false))))))
+ ⊢ typed_val_expr π E L (e1 ||{BoolOp, BoolOp, u8} e2)%E T.
+ Proof.
+ iIntros "HT". rewrite /LogicalOr. iApply type_ife.
+ iApply (typed_val_expr_wand with "HT"). iIntros (L1 v rt ty r) "HT".
+ iApply (typed_if_wand with "HT"). iSplit; iIntros "HT".
+ 1: { iApply type_val. by rewrite !val_of_bool_i2v. }
+ iApply type_ife.
+ iApply (typed_val_expr_wand with "HT"). iIntros (L2 v2 rt2 ty2 r2) "HT".
+ iApply (typed_if_wand with "HT"). iSplit; iIntros "HT"; iApply type_val; by rewrite !val_of_bool_i2v.
+ Qed.
+
+ (** Similar to type_assign, use is formulated with a skip over the expression, in order to allow
+ on-demand unblocking. We can't just use any of the potential place access steps, because there might not be any (if it's just a location). So we can't easily use any of the other steps around.
+ *)
+ Lemma type_use E L ot T e o π :
+ ⌜if o is Na2Ord then False else True⌠∗ typed_read π E L e ot T
+ ⊢ typed_val_expr π E L (use{ot, o} e) T.
+ Proof.
+ iIntros "[% Hread]" (Φ) "#(LFT & TIME & LLCTX) #HE HL HΦ".
+ wp_bind.
+ iApply ("Hread" $! _ ⊤ with "[//] [//] [//] [$TIME $LFT $LLCTX] HE HL").
+ iIntros (l) "Hl".
+ iApply ewp_fupd.
+ rewrite /Use. wp_bind.
+ iApply (wp_logical_step with "TIME Hl"); [solve_ndisj.. | ].
+ iApply wp_skip. iNext. iIntros "_".
+ iIntros "(%v & %q & %rt & %ty & %r & %Hlyv & %Hv & Hl & Hv & Hcl)".
+ iModIntro. iApply (wp_logical_step with "TIME Hcl"); [solve_ndisj.. | ].
+ iApply (wp_deref with "Hl") => //; try by eauto using val_to_of_loc.
+ { destruct o; naive_solver. }
+ iIntros "!> %st Hl Hcred Hcl".
+ iMod ("Hcl" with "Hl Hv") as "(%L' & %rt' & %ty' & %r' & HL & Hv & HT)"; iModIntro.
+ by iApply ("HΦ" with "HL Hv HT").
+ Qed.
+
+ (* This lemma is about AssignSE, which adds a skip around the LHS expression.
+ The reason is that we might need to unblock e1 first and only after that get access to the location we need for justifying the actual write
+ - so we can't just use the actual write step,
+ - and we also cannot use the place access on the LHS itself, because that might not even take a step (if it's just a location).
+ *)
+ Lemma type_assign E L Ï€ ot e1 e2 s fn R o Ï :
+ typed_val_expr π E L e2 (λ L' v rt ty r, ⌜if o is Na2Ord then False else True⌠∗
+ typed_write Ï€ E L' e1 ot v ty r (λ L'', typed_stmt Ï€ E L'' s fn R Ï))
+ ⊢ typed_stmt Ï€ E L (e1 <-{ot, o} e2; s) fn R Ï.
+ Proof.
+ iIntros "He". iIntros "#(LFT & TIME & LLCTX) #HE HL".
+ wps_bind. iApply ("He" with "[$TIME $LFT $LLCTX] HE HL"). iIntros (L' v rt ty r) "HL Hv [% He1]".
+ wps_bind. iApply ("He1" $! _ ⊤ with "[//] [//] [//] [$TIME $LFT $LLCTX] HE HL"). iIntros (l) "HT".
+ unfold AssignSE. wps_bind.
+ iSpecialize ("HT" with "Hv").
+ iApply (wp_logical_step with "TIME HT"); [solve_ndisj.. | ].
+ iApply (wp_skip).
+ iNext. iIntros "Hcred (Hly & Hl & Hcl)".
+ iModIntro.
+ (* TODO find a way to do this without destructing the logstep *)
+ rewrite /logical_step.
+ iMod "Hcl" as "(%n & Hat & Hcl)".
+ iMod (persistent_time_receipt_0) as "Hp".
+ iApply (wps_assign_credits with "TIME Hp Hat"); rewrite ?val_to_of_loc //. { destruct o; naive_solver. }
+ iMod (fupd_mask_subseteq) as "Hcl_m"; last iApply fupd_intro.
+ { destruct o; solve_ndisj. }
+ iFrame. iNext. iIntros "Hl Hat Hcred'". iMod "Hcl_m" as "_".
+ rewrite Nat.add_0_r. iDestruct "Hcred'" as "(Hcred1 & Hcred')".
+ rewrite (additive_time_receipt_sep 1). iDestruct "Hat" as "(Hat1 & Hat)".
+ iMod ("Hcl" with "Hcred' Hat Hl") as ">(%L'' & HL & Hs)".
+ (* TODO maybe provide excess credits + receipt *)
+ by iApply ("Hs" with "[$TIME $LFT $LLCTX] HE HL").
+ Qed.
+
+ Lemma type_mut_addr_of π E L e T :
+ typed_addr_of_mut π E L e T
+ ⊢ typed_val_expr π E L (&raw{Mut} e) T.
+ Proof.
+ iIntros "HT" (?) "#CTX #HE HL Hcont".
+ rewrite /Raw. wp_bind.
+ iApply ("HT" $! _ ⊤ with "[//] [//] [//] CTX HE HL").
+ iIntros (l) "HT".
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply (wp_logical_step with "TIME HT"); [done.. | ].
+ iApply wp_skip. iNext. iIntros "Hcred".
+ iDestruct 1 as (L' rt ty r) "(Hl & HL & HT)".
+ iApply ("Hcont" with "HL Hl HT").
+ Qed.
+ (* Corresponding lemmas for borrows are in references.v *)
+
+
+ Import EqNotations.
+ Lemma type_read π E L T T' e ot :
+ IntoPlaceCtx π E e T' →
+ T' L (λ L' K l, find_in_context (FindLoc l π) (λ '(existT rto (lt1, r1, b)),
+ typed_place π E L' l lt1 r1 b b K (λ (L1 : llctx) (κs : list lft) (l2 : loc) (b2 bmin : bor_kind) rti (lt2 : ltype rti) (ri2 : place_rfn rti) (strong : option $ strong_ctx rti) (weak : option $ weak_ctx rto rti),
+ (* unblock etc. *)
+ stratify_ltype_unblock π E L1 StratRefoldOpened l2 lt2 ri2 b2 (λ L2 R rt3 lt3 ri3,
+ (* certify that this stratification is allowed, or otherwise commit to a strong update *)
+ prove_place_cond E L2 bmin lt2 lt3 (λ upd,
+ prove_place_rfn_cond (if upd is ResultWeak _ then true else false) bmin ri2 ri3 (
+ (* TODO remove this and instead have a [ltype_read_as] TC or so. Currently this will prevent us from reading from ShrBlocked*)
+ cast_ltype_to_type E L2 lt3 (λ ty3,
+ (* end reading *)
+ typed_read_end π E L2 l2 (◠ty3) ri3 b2 bmin (if strong is Some _ then AllowStrong else AllowWeak) ot (λ L3 v rt3 ty3 r3 rt2' lt2' ri2' upd2,
+ typed_place_finish π E L3 strong weak (access_result_meet upd upd2) R (llft_elt_toks κs) l b lt2' ri2' (λ L4, T L4 v _ ty3 r3))
+ )))))))%I
+ ⊢ typed_read π E L e ot T.
+ Proof.
+ iIntros (HT') "HT'". iIntros (Φ F ???) "#CTX #HE HL HΦ".
+ iApply (HT' with "CTX HE HL HT'").
+ iIntros (L' K l) "HL". iDestruct 1 as ([rt ([ty r] & ?)]) "[Hl HP]".
+ iApply ("HP" with "[//] [//] CTX HE HL [] Hl").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L'' κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hl2 Hs HT HL".
+ iApply "HΦ".
+ iPoseProof ("HT" with "[//] [//] CTX HE HL Hl2") as "Hb".
+ iApply fupd_logical_step. iApply logical_step_fupd.
+ iMod "Hb" as "(%L2 & %R & %rt2' & %lt2' & %ri2 & HL & %Hst & Hl2 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(HL & %upd & Hcond & Hrcond & HT)".
+ iApply (logical_step_wand with "Hl2").
+ iIntros "!> (Hl2 & HR)".
+ iDestruct "HT" as "(%ty3 & %Heqt & HT)".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; first apply Heqt.
+ iPoseProof (full_eqltype_use F with "CTX HE HL") as "(Hincl & HL)"; first done; first apply Heqt.
+ iMod ("Hincl" with "Hl2") as "Hl2".
+ iMod ("HT" with "[//] [//] [//] CTX HE HL [//] Hl2") as "Hread".
+ iDestruct "Hread" as (q v rt2 ty2' r2) "(% & % & Hl2 & Hv & Hcl)".
+ iModIntro. iExists v, q, _, _, _. iSplitR; first done. iSplitR; first done.
+ iFrame "Hl2 Hv".
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl" (st) "Hl2 Hv".
+ iMod ("Hcl" $! st with "Hl2 Hv") as (L3 rt4 ty4 r4) "(Hmv & HL & Hcl)".
+ iDestruct "Hcl" as "(%rt' & %lt' & %r' & %res & Hl2 & %Hsteq & Hx & Hfin)" => /=.
+ iPoseProof (typed_place_finish_elim with "Hfin") as "[Hweak | Hstrong]".
+ + (* do a weak update *)
+ iDestruct "Hweak" as "(%weak' & %Heq & -> & %Hw & Hfin)". subst rt'.
+ destruct upd as [ upd | ]; last done.
+ simpl in Hw. iDestruct "Hs" as "[_ Hs]". subst rt2'.
+ destruct res; last done.
+ (*rewrite (UIP_refl _ _ Heq).*)
+ iMod ("Hs" with "[] Hl2 [Hcond Hx Hrcond]") as "(Hl & Hcond'' & Htoks & HR')".
+ { iApply bor_kind_incl_refl. }
+ { iApply (typed_place_cond_trans with "[-Hx] Hx").
+ iApply (typed_place_cond_ltype_eq_ofty with "[-]"); last done.
+ iFrame.
+ }
+ cbn. iDestruct ("Hfin" with "Hl HR'") as "Hfin".
+ iMod ("Hfin" with "[] HE HL [$HR $Htoks]") as "(%L4 & HL & HT)"; first done.
+ iModIntro. iExists _, _, _, _. iFrame.
+ + (* also need to do a strong update due to the stratification *)
+ iDestruct "Hstrong" as "(%strong' & -> & %Hw & Hfin)".
+ iDestruct "Hs" as "[Hs _]".
+ iMod ("Hs" with "Hl2 [Hcond]") as "(Hl & Hcond'' & HR')".
+ { unshelve iSpecialize ("Heq" $! (Owned false) inhabitant); first apply _.
+ iPoseProof (ltype_eq_syn_type with "Heq") as "%Hst2".
+ destruct upd.
+ - iPoseProof (typed_place_cond_ty_syn_type_eq with "Hcond") as "%Hcond2".
+ rewrite Hsteq Hcond2 //.
+ - rewrite Hsteq -Hst2. done.
+ }
+ cbn. iDestruct ("Hfin" with "Hl HR'") as "Hfin".
+ iMod ("Hfin" with "[] HE HL HR") as "(%L4 & HL & HT)"; first done.
+ iModIntro. iExists _, _, _, _. iFrame.
+ Qed.
+
+ (* [type_read_end] instance that does a copy *)
+ Lemma type_read_ofty_copy E L {rt} π (T : typed_read_end_cont_t rt) b2 bmin br l (ty : type rt) r ot `{!Copyable ty}:
+ (⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜lctx_bor_kind_alive E L b2⌠∗ ∀ v, T L v rt ty r rt (◠ty) (PlaceIn r) (ResultWeak eq_refl))
+ ⊢ typed_read_end π E L l (◠ty) (#r) b2 bmin br ot T.
+ Proof.
+ iIntros "(%Hot & %Hal & Hs)" (F ???) "#CTX #HE HL".
+ destruct b2 as [ wl | | ]; simpl.
+ - iIntros "_ Hb".
+ iPoseProof (ofty_ltype_acc_owned with "Hb") as "(%ly & %Halg & %Hly & Hsc & Hlb & >(%v & Hl & #Hv & Hcl))"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ specialize (ty_op_type_stable Hot) as Halg''.
+ assert (ly = ot_layout ot) as ->. { by eapply syn_type_has_layout_inj. }
+ iModIntro. iExists _, _, rt, _, _.
+ iFrame "Hl Hv".
+ iSplitR; first done. iSplitR; first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl %st Hl _". iMod ("Hcl" with "Hl [//] Hsc Hv") as "Hl".
+ iModIntro. iExists L, rt, ty, r.
+ iPoseProof (ty_memcast_compat with "Hv") as "Ha"; first done. iFrame "Ha HL".
+ (* weak update *)
+ iExists _, _, _, (ResultWeak eq_refl). iFrame.
+ iR. iSplitR. { iApply typed_place_cond_refl. done. }
+ iApply "Hs".
+ - iIntros "Hincl0 #Hl".
+ simpl in Hal.
+ iPoseProof (ofty_ltype_acc_shared with "Hl") as "(%ly & %Halg & %Hly & Hlb & >Hl')"; first done.
+
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iMod (lctx_lft_alive_tok_noend κ with "HE HL") as (q') "(Htok & HL & Hclose)"; [solve_ndisj | done | ].
+ iMod (copy_shr_acc _ _ _ (↑shrN) with "CTX Hl' [] Htok") as "(>%Hly' & (%q'' & Hna & (%v & >Hll & #Hv) & Hclose_l))";
+ [solve_ndisj | solve_ndisj | | | ].
+ { admit. }
+ { admit. (* TODO: thread that stuff through everywhere *) }
+ iDestruct (ty_own_val_has_layout with "Hv") as "#>%Hlyv"; first done.
+ iModIntro. iExists _, _, rt, _, _. iFrame "Hll Hv".
+ assert (ly = ot_layout ot) as ->.
+ { specialize (ty_op_type_stable Hot) as ?. eapply syn_type_has_layout_inj; done. }
+ iSplitR; first done. iSplitR; first done.
+ iApply logical_step_intro. iIntros (st) "Hll Hv'".
+ iMod ("Hclose_l" with "Hna [Hv Hll]") as "[Hna Htok]".
+ { eauto with iFrame. }
+ iMod ("Hclose" with "Htok HL") as "HL".
+ iPoseProof ("HL_cl" with "HL") as "HL".
+ iModIntro. iExists L, rt, ty, r.
+ iPoseProof (ty_memcast_compat with "Hv'") as "Hid"; first done. simpl. iFrame.
+ iExists _, _, _, (ResultWeak eq_refl). iFrame "Hl".
+ iR. iSplitR; last done. iSplitR; last iApply typed_place_cond_rfn_refl.
+ iApply typed_place_cond_ty_refl_ofty.
+ - iIntros "Hincl0 Hl".
+ simpl in Hal.
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iMod (fupd_mask_subseteq lftE) as "HF_cl"; first done.
+ iMod (Hal with "HE HL") as (q') "(Htok & HL_cl2)"; [solve_ndisj | ].
+ iPoseProof (ofty_ltype_acc_uniq with "CTX Htok HL_cl2 Hl") as "(%ly & %Halg & %Hly & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iMod "HF_cl" as "_".
+ assert (ly = ot_layout ot) as ->.
+ { specialize (ty_op_type_stable Hot) as ?. eapply syn_type_has_layout_inj; done. }
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ iModIntro. iExists _, _, _, _, _. iFrame.
+ iSplitR; first done. iSplitR; first done.
+ iApply logical_step_mask_mono; last iApply (logical_step_wand with "Hcl"); first done.
+ iIntros "[Hcl _]".
+ iIntros (st) "Hl #Hv".
+ iMod (fupd_mask_mono with "(Hcl Hl Hv)") as "(Hl & HL)"; first done.
+ iPoseProof ("HL_cl" with "HL") as "HL".
+ iPoseProof (ty_memcast_compat with "Hv") as "Hid"; first done. simpl.
+ iModIntro. iExists L, rt, ty, r. iFrame "Hid HL".
+ iExists _, _, _, (ResultWeak eq_refl). iFrame.
+ iR. iSplitR; last done. iSplitR; last iApply typed_place_cond_rfn_refl.
+ iApply typed_place_cond_ty_refl_ofty.
+ Admitted.
+ Global Instance type_read_ofty_copy_inst E L {rt} π b2 bmin br l (ty : type rt) r ot `{!Copyable ty} :
+ TypedReadEnd π E L l (◠ty)%I (PlaceIn r) b2 bmin br ot | 10 :=
+ λ T, i2p (type_read_ofty_copy E L π T b2 bmin br l ty r ot).
+
+ (*
+ For more generality, maybe have LtypeReadAs lty (λ ty r, ...)
+ that gives us an accessor as a type?
+ => this should work fine.
+ - T ty .. (Shared κ) -∗ LtypeReadAs (ShrBlocked ty) T
+ - T ty .. k -∗ LtypeReadAs (◠ty) T
+ -
+ How does that work for moves? Well, we cannot move if it isn't an OfTy.
+ so there we should really cast first.
+ Note here: we should only trigger the copy instance if we can LtypeReadAs as something that is copy.
+ So we should really make that a TC and make it a precondition, similar to SimplifyHyp etc.
+
+ And similar for LtypeWriteAs lty (λ ty r, ...)?
+ well, there it is more difficult, because it even needs to hold if there are Blocked things below.
+ I don't think we can nicely solve that part.
+ *)
+
+ (** NOTE instance for moving is defined in value.v *)
+
+ (** Reading products: read each of the components in sequence *)
+ (* TODO check if this is the right thing to do.
+ Lemma type_read_prod E L π {rt1 rt2} `{ghost_varG Σ rt1} `{ghost_varG Σ rt2} `{ghost_varG Σ ((place_rfn rt1) * (place_rfn rt2))} b2 bmin l (lt1 : lty rt1) (lt2: lty rt2) r1 r2 sl ot
+ (T : val → ∀ rt', ghost_varG Σ rt' → lty rt' → place_rfn rt' → type (place_rfn rt1 * place_rfn rt2)%type → (place_rfn rt1 * place_rfn rt2) → iProp Σ) :
+ typed_read_end E L π (GetMemberLoc l sl "0") rt1 lt1 r1 b2 bmin ot (λ v1 rt1' _ lt1' r1' ty1 r1t,
+ typed_read_end E L π (GetMemberLoc l sl "1") rt2 lt2 r2 b2 bmin ot (λ v2 rt2' _ lt2' r2' ty2 r2t,
+ li_tactic (find_gvar_inst_goal (place_rfn rt1' * place_rfn rt2')) (λ _,
+ T (v1 ++ v2) (place_rfn rt1' * place_rfn rt2')%type _ (ProdLty lt1' lt2' sl) (PlaceIn (r1', r2')) (pair_t ty1 ty2 sl) (PlaceIn r1t, PlaceIn r2t)))) -∗
+ typed_read_end E L π l (place_rfn rt1 * place_rfn rt2) (ProdLty lt1 lt2 sl) (PlaceIn (r1, r2)) b2 bmin ot T.
+ Proof.
+ Admitted.
+ Global Instance type_read_prod_inst E L π {rt1 rt2} `{ghost_varG Σ rt1} `{ghost_varG Σ rt2} `{ghost_varG Σ ((place_rfn rt1) * (place_rfn rt2))} b2 bmin l (lt1 : lty rt1) (lt2: lty rt2) r1 r2 sl ot :
+ TypedReadEnd E L π l (ProdLty lt1 lt2 sl) (PlaceIn (r1, r2)) b2 bmin ot | 10 :=
+ λ T, i2p (type_read_prod E L π b2 bmin l lt1 lt2 r1 r2 sl ot T).
+
+ (** We can do copy reads from shr-blocked places *)
+ Lemma type_read_shr_blocked_copy E L π {rt} `{ghost_varG Σ rt} b2 bmin l (ty : type rt) r κ ot `{!Copyable ty} (T : val → ∀ rt', ghost_varG Σ rt' → lty rt' → place_rfn rt' → type rt → rt → iProp _) :
+ (⌜ty.(ty_has_op_type) ot⌠∗ ⌜lctx_lft_alive E L κ⌠∗ (∀ v, T v rt _ (ShrBlockedLty ty κ) (PlaceIn r) ty r)) -∗
+ typed_read_end E L π l rt (ShrBlockedLty ty κ) (PlaceIn r) b2 bmin ot T.
+ Proof.
+ Admitted.
+ Global Instance type_read_shr_blocked_copy_inst E L π {rt} `{ghost_varG Σ rt} b2 bmin l (ty : type rt) r κ ot `{!Copyable ty} :
+ TypedReadEnd E L π l (ShrBlockedLty ty κ) (PlaceIn r) b2 bmin ot | 10 :=
+ λ T, i2p (type_read_shr_blocked_copy E L π b2 bmin l ty r κ ot T).
+ *)
+
+
+
+ (* TODO: potentially lemmas for reading from mut-ref and box ltypes.
+ (this would be required for full generality, because shr_blocked can be below them)
+ *)
+
+ Lemma type_write E L T T' e ot v rt (ty : type rt) r π :
+ IntoPlaceCtx π E e T' →
+ T' L (λ L' K l, find_in_context (FindLoc l π) (λ '(existT rto (lt1, r1, b)),
+ typed_place π E L' l lt1 r1 b b K (λ (L1 : llctx) (κs : list lft) (l2 : loc) (b2 bmin : bor_kind) rti (lt2 : ltype rti) (ri2 : place_rfn rti) (strong : option $ strong_ctx rti) (weak : option $ weak_ctx rto rti),
+ (* unblock etc. TODO: this requirement is too strong. *)
+ stratify_ltype_unblock π E L1 StratRefoldOpened l2 lt2 ri2 b2 (λ L2 R rt3 lt3 ri3,
+ (* certify that this stratification is allowed, or otherwise commit to a strong update *)
+ prove_place_cond E L2 bmin lt2 lt3 (λ upd,
+ prove_place_rfn_cond (if upd is ResultWeak _ then true else false) bmin ri2 ri3 (
+ (* end writing *)
+ typed_write_end π E L2 ot v ty r b2 bmin (if strong is Some _ then AllowStrong else AllowWeak) l2 lt3 ri3 (λ L3 (rt3' : Type) (ty3 : type rt3') (r3 : rt3') upd2,
+ typed_place_finish π E L3 strong weak (access_result_meet upd upd2) R (llft_elt_toks κs) l b (◠ty3)%I (PlaceIn r3) T)))))))
+ ⊢ typed_write π E L e ot v ty r T.
+ Proof.
+ iIntros (HT') "HT'". iIntros (Φ F ???) "#CTX #HE HL HΦ".
+ iApply (HT' with "CTX HE HL HT'").
+ iIntros (L' K l) "HL". iDestruct 1 as ([rt1 ([ty1 r1] & ?)]) "[Hl HP]".
+ iApply ("HP" with "[//] [//] CTX HE HL [] Hl").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L'' κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hl2 Hs HT HL".
+ iApply ("HΦ"). iIntros "Hv".
+ iPoseProof ("HT" with "[//] [//] CTX HE HL Hl2") as "Hb".
+ iApply fupd_logical_step. iApply logical_step_fupd.
+ iMod "Hb" as "(%L2 & %R & %rt2' & %lt2' & %ri2 & HL & %Hst & Hl2 & HT)".
+ iModIntro. iApply (logical_step_wand with "Hl2").
+ iIntros "(Hl2 & HR)".
+ iMod ("HT" with "[//] CTX HE HL") as "(HL & %upd & Hcond & Hrcond & HT)".
+ iMod ("HT" with "[//] [//] [//] CTX HE HL [//] Hl2 Hv") as "Hwrite".
+ iDestruct "Hwrite" as "(% & Hl2 & Hcl)".
+ iModIntro. iFrame "Hl2". iSplitR; first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl Hl2".
+ iMod ("Hcl" with "Hl2") as "Hcl".
+ iDestruct "Hcl" as "(%L3 & %rt3 & %ty3 & %r3 & %res & HL & Hl2 & %Hsteq & Hx & Hfin)".
+ iPoseProof (typed_place_finish_elim with "Hfin") as "[Hweak | Hstrong]".
+ - (* weak *)
+ iDestruct "Hweak" as "(%weak' & %Heq & -> & %Hres & Hfin)".
+ iDestruct "Hs" as "[_ Hs]". subst rt3.
+ destruct upd as [ upd | ]; last done. subst rt2'.
+ iMod ("Hs" with "[] Hl2 [Hcond Hx Hrcond]") as "(Hl & Hcond'' & Htoks & HR')".
+ { iApply bor_kind_incl_refl. }
+ { destruct res; last done.
+ iApply (typed_place_cond_trans with "[$Hcond $Hrcond] Hx"). }
+ cbn. iPoseProof ("Hfin" with "Hl HR'") as "Hfin".
+ iMod ("Hfin" with "[//] HE HL [$HR $Htoks]") as "(%L4 & HL & HT)".
+ iModIntro. iExists L4. iFrame.
+ - (* strong *)
+ iDestruct "Hstrong" as "(%strong' & -> & %Hres & Hfin)".
+ iDestruct "Hs" as "[Hs _]".
+ iMod ("Hs" with "Hl2 [Hcond Hrcond]") as "(Hl & Hcond'' & HR')".
+ { destruct upd.
+ - iPoseProof (typed_place_cond_ty_syn_type_eq with "Hcond") as "%Hcond2".
+ simp_ltypes. rewrite Hcond2 //.
+ - simp_ltypes. rewrite Hsteq //. }
+ iPoseProof ("Hfin" with "Hl HR'") as "Hfin".
+ iMod ("Hfin" with "[//] HE HL HR") as "(%L4 & HL & HT)".
+ iModIntro. iExists _. iFrame.
+ Qed.
+
+ (* TODO: generalize to other places where we can overwrite, but which can't be folded to an ofty *)
+
+ (** Currently have [ty2], want to write [ty]. This allows updates of the refinement type (from rt to rt2).
+ This only works if the path is fully owned ([bmin = Owned _]).
+ We could in principle allow this also for Uniq paths by suspending the mutable reference's contract with [OpenedLtype], but currently we have decided against that. *)
+ (* TODO the syntype equality requirement currently is too strong: it does not allow us to go from UntypedSynType to "proper sy types".
+ more broadly, this is a symptom of our language not understanding about syntypes.
+ *)
+ Lemma type_write_ofty_strong E L {rt rt2} π (T : typed_write_end_cont_t rt2) l (ty : type rt) (ty2 : type rt2) r1 (r2 : rt2) v ot wl wl' :
+ (⌜ty.(ty_has_op_type) ot MCNone⌠∗ ⌜ty_syn_type ty = ty_syn_type ty2⌠∗
+ (ty2.(ty_ghost_drop) π r2 -∗ T L rt ty r1 ResultStrong))
+ ⊢ typed_write_end π E L ot v ty r1 (Owned wl) (Owned wl') AllowStrong l (◠ty2) (#r2) T.
+ Proof.
+ iIntros "(%Hot & %Hst_eq & HT)".
+ iIntros (F qL ??) "#CTX #HE HL _ Hl Hv".
+ iPoseProof (ofty_ltype_acc_owned with "Hl") as "(%ly & %Halg & %Hly & Hsc & Hlb & >(%v0 & Hl0 & Hv0 & Hcl))"; first done.
+
+ iDestruct (ty_own_val_has_layout with "Hv0") as "%Hlyv0"; first done.
+ iDestruct (ty_has_layout with "Hv") as "#(%ly' & % & %Hlyv)".
+ assert (ly' = ly) as ->. { eapply syn_type_has_layout_inj; first done. by rewrite Hst_eq. }
+ specialize (ty_op_type_stable Hot) as Halg'.
+ assert (ly = ot_layout ot) as ->. { by eapply syn_type_has_layout_inj. }
+ iModIntro. iSplitR; first done.
+ iSplitL "Hl0".
+ { iExists v0. iFrame. iSplitR; first done. done. }
+ iPoseProof (ty_own_ghost_drop _ _ _ _ F with "Hv0") as "Hgdrop"; first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hgdrop").
+ iApply logical_step_intro.
+ iIntros "Hgdrop Hcl Hl".
+ iPoseProof (ty_own_val_sidecond with "Hv") as "#Hsc'".
+ iMod ("Hcl" with "Hl [//] Hsc' Hv") as "Hl".
+ iExists _, rt, ty, r1, ResultStrong. iFrame.
+ iSplitR. { done. }
+ iR.
+ iApply ("HT" with "Hgdrop").
+ Qed.
+ Global Instance type_write_ofty_strong_inst E L {rt rt2} π l (ty : type rt) (ty2 : type rt2) (r1 : rt) (r2 : rt2) v ot wl wl' :
+ TypedWriteEnd π E L ot v ty r1 (Owned wl) (Owned wl') AllowStrong l (◠ty2)%I (PlaceIn r2) | 10 :=
+ λ T, i2p (type_write_ofty_strong E L π T l ty ty2 r1 r2 v ot wl wl').
+
+ (** This does not allow updates to the refinement type, rt stays the same. *)
+ (* TODO: also allow writes here if the place is not an ofty *)
+ (* Write v : r1 @ ty to l : #r2 @ â— ty2. We first need to show that ty is a subtype of ty2.
+ Afterwards, we obtain l : #r3 @ â— ty2 for some r3, as well as the result of ghost-dropping r2 @ ty2. *)
+ Lemma type_write_ofty_weak E L {rt} π (T : typed_write_end_cont_t rt) b2 bmin ac l (ty ty2 : type rt) r1 r2 v ot :
+ (∃ r3, owned_subtype π E L false r1 r3 ty ty2 (λ L2,
+ ⌜ty_syn_type ty = ty_syn_type ty2⌠∗ (* TODO: would be nice to remove this requirement *)
+ ⌜ty.(ty_has_op_type) ot MCNone⌠∗ ⌜lctx_bor_kind_alive E L2 b2⌠∗ ⌜bor_kind_writeable bmin⌠∗ (ty2.(ty_ghost_drop) π r2 -∗ T L2 rt ty2 r3 (ResultWeak eq_refl))))
+ ⊢ typed_write_end π E L ot v ty r1 b2 bmin ac l (◠ty2) (#r2) T.
+ Proof.
+ iIntros "(%r3 & HT)".
+ iIntros (F qL ??) "#CTX #HE HL #Hincl Hl Hv".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L2 & Hsub & HL & %Hst_eq & %Hot & %Hal & %Hwriteable & HT)".
+ iDestruct ("Hsub") as "(#%Hly_eq & _ & Hsub)".
+ iPoseProof ("Hsub" with "Hv") as "Hv".
+ destruct b2 as [ wl | | ]; simpl.
+ - iPoseProof (ofty_ltype_acc_owned with "Hl") as "(%ly & %Halg & %Hly & #Hsc & _ & >(%v0 & Hl & Hv0 & Hcl))"; first done.
+ iDestruct (ty_own_val_has_layout with "Hv0") as "%"; first done.
+ iDestruct (ty_has_layout with "Hv") as "(%ly'' & % & %)".
+ assert (ly'' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ specialize (ty_op_type_stable Hot) as ?.
+ assert (ly = ot_layout ot) as ->. { eapply syn_type_has_layout_inj; first done. by rewrite -Hst_eq. }
+ iModIntro. iSplitR; first done. iSplitL "Hl".
+ { iExists v0. iFrame. done. }
+ iPoseProof (ty_own_ghost_drop _ _ _ _ F with "Hv0") as "Hgdrop"; first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hgdrop").
+ iApply logical_step_intro. iIntros "Hgdrop Hcl Hl".
+ (*iPoseProof (ty_own_val_sidecond with "Hv") as "#Hsc'".*)
+ iMod ("Hcl" with "Hl [] [] Hv") as "Hl"; [done.. | ].
+ iModIntro.
+ iExists _, _, ty2, r3, (ResultWeak eq_refl).
+ iFrame.
+ iR.
+ iSplitR.
+ { iSplit; first iApply typed_place_cond_ty_refl_ofty.
+ destruct bmin; simpl; done. }
+ iApply ("HT" with "Hgdrop").
+ - (* we know that bmin is also Shared, so it can't be writeable *)
+ destruct bmin; done.
+ - (* we know that bmin is also Uniq, since it can't be shared *)
+ destruct bmin as [ | | κ' ?]; [done.. | ]. rewrite {1}/bor_kind_incl.
+ simpl in Hal.
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iMod (fupd_mask_subseteq lftE) as "HF_cl"; first done.
+ iMod (Hal with "HE HL") as "(%q & Htok & Htok_cl)"; first done.
+ iPoseProof (ofty_ltype_acc_uniq lftE with "CTX Htok Htok_cl Hl") as "(%ly & %Halg & %Hly & Hlb & >Hb)"; first done.
+ iMod "HF_cl" as "_".
+ iDestruct "Hb" as "(%v0 & Hl & Hv0 & Hcl)".
+ iDestruct (ty_own_val_has_layout with "Hv0") as "%"; first done.
+ iDestruct (ty_has_layout with "Hv") as "(%ly'' & % & %)".
+ assert (ly'' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ specialize (ty_op_type_stable Hot) as ?.
+ assert (ly = ot_layout ot) as ->. { eapply syn_type_has_layout_inj; first done. by rewrite -Hst_eq. }
+ iModIntro. iSplitR; first done. iSplitL "Hl".
+ { iExists v0. iFrame. done. }
+ iPoseProof (ty_own_ghost_drop _ _ _ _ F with "Hv0") as "Hgdrop"; first done.
+ iApply (logical_step_compose with "Hgdrop").
+ iApply (logical_step_mask_mono lftE); first done.
+ iApply (logical_step_compose with "Hcl").
+ iApply logical_step_intro. iIntros "[Hcl _] Hgdrop Hl".
+ iMod (fupd_mask_mono with "(Hcl Hl Hv)") as "(Hl & HL)"; [done.. | ].
+ iPoseProof ("HL_cl" with "HL") as "HL".
+ iModIntro.
+ iExists _, _, ty2, r3, (ResultWeak eq_refl). iFrame.
+ iR.
+ iSplitR.
+ { iSplit; first iApply typed_place_cond_ty_refl_ofty. done. }
+ iApply ("HT" with "Hgdrop").
+ Qed.
+ Global Instance type_write_ofty_weak_inst E L {rt} π b2 bmin br l ty ty2 (r1 r2 : rt) v ot :
+ TypedWriteEnd π E L ot v ty r1 b2 bmin br l (◠ty2)%I (PlaceIn r2) | 20 :=
+ λ T, i2p (type_write_ofty_weak E L π T b2 bmin br l ty ty2 r1 r2 v ot).
+
+ (* TODO move *)
+ (*
+ Fixpoint try_fold_lty {rt} (lt : lty rt) : option (type rt) :=
+ match lt with
+ | BlockedLty _ _ => None
+ | ShrBlockedLty _ _ => None
+ | OfTy ty => Some ty
+ | MutLty lt κ =>
+ ty ↠try_fold_lty lt;
+ Some (mut_ref ty κ)
+ | ShrLty lt κ =>
+ (* TODO *)
+ (*ty ↠try_fold_lty lt;*)
+ (*Some (shr_ref ty κ)*)
+ None
+ | BoxLty lt =>
+ (* TODO *)
+ (*ty ↠try_fold_lty lt;*)
+ (*Some (box ty)*)
+ None
+ | ProdLty lt1 lt2 sl =>
+ ty1 ↠try_fold_lty lt1;
+ ty2 ↠try_fold_lty lt2;
+ if decide (sl = pair_layout_spec ty1 ty2) then Some (pair_t ty1 ty2) else None
+ end.
+ Lemma try_fold_lty_correct {rt} (lt : lty rt) (ty : type rt) :
+ try_fold_lty lt = Some ty →
+ ⊢ ltype_eq lt (◠ty)%I.
+ Proof.
+ Abort.
+
+ (* The following lemmas are really somewhat awkward, because of the whole "pushing down" thing: we are really overwriting the MutLty(etc.) here, not its contents. But still, we need to replicate these lemmas that are really similar, because we can't phrase the ownership generically. *)
+
+ (* Basically for Uniq ownership. We need to take care that we are not disrupting the contract of the mutable reference that may be above it (in the b2=Uniq case). *)
+ Lemma type_write_mutlty E L {rt} π (T : ∀ rt3, type rt3 → rt3 → iProp Σ) b2 bmin l (ty : type (place_rfn rt * gname)) (lt2 : lty rt) r1 r2 v κ ot :
+ (* the core must be equivalent to some type, of which the type we are writing must be a subtype *)
+ ∃ ty2, ⌜try_fold_lty (ltype_core (MutLty lt2 κ)) = Some ty2⌠∗
+ (weak_subtype E L ty ty2 (⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜lctx_bor_kind_alive E L b2⌠∗ ⌜bor_kind_writeable bmin⌠∗ T _ ty2 r1)) -∗
+ typed_write_end π E L ot v _ ty r1 b2 bmin l _ (MutLty lt2 κ) (PlaceIn r2) T.
+ Proof.
+ Abort.
+ (* No restrictions if we fully own it *)
+ Lemma type_write_mutlty_strong E L {rt rt2} π (T : ∀ rt3, type rt3 → rt3 → iProp Σ) l (ty : type rt) (lt2 : lty rt2) r1 r2 v κ wl wl' ot :
+ ⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜ty_syn_type ty = PtrSynType⌠∗ T _ ty r1 -∗
+ typed_write_end π E L ot v _ ty r1 (Owned wl) (Owned wl') l _ (MutLty lt2 κ) (PlaceIn r2) T.
+ Proof.
+ Abort.
+
+ (* Same lemmas for box *)
+ Lemma type_write_boxlty E L {rt} π (T : ∀ rt3, type rt3 → rt3 → iProp Σ) b2 bmin l (ty : type (place_rfn rt)) (lt2 : lty rt) r1 r2 v ot :
+ (* the core must be equivalent to some type, of which the type we are writing must be a subtype *)
+ ∃ ty2, ⌜try_fold_lty (ltype_core (BoxLty lt2)) = Some ty2⌠∗
+ (weak_subtype E L ty ty2 (⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜lctx_bor_kind_alive E L b2⌠∗ ⌜bor_kind_writeable bmin⌠∗ T _ ty2 r1)) -∗
+ typed_write_end π E L ot v _ ty r1 b2 bmin l _ (BoxLty lt2) (PlaceIn r2) T.
+ Proof.
+ Abort.
+ (* No restrictions if we fully own it *)
+ Lemma type_write_boxlty_strong E L {rt rt2} π (T : ∀ rt3, type rt3 → rt3 → iProp Σ) l (ty : type rt) (lt2 : lty rt2) r1 r2 v wl wl' ot :
+ ⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜ty_syn_type ty = PtrSynType⌠∗ T _ ty r1 -∗
+ typed_write_end π E L ot v _ ty r1 (Owned wl) (Owned wl') l _ (BoxLty lt2) (PlaceIn r2) T.
+ Proof.
+ Abort.
+
+ (* Same for sharing. This works, again, because we are writing to the place the shared reference is stored in, not below the shared reference. *)
+ Lemma type_write_shrlty E L {rt} π (T : ∀ rt3, type rt3 → rt3 → iProp Σ) b2 bmin l (ty : type (place_rfn rt)) (lt2 : lty rt) r1 r2 v κ ot :
+ (* the core must be equivalent to some type, of which the type we are writing must be a subtype *)
+ ∃ ty2, ⌜try_fold_lty (ltype_core (ShrLty lt2 κ)) = Some ty2⌠∗
+ (weak_subtype E L ty ty2 (⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜lctx_bor_kind_alive E L b2⌠∗ ⌜bor_kind_writeable bmin⌠∗ T _ ty2 r1)) -∗
+ typed_write_end π E L ot v _ ty r1 b2 bmin l _ (ShrLty lt2 κ) (PlaceIn r2) T.
+ Proof.
+ Abort.
+ (* No restrictions if we fully own it *)
+ Lemma type_write_shrlty_strong E L {rt rt2} π (T : ∀ rt3, type rt3 → rt3 → iProp Σ) l (ty : type rt) (lt2 : lty rt2) r1 r2 v κ wl wl' ot :
+ ⌜ty.(ty_has_op_type) ot MCCopy⌠∗ ⌜ty_syn_type ty = PtrSynType⌠∗ T _ ty r1 -∗
+ typed_write_end π E L ot v _ ty r1 (Owned wl) (Owned wl') l _ (ShrLty lt2 κ) (PlaceIn r2) T.
+ Proof.
+ Abort.
+ *)
+
+ (* TODO: product typing rule.
+ This will be a bit more complicated, as we essentially need to require that directly below the product, nothing is blocked.
+ Of course, with nested products, this gets more complicated...
+ *)
+
+ Lemma type_addr_of_mut π E L (e : expr) (T : typed_addr_of_mut_cont_t) T' :
+ IntoPlaceCtx π E e T' →
+ T' L (λ L1 K l, find_in_context (FindLoc l π) (λ '(existT rto (lt1, r1, b)),
+ (* place *)
+ typed_place π E L1 l lt1 r1 b b K (λ L2 κs (l2 : loc) (b2 bmin : bor_kind) rti (lt2 : ltype rti) (ri2 : place_rfn rti) strong weak,
+ typed_addr_of_mut_end π E L2 l2 lt2 ri2 b2 bmin (λ L3 rtb tyb rb rt' lt' r',
+ typed_place_finish π E L3 strong weak ResultStrong True (llft_elt_toks κs) l b lt' r' (λ L4,
+ (* in case lt2 is already an AliasLtype, the simplify_hyp instance for it will make sure that we don't actually introduce that assignment into the context *)
+ l2 â—â‚—[Ï€, Owned false] ri2 @ lt2 -∗
+ T L4 l2 rtb tyb rb)))))
+ ⊢ typed_addr_of_mut π E L e T.
+ Proof.
+ iIntros (HT') "HT'". iIntros (Φ F ???) "#CTX #HE HL HΦ".
+ iApply (HT' with "CTX HE HL HT'").
+ iIntros (L1 K l) "HL". iDestruct 1 as ([rto [[lt1 r1] b]]) "(Hl & Hplace)" => /=.
+ iApply ("Hplace" with "[//] [//] CTX HE HL [] Hl").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L2 κs l2 b2 bmin rti ltyi ri strong weak) "#Hincl Hl2 Hs Hcont HL".
+ iApply "HΦ".
+ iApply logical_step_fupd.
+ iSpecialize ("Hcont" with "[//] [//] [//] CTX HE HL [//] Hl2").
+ iApply (logical_step_wand with "Hcont").
+ iDestruct 1 as (L3 rtb tyb rb rt' lt' r') "(Htyb & Hl2 & Hl2' & %Hst & HL & HT)".
+
+ rewrite /typed_place_finish. simpl.
+ (* strong update *) iDestruct "Hs" as "[Hs _]".
+ destruct strong as [ strong' | ]; last done.
+ iMod ("Hs" with "Hl2 []") as "(Hl & Hcond & HR')".
+ { done. }
+ simpl.
+ iDestruct ("HT" with "Hl HR'") as "HT".
+ iMod ("HT" with "[//] HE HL [//]") as "(%L4 & HL & HT)".
+ iModIntro.
+
+ iExists L4, _, tyb, rb. iFrame.
+ by iApply "HT".
+ Qed.
+ (* NOTE: instances for [typed_addr_of_mut_end] are in alias_ptr.v *)
+
+ Lemma type_borrow_mut E L T T' e κ π (orty : option rust_type) :
+ IntoPlaceCtx π E e T' →
+ T' L (λ L1 K l, find_in_context (FindLoc l π) (λ '(existT rto (lt1, r1, b)),
+ (* place *)
+ typed_place π E L1 l lt1 r1 b b K (λ L2 κs (l2 : loc) (b2 bmin : bor_kind) rti (lt2 : ltype rti) (ri2 : place_rfn rti) strong weak,
+ (* find the credit context to give the borrow-step a time receipt *)
+ find_in_context (FindCreditStore) (λ '(n, m),
+ (* stratify *)
+ stratify_ltype_unblock π E L2 StratRefoldFull l2 lt2 ri2 b2 (λ L3 R rt2' lt2' ri2',
+ (* certify that this stratification is allowed, or otherwise commit to a strong update *)
+ prove_place_cond E L3 bmin lt2 lt2' (λ upd,
+ prove_place_rfn_cond (if upd is ResultWeak _ then true else false) bmin ri2 ri2' (
+ (* needs to be a type *)
+ ∃ ty2 ri2'',
+ ⌜ri2' = #ri2''⌠∗
+ mut_eqltype E L3 lt2' (â— ty2) (
+ (* use the type annotation; but only if we are at an Owned place -- below mutable references (e.g. when reborrowing) our options for subtyping are much more limited.
+ TODO: we could conceivably still do something here, if we require the type transformation to be injective in a sense. *)
+ typed_option_map (option_combine orty (match bmin with Owned _ => Some () | _ => None end))
+ (λ '(rty, _) (T : sigT (λ rt, type rt * rt * access_result rt2' rt)%type → _),
+ find_in_context (FindNamedLfts) (λ M, named_lfts M -∗
+ li_tactic (interpret_rust_type_goal M rty) (λ '(existT rt3 ty3),
+ (* TODO it would be really nice to have a stronger form of subtyping here that also supports unfolding/folding of invariants *)
+ ∃ ri3, weak_subtype E L3 ri2'' ri3 ty2 ty3 (T (existT rt3 (ty3, ri3, ResultStrong)))
+ )))
+ (existT rt2' (ty2, ri2'', access_result_refl)) (λ '(existT rt4 (ty4, ri4, upd')),
+ (* finish borrow *)
+ typed_borrow_mut_end π E L3 κ l2 ty4 (#ri4) b2 bmin (λ (γ : gname) (lt5 : ltype rt4) (r5 : place_rfn rt4),
+ credit_store n m -∗
+ typed_place_finish π E L3 strong weak (access_result_meet upd upd') R (llft_elt_toks κs) l b
+ lt5 r5 (λ L4, T L4 (val_of_loc l2) γ rt4 ty4 ri4)))))))))))
+ ⊢ typed_borrow_mut π E L e κ orty T.
+ Proof.
+ iIntros (HT') "HT'". iIntros (Φ F ???) "#CTX #HE HL HΦ".
+ iApply (HT' with "CTX HE HL HT'").
+ iIntros (L1 K l) "HL". iDestruct 1 as ([rt1 ([ty1 r1] & ?)]) "[Hl HP]".
+ iApply ("HP" $! _ F with "[//] [//] CTX HE HL [] Hl").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L2 κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hl2 Hs HT HL2".
+ iDestruct "HT" as ([n m]) "(Hstore & HT)".
+ iPoseProof (credit_store_borrow_receipt with "Hstore") as "(Hat & Hstore)".
+ (* bring the place type in the right shape *)
+ iApply ("HΦ" with "Hat").
+ iPoseProof ("HT" with "[//] [//] CTX HE HL2 Hl2") as "Hb".
+ iApply fupd_logical_step. iApply logical_step_fupd.
+ iMod "Hb" as "(%L3 & %R & %rt' & %lt' & %r' & HL & %Hst & Hl2 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(HL & %upd & Hcond & Hrcond & HT)".
+ iDestruct "HT" as "(%ty2 & %ri2' & -> & HT)".
+ iDestruct "HT" as "(%Heq & HT)".
+ (*iMod ("HT" with "[//] CTX HE HL") as "(#Hincl_ty2 & HL & HT)".*)
+
+ iApply (logical_step_wand with "Hl2").
+ iIntros "!> (Hl2 & HR) !> Hcred Hat".
+ iPoseProof ("Hstore" with "Hat") as "Hstore".
+
+ (*iMod (ltype_incl_use with "Hincl_ty2 Hl2") as "Hl2"; first done.*)
+ iPoseProof (full_eqltype_use F with "CTX HE HL") as "[Hvs HL]"; [solve_ndisj | apply Heq | ].
+ iMod ("Hvs" with "Hl2") as "Hl2".
+ iPoseProof (ltype_own_has_layout with "Hl2") as "(%ly & %Halg & %Hly)".
+
+ (* eliminate the optional subtyping *)
+ iPoseProof (typed_option_map_elim_fupd _ _ _ (λ '(existT rt4 (ty4, r4, upd')),
+ ltype_incl b2 (#ri2') (#r4) (◠ty2) (◠ty4) ∗ typed_place_cond bmin (◠ty2) (◠ty4) (#ri2') (#r4) )%I with "HT [] [] HL") as ">(%ra & HL & Hincl & Hbor)"; first done.
+ { iIntros ([rst ?]) "%Heqo HL Ha".
+ rewrite /FindNamedLfts.
+ iDestruct "Ha" as "(%M & HM & HT)". iPoseProof ("HT" with "HM") as "Ha".
+ rewrite /interpret_rust_type_goal. iDestruct "Ha" as "(%rt3 & %ty3 & %r3 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & HT)".
+ iModIntro. iPoseProof "Hincl" as "(%Hsteq & _)".
+ iExists (existT _ (ty3, r3, ResultStrong)). iFrame "HL HT".
+ destruct bmin; [ | destruct orty; done.. ].
+ iSplitR; last done.
+ destruct b2; [ | done..]. iApply (type_ltype_incl_owned_in with "Hincl"). }
+ { iSplitR; first iApply ltype_incl_refl. iSplitL; first iApply typed_place_cond_ty_refl_ofty.
+ iApply typed_place_cond_rfn_refl. }
+ destruct ra as [rt4 [[ty4 r4] upd']].
+ iDestruct "Hincl" as "(#Hincl & #Hcond2)".
+
+ iMod (ltype_incl_use with "Hincl Hl2") as "Hl2"; first done.
+ iPoseProof (ltype_incl_syn_type with "Hincl") as "%Hst_eq".
+ iMod ("Hbor" $! F with "[//] [//] [//] CTX HE HL [//] Hl2 Hcred") as "Hbor".
+ iDestruct "Hbor" as (γ ly') "(Hobs & Hbor & Hsc & %Halg' & Hlb & Hblock & Hcond' & HL & HT)".
+ iSpecialize ("HT" with "Hstore").
+ assert (ly' = ly) as ->. { move: Hst_eq Halg' Halg. simp_ltypes => -> ??. by eapply syn_type_has_layout_inj. }
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; first apply Heq.
+
+ iPoseProof (typed_place_finish_elim with "HT") as "[Hweak | Hstrong]".
+ - (* weak update *)
+ iDestruct "Hweak" as "(%weak' & %Heq' & -> & %Hmeet & HT)".
+ iDestruct "Hs" as "[_ Hs]". subst rt4.
+ destruct upd; last done. destruct upd'; last done. simpl in Hmeet.
+ subst rt'.
+ (*rewrite (UIP_refl _ _ Heq1) in Hmeet. simpl in Hmeet. *)
+ iMod ("Hs" with "[] Hblock [Hcond Hcond' Hrcond]") as "(Hl & Hcond & Htoks & HR')".
+ { iApply bor_kind_incl_refl. }
+ { iApply (typed_place_cond_trans with "[$Hcond]"); first iApply typed_place_cond_rfn_refl.
+ iApply ltype_eq_place_cond_trans; first done.
+ (*iApply ltype_eq_place_cond_trans. *)
+ (* want: the place cond holds trivially, because we are Owned if they are different *)
+ iApply (typed_place_cond_trans with "[Hcond2 Hrcond] Hcond'").
+ iDestruct "Hcond2" as "(Hcond2 & Hcond2')".
+ iFrame "Hcond2". iApply (typed_place_cond_rfn_trans with "Hrcond Hcond2'"). }
+ cbn.
+ iDestruct ("HT" with "Hl HR'") as "HT".
+ iMod ("HT" with "[//] HE HL [$HR $Htoks]") as "(%L4 & HL & HT)".
+ iModIntro. iExists L4, _, _, _, γ, ly. iFrame.
+ iSplitR; done.
+ - (* strong update *) iDestruct "Hs" as "[Hs _]".
+ iDestruct "Hstrong" as "(%strong' & -> & %Hw & HT)".
+ iMod ("Hs" with "Hblock [Hcond Hcond']") as "(Hl & Hcond & HR')".
+ { iPoseProof (ltype_eq_syn_type inhabitant inhabitant with "Heq") as "%Heq2".
+ move: Hst_eq. simp_ltypes => Hst_eq.
+ simp_ltypes. iPureIntro. congruence. }
+ simpl.
+ iDestruct ("HT" with "Hl HR'") as "HT".
+ iMod ("HT" with "[//] HE HL HR") as "(%L4 & HL & HT)".
+ iModIntro. iExists L4, _, _, _, γ, ly. iFrame.
+ iSplitR; done.
+ Qed.
+
+ Lemma type_borrow_mut_end E L π κ l (rt : Type) (ty : type rt) (r : rt) b2 bmin T:
+ ⌜lctx_bor_kind_incl E L (Uniq κ inhabitant) bmin⌠∗
+ (* require this for the mutable reference case, to be able to access [b2] *)
+ ⌜lctx_lft_alive E L κ⌠∗
+ (∀ γ, T γ (BlockedLtype ty κ) (PlaceGhost γ))
+ ⊢ typed_borrow_mut_end π E L κ l ty (PlaceIn r) b2 bmin T.
+ Proof.
+ simpl. iIntros "(%Hincl & %Hal & HT)".
+ iIntros (F ???) "#CTX #HE HL #Hincl0 Hl Hcred".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iDestruct (Hincl with "HL HE") as "#Hincl". iPoseProof ("Hcl_L" with "HL") as "HL".
+ destruct b2 eqn:Hmin.
+ - (* owned *)
+ iMod (gvar_alloc r) as (γ) "[Hauth Hobs]".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcreda & (%r' & Hrfn & Hb))".
+ iDestruct "Hrfn" as "<-".
+ iDestruct "CTX" as "(LFT & TIME & LLFT)".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_m"; first done.
+ iMod (bor_create lftE κ (∃ r', gvar_auth γ r' ∗ |={lftE}=> l ↦: ty.(ty_own_val) π r') with "LFT [Hauth Hb]") as "[Hb Hinh]"; first solve_ndisj.
+ { iPoseProof (maybe_later_mono with "Hb") as "Hb". iNext. eauto with iFrame. }
+ iMod "Hcl_m" as "_".
+ iModIntro. iExists γ, ly. iFrame "Hobs Hb HL Hlb Hsc".
+ iSplitR; first done.
+ iSplitL "Hinh Hcred Hcreda".
+ { rewrite ltype_own_blocked_unfold /blocked_lty_own.
+ iExists ly. iSplitR; first done. iSplitR; first done. iSplitR; first done.
+ iFrame "Hlb Hcreda". iDestruct "Hcred" as "(Hcred1 & Hcred2 & Hcred)".
+ iIntros "Hdead". iMod ("Hinh" with "Hdead") as "Hinh".
+ iApply (lc_fupd_add_later with "Hcred1").
+ iNext. iFrame "Hcred2". done. }
+ iSplitR.
+ { iSplit.
+ + iApply ofty_blocked_place_cond_ty. iIntros (?). destruct bmin; simpl; done.
+ + destruct bmin; simpl; done.
+ }
+ iApply "HT".
+ - (* shared bor is contradictory *)
+ destruct bmin; done.
+ - (* mutable bor: reborrow *)
+ (* TODO maybe this will need additional credits (i.e. require a regeneration opportunity) *)
+ admit.
+ Admitted.
+ Global Instance type_borrow_mut_inst E L π κ l rt (ty : type rt) r b2 bmin :
+ TypedBorrowMutEnd π E L κ l ty (PlaceIn r) b2 bmin | 20 :=
+ λ T, i2p (type_borrow_mut_end E L π κ l rt ty r b2 bmin T).
+
+ Lemma type_borrow_shr E L T T' e κ orty π :
+ IntoPlaceCtx π E e T' →
+ T' L (λ L1 K l, find_in_context (FindLoc l π) (λ '(existT rto (lt1, r1, b)),
+ (* place *)
+ typed_place π E L1 l lt1 r1 b b K (λ L2 κs (l2 : loc) (b2 bmin : bor_kind) rti (lt2 : ltype rti) (ri2 : place_rfn rti) strong weak,
+ (* stratify *)
+ stratify_ltype_unblock π E L2 StratRefoldOpened l2 lt2 ri2 b2 (λ L3 R rt2' lt2' ri2',
+ (* certify that this stratification is allowed, or otherwise commit to a strong update *)
+ prove_place_cond E L3 bmin lt2 lt2' (λ upd,
+ prove_place_rfn_cond (if upd is ResultWeak _ then true else false) bmin ri2 ri2' (
+ (* needs to be a type *)
+ (* TODO: drop this assumption to support borrowing of partially shr-blocked places / find some other formulation *)
+ ∃ ty2 ri2'', ⌜ri2' = #ri2''⌠∗
+ mut_eqltype E L3 lt2' (â— ty2) (
+ typed_option_map (option_combine orty (match bmin with Owned _ => Some () | _ => None end))
+ (λ '(rty, _) (T : sigT (λ rt, type rt * rt * access_result rt2' rt)%type → _),
+ find_in_context (FindNamedLfts) (λ M, named_lfts M -∗
+ li_tactic (interpret_rust_type_goal M rty) (λ '(existT rt3 ty3),
+ ∃ ri3, weak_subtype E L3 ri2'' ri3 ty2 ty3 (T (existT rt3 (ty3, ri3, ResultStrong)))
+ )))
+ (existT rt2' (ty2, ri2'', access_result_refl)) (λ '(existT rt4 (ty4, ri4, upd')),
+ (* finish borrow *)
+ typed_borrow_shr_end π E L3 κ l2 ty4 ri4 b2 bmin (λ (lt5 : ltype rt4) (r5 : place_rfn rt4),
+ (* return toks *)
+ typed_place_finish π E L3 strong weak (access_result_meet upd upd') R (llft_elt_toks κs) l b lt5 r5
+ (λ L4, T L4 (val_of_loc l2) rt4 ty4 ri4))))))))))
+ ⊢ typed_borrow_shr π E L e κ orty T.
+ Proof.
+ iIntros (HT') "HT'". iIntros (Φ F ???) "#CTX #HE HL HΦ".
+ iApply (HT' with "CTX HE HL HT'").
+ iIntros (L1 K l) "HL". iDestruct 1 as ([rt1 ([ty1 r1] & ?)]) "[Hl HP]".
+ iApply ("HP" $! _ F with "[//] [//] CTX HE HL [] Hl").
+ { iApply bor_kind_incl_refl. }
+ iIntros (L2 κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hl2 Hs HT HL".
+ (* bring the place type in the right shape *)
+ iApply ("HΦ").
+ iPoseProof ("HT" with "[//] [//] CTX HE HL Hl2") as "Hb".
+ iApply fupd_logical_step.
+ iMod "Hb" as "(%L3 & %R & %rt2' & %lt2' & %ri2 & HL & %Hst & Hl2 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(HL & %upd & Hcond & Hrcond & HT)".
+ iDestruct "HT" as (ty2 ri2') "(-> & %Heq & HT)".
+ (* needs two logical steps: one for stratification and one for initiating sharing.
+ - that means: creating a reference will now be two skips.
+ - this shouldn't be very problematic. *)
+ iApply (logical_step_wand with "Hl2").
+ iIntros "!>(Hl2 & HR)".
+ iApply fupd_logical_step.
+ iPoseProof (full_eqltype_use F with "CTX HE HL") as "[Hvs HL]"; [solve_ndisj | apply Heq | ].
+ iMod ("Hvs" with "Hl2") as "Hl2".
+ iPoseProof (ltype_own_has_layout with "Hl2") as "(%ly & %Halg & %Hly)".
+
+
+ (* eliminate the optional subtyping *)
+ iPoseProof (typed_option_map_elim_fupd _ _ _ (λ '(existT rt4 (ty4, r4, upd')),
+ ltype_incl b2 (#ri2') (#r4) (◠ty2) (◠ty4) ∗ typed_place_cond bmin (◠ty2) (◠ty4) (#ri2') (#r4) )%I with "HT [] [] HL") as ">(%ra & HL & Hincl & Hbor)"; first done.
+ { iIntros ([rst ?]) "%Heqo HL Ha".
+ rewrite /FindNamedLfts.
+ iDestruct "Ha" as "(%M & HM & HT)". iPoseProof ("HT" with "HM") as "Ha".
+ rewrite /interpret_rust_type_goal. iDestruct "Ha" as "(%rt3 & %ty3 & %r3 & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & HT)".
+ iModIntro. iPoseProof "Hincl" as "(%Hsteq & _)".
+ iExists (existT _ (ty3, r3, ResultStrong)). iFrame "HL HT".
+ destruct bmin; [ | destruct orty; done.. ].
+ iSplitR; last done.
+ destruct b2; [ | done..]. iApply (type_ltype_incl_owned_in with "Hincl"). }
+ { iSplitR; first iApply ltype_incl_refl. iSplitL; first iApply typed_place_cond_ty_refl_ofty.
+ iApply typed_place_cond_rfn_refl. }
+ destruct ra as [rt4 [[ty4 r4] upd']].
+ iDestruct "Hincl" as "(#Hincl & #Hcond2)".
+
+ iMod (ltype_incl_use with "Hincl Hl2") as "Hl2"; first done.
+ iPoseProof (ltype_incl_syn_type with "Hincl") as "%Hst_eq".
+ iPoseProof ("Hbor" $! F with "[//] [//] [//] CTX HE HL [//] Hl2") as ">Hb".
+ iModIntro. iApply logical_step_fupd. iApply (logical_step_wand with "Hb").
+ iIntros "Ha !> Hcred".
+ iDestruct ("Ha" with "Hcred") as ">(%ly' & %lt' & Hshr & %Halg' & Hlb & Hsc & Hblocked & Hcond' & HL & HT)".
+ assert (ly' = ly) as ->. { move: Hst_eq Halg' Halg. simp_ltypes => -> ??. by eapply syn_type_has_layout_inj. }
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; first apply Heq.
+
+ iPoseProof (typed_place_finish_elim with "HT") as "[Hweak | Hstrong]".
+ - (* weak update *)
+ iDestruct "Hweak" as "(%weak' & %Heq' & -> & %Hmeet & HT)".
+ iDestruct "Hs" as "[_ Hs]". subst rt4.
+ destruct upd; last done. destruct upd'; last done. simpl in Hmeet.
+ (*rewrite (UIP_refl _ _ Heq1) in Hmeet. simpl in Hmeet. *)
+ iMod ("Hs" with "[] Hblocked [Hcond Hcond' Hrcond]") as "(Hl & Hcond & Htoks & HR')".
+ { iApply bor_kind_incl_refl. }
+ { iApply (typed_place_cond_trans with "[$Hcond $Hrcond]").
+ iApply ltype_eq_place_cond_trans; first done.
+ (*iApply ltype_eq_place_cond_trans. *)
+ (* want: the place cond holds trivially, because we are Owned if they are different *)
+ iApply (typed_place_cond_trans with "[Hcond2] Hcond'").
+ done. }
+ cbn.
+ iDestruct ("HT" with "Hl HR'") as "HT".
+ iMod ("HT" with "[//] HE HL [$HR $Htoks]") as "(%L4 & HL & HT)".
+ iModIntro. iExists L4, _, _, _, ly. iFrame.
+ iSplitR; done.
+ - (* strong update *) iDestruct "Hs" as "[Hs _]".
+ iPoseProof (typed_place_cond_syn_type_eq with "Hcond'") as "%Heq'".
+ iDestruct "Hstrong" as "(%strong' & -> & %Hw & HT)".
+ iMod ("Hs" with "Hblocked [Hcond Hcond']") as "(Hl & Hcond & HR')".
+ { iPoseProof (ltype_eq_syn_type inhabitant inhabitant with "Heq") as "%Heq2".
+ move: Hst_eq. simp_ltypes => Hst_eq.
+ simp_ltypes. iPureIntro. simp_ltypes. congruence. }
+ simpl.
+ iDestruct ("HT" with "Hl HR'") as "HT".
+ iMod ("HT" with "[//] HE HL HR") as "(%L4 & HL & HT)".
+ iModIntro. iExists L4, _, _, _, ly. iFrame.
+ iSplitR; done.
+ Qed.
+
+ Lemma type_borrow_shr_end_owned E L π κ l {rt : Type} (ty : type rt) (r : rt) bmin wl T:
+ ⌜lctx_bor_kind_incl E L (Uniq κ inhabitant) bmin⌠∗
+ ⌜lctx_lft_alive E L κ⌠∗
+ ⌜Forall (lctx_lft_alive E L) ty.(ty_lfts)⌠∗
+ (T (ShrBlockedLtype ty κ) (PlaceIn r))
+ ⊢ typed_borrow_shr_end π E L κ l ty r (Owned wl) bmin T.
+ Proof.
+ simpl. iIntros "(%Hincl & %Hal & %Hal' & HT)".
+ iIntros (F ???) "#[LFT TIME] #HE HL #Hincl0 Hl".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iDestruct (Hincl with "HL HE") as "#Hincl".
+ iMod (lctx_lft_alive_tok_noend (κ ⊓ (lft_intersect_list ty.(ty_lfts))) with "HE HL") as "Ha"; first done.
+ { eapply lctx_lft_alive_intersect; first done. by eapply lctx_lft_alive_intersect_list. }
+ iDestruct "Ha" as "(%q' & Htok & HL & Hcl_L')".
+ (* owned *)
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcred & %r' & <- & Hl)".
+ iMod (maybe_use_credit with "Hcred Hl") as "(Hcred & Hat & (%v & Hl & Hv))"; first done.
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (bor_create lftE κ (∃ v, l ↦ v ∗ v â—áµ¥{Ï€} r @ ty)%I with "LFT [Hv Hl]") as "(Hb & Hinh)"; first done.
+ { eauto with iFrame. }
+ iMod "Hcl_F" as "_".
+ iPoseProof (ty_share _ F with "[$LFT $TIME] Htok [//] [//] Hlb Hb") as "Hshr"; first done.
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hshr").
+ iApply (logical_step_intro_maybe with "Hat").
+ iModIntro. iIntros "Hcred' !> (#Hshr & Htok) !> Hcred1".
+ iMod ("Hcl_L'" with "Htok HL") as "HL".
+ iPoseProof ("Hcl_L" with "HL") as "HL".
+ iExists ly, (ShrBlockedLtype ty κ). iFrame "Hshr Hlb Hsc HL". iSplitR; first done.
+ iSplitL "Hcred' Hinh Hcred1".
+ { iModIntro. rewrite ltype_own_shrblocked_unfold /shr_blocked_lty_own.
+ iExists ly. iFrame "Hlb Hsc". iSplitR; first done. iSplitR; first done.
+ iExists r. iSplitR; first done. iFrame "Hshr Hcred'".
+ iIntros "Hdead". iMod ("Hinh" with "Hdead"). iApply (lc_fupd_add_later with "Hcred1").
+ iNext. eauto with iFrame. }
+ iModIntro.
+ iSplitR.
+ { destruct bmin; simpl; [done | done | ].
+ iSplit; last done.
+ iExists eq_refl. cbn.
+ simp_ltypes. iSplitR. { iIntros (??). iApply ltype_eq_refl. }
+ iApply imp_unblockable_shorten'; first done.
+ iApply shr_blocked_imp_unblockable.
+ }
+ iApply "HT".
+ Qed.
+ Global Instance type_borrow_shr_owned_inst E L π κ l rt (ty : type rt) r wl bmin :
+ TypedBorrowShrEnd π E L κ l ty r (Owned wl) bmin | 20 :=
+ λ T, i2p (type_borrow_shr_end_owned E L π κ l ty r bmin wl T).
+
+ Lemma type_borrow_shr_end_uniq E L π κ l {rt : Type} (ty : type rt) (r : rt) bmin κ' γ T:
+ ⌜lctx_bor_kind_incl E L (Uniq κ inhabitant) bmin⌠∗
+ ⌜lctx_lft_alive E L κ⌠∗
+ ⌜Forall (lctx_lft_alive E L) ty.(ty_lfts)⌠∗
+ (T (ShrBlockedLtype ty κ) (PlaceIn r))
+ ⊢ typed_borrow_shr_end π E L κ l ty r (Uniq κ' γ) bmin T.
+ Proof.
+ (*
+ simpl. iIntros "(%Hincl & %Hal & %Hal' & HT)".
+ iIntros (F ???) "#[LFT TIME] #HE HL #Hincl0 Hl".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iDestruct (Hincl with "HL HE") as "#Hincl".
+ iMod (lctx_lft_alive_tok_noend (κ ⊓ (lft_intersect_list ty.(ty_lfts))) with "HE HL") as "Ha"; first done.
+ { eapply lctx_lft_alive_intersect; first done. by eapply lctx_lft_alive_intersect_list. }
+ iDestruct "Ha" as "(%q' & Htok & HL & Hcl_L')".
+ (* owned *)
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & #Hsc & #Hlb & Hcred & %r' & <- & Hl)".
+ iMod (maybe_use_credit with "Hcred Hl") as "(Hcred & Hat & (%v & Hl & Hv))"; first done.
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (bor_create lftE κ (∃ v, l ↦ v ∗ v â—áµ¥{Ï€} r @ ty)%I with "LFT [Hv Hl]") as "(Hb & Hinh)"; first done.
+ { eauto with iFrame. }
+ iMod "Hcl_F" as "_".
+ iPoseProof (ty_share _ F with "[$LFT $TIME] Htok [//] [//] Hlb Hb") as "Hshr"; first done.
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hshr").
+ iApply (logical_step_intro_maybe with "Hat").
+ iModIntro. iIntros "Hcred' !> (#Hshr & Htok) !> Hcred1".
+ iMod ("Hcl_L'" with "Htok HL") as "HL".
+ iPoseProof ("Hcl_L" with "HL") as "HL".
+ iExists ly, (ShrBlockedLtype ty κ). iFrame "Hshr Hlb Hsc HL". iSplitR; first done.
+ iSplitL "Hcred' Hinh Hcred1".
+ { iModIntro. rewrite ltype_own_shrblocked_unfold /shr_blocked_lty_own.
+ iExists ly. iFrame "Hlb Hsc". iSplitR; first done. iSplitR; first done.
+ iExists r. iSplitR; first done. iFrame "Hshr Hcred'".
+ iIntros "Hdead". iMod ("Hinh" with "Hdead"). iApply (lc_fupd_add_later with "Hcred1").
+ iNext. eauto with iFrame. }
+ iModIntro.
+ iSplitR.
+ { destruct bmin; simpl; [done | done | ].
+ iSplit; last done.
+ iExists eq_refl. cbn.
+ simp_ltypes. iSplitR. { iIntros (??). iApply ltype_eq_refl. }
+ iApply imp_unblockable_shorten'; first done.
+ iApply shr_blocked_imp_unblockable.
+ }
+ iApply "HT".
+ Qed.
+ *)
+ Admitted.
+ Global Instance type_borrow_shr_uniq_inst E L π κ l rt (ty : type rt) r κ' γ bmin :
+ TypedBorrowShrEnd π E L κ l ty r (Uniq κ' γ) bmin | 20 :=
+ λ T, i2p (type_borrow_shr_end_uniq E L π κ l ty r bmin κ' γ T).
+
+ Lemma type_borrow_shr_end_shared E L π κ l {rt : Type} (ty : type rt) (r : rt) κ' bmin T:
+ ⌜lctx_bor_kind_incl E L (Shared κ) bmin⌠∗
+ (T (â— ty) (PlaceIn r))
+ ⊢ typed_borrow_shr_end π E L κ l ty r (Shared κ') bmin T.
+ Proof.
+ simpl. iIntros "(%Hincl & HT)".
+ iIntros (F ???) "#[LFT TIME] #HE HL #Hincl0 #Hl".
+ iPoseProof (lctx_bor_kind_incl_acc with "HE HL") as "#Hincl"; first apply Hincl.
+ iModIntro. iApply logical_step_intro. iIntros "Hcred".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hsc & Hlb & %r' & <- & #Hl)".
+ iDestruct "Hl" as "-#Hl". iMod (fupd_mask_mono with "Hl") as "#Hl"; first done.
+ iExists ly, (â— ty)%I.
+ iAssert (κ ⊑ κ')%I as "Hinclκ".
+ { iApply (bor_kind_incl_trans with "Hincl Hincl0"). }
+ iPoseProof (ty_shr_mono with "Hinclκ Hl") as "$".
+ iR. iFrame "Hlb Hsc". iModIntro.
+ iSplitR. { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iR. iR. iFrame "∗ #". iExists _. iR. done. }
+ iFrame. iSplitL; first iApply typed_place_cond_ty_refl_ofty.
+ iApply typed_place_cond_rfn_refl.
+ Qed.
+ Global Instance type_borrow_shr_end_shared_inst E L π κ l rt (ty : type rt) r κ' bmin :
+ TypedBorrowShrEnd π E L κ l ty r (Shared κ') bmin | 20 :=
+ λ T, i2p (type_borrow_shr_end_shared E L π κ l ty r κ' bmin T).
+
+ (** statements *)
+ Lemma type_goto E L Ï€ b fn R s Ï :
+ fn.(rf_fn).(f_code) !! b = Some s →
+ typed_stmt Ï€ E L s fn R Ï
+ ⊢ typed_stmt Ï€ E L (Goto b) fn R Ï.
+ Proof.
+ iIntros (HQ) "Hs". iIntros "#LFT #HE HL". iApply wps_goto => //.
+ iModIntro. iIntros "Hcred". by iApply ("Hs" with "LFT HE HL").
+ Qed.
+
+ (** Goto a block if we have already proved it with a particular precondition [P]. *)
+ (* This is not in Lithium goal shape, but that's fine since it is only manually applied by automation. *)
+ Lemma type_goto_precond E L Ï€ P b fn R Ï :
+ (* TODO maybe we should also stratify? *)
+ typed_block Ï€ P b fn R Ï âˆ— prove_with_subtype E L false ProveDirect (P E L) (λ L' _ R, R -∗⌜L = L'⌠∗ True (* TODO maybe relax *))
+ ⊢ typed_stmt Ï€ E L (Goto b) fn R Ï.
+ Proof.
+ iIntros "(Hblock & Hsubt) #CTX #HE HL".
+ iMod ("Hsubt" with "[] [] CTX HE HL") as "(%L' & % & %R2 & >(HP & HR2) & HL & HT)"; [done.. | ].
+ iDestruct ("HT" with "HR2") as "(<- & _)".
+ by iApply ("Hblock" with "CTX HE HL").
+ Qed.
+
+ Lemma typed_block_rec Ï€ fn R P b Ï s :
+ fn.(rf_fn).(f_code) !! b = Some s →
+ (â–¡ (∀ E L, (â–¡ typed_block Ï€ P b fn R Ï) -∗ P E L -∗ typed_stmt Ï€ E L s fn R Ï))
+ ⊢ typed_block Ï€ P b fn R Ï.
+ Proof.
+ iIntros (Hs) "#Hb". iLöb as "IH".
+ iIntros (E L) "#CTX #HE HL HP".
+ iApply wps_goto => //=. iNext. iIntros "Hcred".
+ iApply ("Hb" with "IH HP CTX HE HL").
+ Qed.
+
+ (** current goal: Goto.
+ Instead of just jumping there, we can setup an invariant [P] on ownership and the lifetime contexts.
+ Then instead prove: wp of the block, but in the context we can persistently assume the WP of the goto with the same invariant already. *)
+ (* Note: these need to be manually applied. *)
+ Lemma typed_goto_acc E L Ï€ fn R P b Ï s :
+ fn.(rf_fn).(f_code) !! b = Some s →
+ (* TODO maybe also stratify? *)
+ prove_with_subtype E L false ProveDirect (P E L) (λ L' _ R2, R2 -∗
+ ⌜L' = L⌠∗ (* TODO maybe relax if we have a separate condition on lifetime contexts *)
+ â–¡ (∀ E L, (â–¡ typed_block Ï€ P b fn R Ï) -∗ P E L -∗ typed_stmt Ï€ E L s fn R Ï))
+ ⊢ typed_stmt Ï€ E L (Goto b) fn R Ï.
+ Proof.
+ iIntros (Hlook) "Hsubt". iIntros "#CTX #HE HL".
+ iMod ("Hsubt" with "[] [] CTX HE HL") as "(%L' & % & %R2 & >(Hinv &HR2) & HL & HT)"; [done.. | ].
+ iDestruct ("HT" with "HR2") as "(-> & Hrec)".
+ iApply (typed_block_rec with "Hrec CTX HE HL Hinv"); done.
+ Qed.
+
+ Lemma type_assert E L e s fn Ï€ R Ï :
+ typed_val_expr Ï€ E L e (λ L' v rt ty r, typed_assert Ï€ E L' v ty r s fn R Ï)
+ ⊢ typed_stmt Ï€ E L (assert{BoolOp}: e; s) fn R Ï.
+ Proof.
+ iIntros "He #CTX #HE HL". wps_bind.
+ iApply ("He" with "CTX HE HL"). iIntros (L' v rt ty r) "HL Hv Hs".
+ iDestruct ("Hs" with "CTX HE HL Hv") as (?) "[HL Hs]".
+ iApply wps_assert_bool; [done.. | ]. iIntros "!> Hcred". by iApply ("Hs" with "CTX HE HL").
+ Qed.
+
+ Lemma type_if E L Ï€ e s1 s2 fn R Ï:
+ typed_val_expr Ï€ E L e (λ L' v rt ty r, typed_if E L' v (v â—áµ¥{Ï€} r @ ty)
+ (typed_stmt Ï€ E L' s1 fn R Ï) (typed_stmt Ï€ E L' s2 fn R Ï))
+ ⊢ typed_stmt Ï€ E L (if{BoolOp}: e then s1 else s2) fn R Ï.
+ Proof.
+ iIntros "He #CTX #HE HL". wps_bind.
+ iApply ("He" with "CTX HE HL"). iIntros (L' v rt ty r) "HL Hv Hs".
+ iDestruct ("Hs" with "Hv") as "(%b & % & Hs)".
+ iApply wps_if_bool; [done|..]. iIntros "!> Hcred". by destruct b; iApply ("Hs" with "CTX HE HL").
+ Qed.
+
+ Lemma type_switch E L Ï€ it e m ss def fn R Ï:
+ typed_val_expr Ï€ E L e (λ L' v rt ty r, typed_switch Ï€ E L' v rt ty r it m ss def fn R Ï)
+ ⊢ typed_stmt Ï€ E L (Switch it e m ss def) fn R Ï.
+ Proof.
+ iIntros "He #CTX #HE HL".
+ have -> : (Switch it e m ss def) = (W.to_stmt (W.Switch it (W.Expr e) m (W.Stmt <$> ss) (W.Stmt def)))
+ by rewrite /W.to_stmt/= -!list_fmap_compose list_fmap_id.
+ iApply tac_wps_bind; first done.
+ rewrite /W.to_expr /W.to_stmt /= -list_fmap_compose list_fmap_id.
+
+ iApply ("He" with "CTX HE HL"). iIntros (L' v rt ty r) "HL Hv Hs".
+ iDestruct ("Hs" with "Hv") as (z Hn) "Hs".
+ iAssert (⌜∀ i : nat, m !! z = Some i → is_Some (ss !! i)âŒ%I) as %?. {
+ iIntros (i ->). iDestruct "Hs" as (s ->) "_"; by eauto.
+ }
+ iApply wps_switch; [done|done|..]. iIntros "!> Hcred".
+ destruct (m !! z) => /=.
+ - iDestruct "Hs" as (s ->) "Hs". by iApply ("Hs" with "CTX HE HL").
+ - by iApply ("Hs" with "CTX HE HL").
+ Qed.
+
+ Lemma type_exprs E L s e fn R Ï€ Ï :
+ (typed_val_expr Ï€ E L e (λ L' v rt ty r, v â—áµ¥{Ï€} r @ ty -∗ typed_stmt Ï€ E L' s fn R Ï))
+ ⊢ typed_stmt Ï€ E L (ExprS e s) fn R Ï.
+ Proof.
+ iIntros "Hs #CTX #HE HL". wps_bind.
+ iApply ("Hs" with "CTX HE HL"). iIntros (L' v rt ty r) "HL Hv Hs".
+ iApply wps_exprs. iApply step_fupd_intro => //. iIntros "!> Hcred".
+ by iApply ("Hs" with "Hv CTX HE HL").
+ Qed.
+
+ Lemma type_skips E L s fn R Ï€ Ï :
+ (|={⊤}[∅]â–·=> (£1 -∗ typed_stmt Ï€ E L s fn R Ï)) ⊢ typed_stmt Ï€ E L (SkipS s) fn R Ï.
+ Proof.
+ iIntros "Hs #CTX #HE HL". iApply wps_skip. iApply (step_fupd_wand with "Hs"). iIntros "Hs Hcred".
+ by iApply ("Hs" with "Hcred CTX HE HL").
+ Qed.
+
+ Lemma type_skips' E L s fn R Ï€ Ï :
+ typed_stmt Ï€ E L s fn R Ï âŠ¢ typed_stmt Ï€ E L (SkipS s) fn R Ï.
+ Proof.
+ iIntros "Hs". iApply type_skips. iApply step_fupd_intro; first done.
+ iIntros "!> Hcred". done.
+ Qed.
+
+ Lemma typed_stmt_annot_skip {A} Ï€ E L (a : A) s fn R Ï :
+ typed_stmt Ï€ E L s fn R Ï âŠ¢ typed_stmt Ï€ E L (annot: a; s) fn R Ï.
+ Proof.
+ iIntros "Hs #CTX #HE HL".
+ iApply wps_annot. iApply step_fupd_intro; first done.
+ iIntros "!> _". iApply ("Hs" with "CTX HE HL").
+ Qed.
+
+ Lemma typed_expr_assert_type π E L n sty v {rt} (ty : type rt) r T :
+ (∃ lfts, named_lfts lfts ∗
+ (named_lfts lfts -∗ li_tactic (interpret_rust_type_goal lfts sty) (λ '(existT _ ty2),
+ ∃ r2, subsume_full E L false (v â—áµ¥{Ï€} r @ ty) (v â—áµ¥{Ï€} r2 @ ty2) (λ L2 R2, R2 -∗ T L2 v _ ty2 r2))))%I
+ ⊢ typed_annot_expr Ï€ E L n (AssertTypeAnnot sty) v (v â—áµ¥{Ï€} r @ ty) T.
+ Proof.
+ iIntros "(%lfts & Hnamed & HT)". iPoseProof ("HT" with "Hnamed") as "HT".
+ rewrite /interpret_rust_type_goal. iDestruct "HT" as "(%rt2 & %ty2 & %r2 & HT)".
+ iIntros "#CTX #HE HL Hv".
+ iApply step_fupdN_intro; first done. iNext.
+ iMod ("HT" with "[] [] CTX HE HL Hv") as "(%L2 & %R2 & >(Hv & HR2) & HL & HT)"; [done.. | ].
+ iModIntro. iExists _, _, _, _. iFrame. by iApply ("HT" with "HR2").
+ Qed.
+ Global Instance typed_expr_assert_type_inst π E L n sty v {rt} (ty : type rt) r :
+ TypedAnnotExpr Ï€ E L n (AssertTypeAnnot sty) v (v â—áµ¥{Ï€} r @ ty) :=
+ λ T, i2p (typed_expr_assert_type π E L n sty v ty r T).
+
+ Lemma typed_expr_get_lft_names π E L n tree v {rt} (ty : type rt) r T :
+ (∃ lfts, named_lfts lfts ∗
+ trigger_tc (GetLftNames ty lfts tree) (λ lfts',
+ (* simplify the updated map *)
+ li_tactic (simplify_lft_map_goal lfts') (λ lfts',
+ named_lfts lfts' -∗ T L v _ ty r)))
+ ⊢ typed_annot_expr Ï€ E L n (GetLftNamesAnnot tree) v (v â—áµ¥{Ï€} r @ ty) T.
+ Proof.
+ rewrite /simplify_lft_map_goal.
+ iIntros "(%lfts & Hnamed & %lfts' & %_ & %lfts'' & _ & HT)".
+ iPoseProof (named_lfts_update _ lfts'' with "Hnamed") as "Hnamed".
+ iIntros "? ? HL Hv". iApply step_fupdN_intro; first done. iNext.
+ iModIntro. iExists L, _, _, _. iFrame. by iApply "HT".
+ Qed.
+ Global Instance typed_expr_get_lft_names_inst π E L n tree v {rt} (ty : type rt) r :
+ TypedAnnotExpr Ï€ E L n (GetLftNamesAnnot tree) v (v â—áµ¥{Ï€} r @ ty) :=
+ λ T, i2p (typed_expr_get_lft_names π E L n tree v ty r T).
+
+ (** ** Handling of lifetime-related annotations *)
+ (** Endlft triggers *)
+ (** Instance for returning lifetime tokens [Inherit κ1 InheritDynIncl (llft_elt_toks κs)] *)
+ Lemma typed_on_endlft_trigger_dyn_incl E L κs T :
+ li_tactic (llctx_release_toks_goal L κs) (λ L', T L')
+ ⊢ typed_on_endlft_trigger E L InheritDynIncl (llft_elt_toks κs) T.
+ Proof.
+ rewrite /llctx_release_toks_goal.
+ iIntros "(%L' & %Hrel & Hs)" (F ?) "#HE HL Htoks".
+ iMod (llctx_return_elt_toks _ _ L' with "HL Htoks") as "HL"; first done.
+ eauto with iFrame.
+ Qed.
+ Global Instance typed_on_endlft_trigger_dyn_incl_inst E L κs : TypedOnEndlftTrigger E L InheritDynIncl (llft_elt_toks κs) :=
+ λ T, i2p (typed_on_endlft_trigger_dyn_incl E L κs T).
+
+ (** Instance for obtaining observations [Inherit κ1 (InheritGhost) ..] *)
+ Lemma typed_on_endlft_trigger_ghost E L (P : iProp Σ) T :
+ (P -∗ T L)
+ ⊢ typed_on_endlft_trigger E L InheritGhost P T.
+ Proof.
+ iIntros "HT" (F ?) "#HE HL HP".
+ iPoseProof ("HT" with "HP") as "HT".
+ eauto with iFrame.
+ Qed.
+ Global Instance typed_on_endlft_trigger_ghost_inst E L (P : iProp Σ) : TypedOnEndlftTrigger E L InheritGhost P :=
+ λ T, i2p (typed_on_endlft_trigger_ghost E L P T).
+
+ (** Instance for resolving Rel2 with another observation *)
+ (* TODO *)
+
+ (* Currently the thing with static is broken.
+ Maybe I should have MaybeInherit that simplifies to the direct proposition if it doesn't have a lifetime. *)
+
+ (* Point: I should still run the endlft hooks *)
+ (* TODO *)
+ Lemma introduce_with_hooks_maybe_inherit_none E L {K} (k : K) P T :
+ introduce_with_hooks E L P T
+ ⊢ introduce_with_hooks E L (MaybeInherit None k P) T.
+ Proof.
+ iIntros "HT" (??) "#HE HL Hinh".
+ rewrite /MaybeInherit.
+ iMod ("Hinh" with "[//]") as "HP".
+ iApply ("HT" with "[//] HE HL HP").
+ Qed.
+ Global Instance introduce_with_hooks_maybe_inherit_none_inst E L {K} (k : K) P :
+ IntroduceWithHooks E L (MaybeInherit None k P) := λ T, i2p (introduce_with_hooks_maybe_inherit_none E L k P T).
+
+ Lemma introduce_with_hooks_maybe_inherit_some E L {K} (k : K) κ P T :
+ introduce_with_hooks E L (Inherit κ k P) T
+ ⊢ introduce_with_hooks E L (MaybeInherit (Some κ) k P) T.
+ Proof.
+ iIntros "HT" (??) "#HE HL Hinh".
+ rewrite /MaybeInherit. iApply ("HT" with "[//] HE HL Hinh").
+ Qed.
+ Global Instance introduce_with_hooks_maybe_inherit_some_inst E L {K} (k : K) κ P :
+ IntroduceWithHooks E L (MaybeInherit (Some κ) k P) := λ T, i2p (introduce_with_hooks_maybe_inherit_some E L k κ P T).
+
+ Lemma introduce_with_hooks_inherit E L {K} (k : K) κ P T :
+ find_in_context (FindOptLftDead κ) (λ dead,
+ if dead
+ then typed_on_endlft_trigger E L k P T
+ else Inherit κ k P -∗ T L)
+ ⊢ introduce_with_hooks E L (Inherit κ k P) T.
+ Proof.
+ rewrite /FindOptLftDead/=. iIntros "(%dead & Hdead & HT)".
+ simpl in *. destruct dead.
+ - iIntros (??) "#HE HL Hinh".
+ rewrite /Inherit. iMod ("Hinh" with "[//] Hdead") as "HP".
+ iApply ("HT" with "[//] HE HL HP").
+ - iIntros (??) "#HE HL Hinh".
+ iExists L. iFrame. by iApply ("HT" with "Hinh").
+ Qed.
+ Global Instance introduce_with_hooks_inherit_inst E L {K} (k : K) κ P :
+ IntroduceWithHooks E L (Inherit κ k P) := λ T, i2p (introduce_with_hooks_inherit E L k κ P T).
+
+ (** StartLft *)
+ Lemma type_startlft E L (n : string) sup_lfts s fn R Ï€ Ï :
+ (∃ M, named_lfts M ∗ li_tactic (compute_map_lookups_nofail_goal M sup_lfts) (λ κs,
+ ∀ κ, named_lfts (named_lft_update n κ M) -∗
+ (* add a credit -- will be used by endlft *)
+ introduce_with_hooks E ((κ ⊑ₗ{0%nat} κs) :: L) (£ 1) (λ L2,
+ typed_stmt Ï€ E L2 s fn R Ï)))
+ ⊢ typed_stmt Ï€ E L (annot: (StartLftAnnot n sup_lfts); s) fn R Ï.
+ Proof.
+ rewrite /compute_map_lookups_nofail_goal.
+ iIntros "(%M & Hnamed & %κs & %Hlook & Hcont) #(LFT & TIME & LLCTX) #HE HL".
+ iApply wps_annot => /=.
+ iMod (llctx_startlft _ _ κs with "LFT LLCTX HL") as (κ) "HL"; [solve_ndisj.. | ].
+ iApply step_fupd_intro; first solve_ndisj. iNext. iIntros "Hcred".
+ iApply fupd_wps.
+ iMod ("Hcont" with "[Hnamed] [] HE HL Hcred") as "(%L2 & HL & HT)"; [ | done | ].
+ { iApply named_lfts_update. done. }
+ iApply ("HT" with "[$LFT $TIME $LLCTX] HE HL").
+ Qed.
+
+ (** Alias lifetimes: like startlft but without the atomic part *)
+ Lemma type_alias_lft E L (n : string) sup_lfts s fn R Ï€ Ï :
+ (∃ M, named_lfts M ∗ li_tactic (compute_map_lookups_nofail_goal M sup_lfts) (λ κs,
+ ∀ κ, named_lfts (named_lft_update n κ M) -∗ typed_stmt Ï€ E ((κ ≡ₗ κs) :: L) s fn R Ï))
+ ⊢ typed_stmt Ï€ E L (annot: (AliasLftAnnot n sup_lfts); s) fn R Ï.
+ Proof.
+ rewrite /compute_map_lookups_nofail_goal.
+ iIntros "(%M & Hnamed & %κs & %Hlook & Hcont) #(LFT & TIME & LLCTX) #HE HL".
+ iApply wps_annot => /=.
+ set (κ := lft_intersect_list κs).
+ iAssert (llctx_interp ((κ ≡ₗ κs) :: L))%I with "[HL]" as "HL".
+ { iFrame "HL". iSplit; iApply lft_incl_refl. }
+ iApply step_fupd_intro; first solve_ndisj. iNext. iIntros "Hcred".
+ iApply ("Hcont" $! κ with "[Hnamed] [$LFT $TIME $LLCTX] HE HL").
+ iApply named_lfts_update. done.
+ Qed.
+
+ (** EndLft *)
+ (* TODO: also make endlft apply to local aliases, endlft should just remove them, without triggering anything. *)
+ Inductive CtxFoldExtract : Type :=
+ | CtxFoldExtractAllInit (κ : lft)
+ | CtxFoldExtractAll (κ : lft).
+ Lemma type_endlft E L Ï€ (n : string) s fn R Ï :
+ (∃ M, named_lfts M ∗
+ (* if this lifetime does not exist anymore, this is a nop *)
+ li_tactic (compute_map_lookup_goal M n) (λ o,
+ match o with
+ | Some κ =>
+ (* find some credits *)
+ prove_with_subtype E L false ProveDirect (£1) (λ L1 _ R2,
+ (* find the new llft context *)
+ li_tactic (llctx_find_llft_goal L1 κ LlctxFindLftFull) (λ '(_, L2),
+ (* simplify the name map *)
+ li_tactic (simplify_lft_map_goal (named_lft_delete n M)) (λ M',
+ (named_lfts M' -∗ (□ [†κ]) -∗
+ (* extract observations from now-dead mutable references *)
+ typed_pre_context_fold π E L2 (CtxFoldExtractAllInit κ) (λ L3,
+ (* give back credits *)
+ introduce_with_hooks E L3 (R2 ∗ £1 ∗ atime 1) (λ L4,
+ (* run endlft triggers *)
+ typed_on_endlft_pre π E L4 κ (λ L5,
+ typed_stmt Ï€ E L5 s fn R Ï)))))))
+ | None => named_lfts M -∗ typed_stmt Ï€ E L s fn R Ï
+ end))
+ ⊢ typed_stmt Ï€ E L (annot: (EndLftAnnot n); s) fn R Ï.
+ Proof.
+ iIntros "(%M & Hnamed & Hlook)".
+ unfold compute_map_lookup_goal.
+ iDestruct "Hlook" as (o) "(<- & HT)".
+ destruct (M !! n) as [κ | ]; first last.
+ { iIntros "#CTX #HE HL". iApply wps_annot.
+ iApply step_fupdN_intro; first done.
+ iIntros "!> _". iApply ("HT" with "Hnamed CTX HE HL"). }
+ unfold llctx_find_llft_goal, li_tactic.
+ iIntros "#CTX #HE HL".
+ iMod ("HT" with "[] [] CTX HE HL") as "(%L2 & % & %R2 & >(Hc & HR2) & HL & HT)"; [done.. | ].
+ iDestruct "HT" as "(%L' & % & %Hkill & Hs)".
+ unfold simplify_lft_map_goal. iDestruct "Hs" as "(%M' & _ & Hs)".
+ iPoseProof (llctx_end_llft ⊤ with "HL") as "Ha"; [done | done | apply Hkill | ].
+ iApply fupd_wps.
+ iMod ("Ha"). iApply (lc_fupd_add_later with "Hc"). iNext. iMod ("Ha") as "(#Hdead & HL)".
+
+ iPoseProof ("Hs" with "[Hnamed] Hdead") as "HT".
+ { by iApply named_lfts_update. }
+ iPoseProof ("HT" $! ⊤ with "[] [] CTX HE HL") as "Hstep"; [done.. | ].
+ rewrite /logical_step.
+ iMod ("Hstep") as "(%k & Hat' & Hk)".
+ iMod (persistent_time_receipt_0)as "Hp".
+ iApply (wps_annot_credits with "[] Hat' Hp").
+ { iDestruct "CTX" as "(_ & $ & _)". }
+ iModIntro. iNext. iIntros "(Hc1 & Hc) Hat'". rewrite Nat.add_0_r.
+ iEval (rewrite additive_time_receipt_succ) in "Hat'".
+ iDestruct "Hat'" as "(Hat1 & Hat)".
+ iMod ("Hk" with "Hc Hat") as "(%L5 & HL & HT)".
+
+ iMod ("HT" with "[] HE HL [$HR2 $Hc1 $Hat1]") as "(%L6 & HL & HT)"; first done.
+ iMod ("HT" with "[] HE HL Hdead") as "(%L7 & HL & HT)".
+ { done. }
+ iApply ("HT" with "CTX HE HL").
+ Qed.
+
+ (** Dynamic inclusion *)
+ Lemma type_dyn_include_lft Ï€ E L n1 n2 s fn R Ï :
+ (∃ M, named_lfts M ∗
+ li_tactic (compute_map_lookup_nofail_goal M n1) (λ κ1,
+ li_tactic (compute_map_lookup_nofail_goal M n2) (λ κ2,
+ li_tactic (lctx_lft_alive_count_goal E L κ2) (λ '(κs, L'),
+ Inherit κ1 InheritDynIncl (llft_elt_toks κs) -∗
+ named_lfts M -∗
+ typed_stmt Ï€ ((κ1 ⊑ₑ κ2) :: E) L' s fn R Ï))))
+ ⊢ typed_stmt Ï€ E L (annot: DynIncludeLftAnnot n1 n2; s) fn R Ï.
+ Proof.
+ rewrite /compute_map_lookup_nofail_goal.
+ iIntros "(%M & Hnamed & %κ1 & %Hlook1 & %κ2 & %Hlook2 & Hs)".
+ unfold lctx_lft_alive_count_goal.
+ iDestruct "Hs" as "(%κs & %L' & %Hal & Hs)".
+ iIntros "#(LFT & TIME & LCTX) #HE HL".
+ iMod (lctx_include_lft_sem with "LFT HE HL") as "(HL & #Hincl & Hinh)"; [done.. | ].
+ iSpecialize ("Hs" with "Hinh").
+ iApply wps_annot. iApply step_fupdN_intro; first done.
+ iIntros "!> _".
+ iApply ("Hs" with "Hnamed [$] [] HL").
+ iFrame "HE Hincl".
+ Qed.
+
+ (** ExtendLft *)
+ Lemma type_extendlft E L Ï€ (n : string) s fn R Ï :
+ (∃ M, named_lfts M ∗
+ li_tactic (compute_map_lookup_nofail_goal M n) (λ κ,
+ li_tactic (llctx_find_llft_goal L κ LlctxFindLftOwned) (λ '(κs, L'),
+ (named_lfts M -∗ typed_stmt Ï€ E ((κ ≡ₗ κs) :: L') s fn R Ï))))
+ ⊢ typed_stmt Ï€ E L (annot: (EndLftAnnot n); s) fn R Ï.
+ Proof.
+ rewrite /compute_map_lookup_nofail_goal /llctx_find_llft_goal.
+ iIntros "(%M & Hnamed & %κ & _ & %L' & %κs & %Hfind & Hs)".
+ iIntros "#(LFT & TIME & LCTX) #HE HL".
+ iMod (llctx_extendlft_local_owned with "LFT HL") as "HL"; [done.. | ].
+ iApply wps_annot. iApply step_fupdN_intro; first done. iIntros "!> _".
+ iApply ("Hs" with "Hnamed [$] HE HL").
+ Qed.
+
+ (** CopyLftNameAnnot *)
+ Lemma type_copy_lft_name Ï€ E L n1 n2 s fn R Ï :
+ (∃ M, named_lfts M ∗
+ li_tactic (compute_map_lookup_nofail_goal M n2) (λ κ2,
+ li_tactic (simplify_lft_map_goal (named_lft_update n1 κ2 (named_lft_delete n1 M))) (λ M',
+ named_lfts M' -∗ typed_stmt Ï€ E L s fn R Ï)))
+ ⊢ typed_stmt Ï€ E L (annot: CopyLftNameAnnot n1 n2; s) fn R Ï.
+ Proof.
+ rewrite /compute_map_lookup_nofail_goal.
+ iIntros "(%M & Hnamed & %κ2 & _ & Hs) #CTX #HE HL".
+ unfold simplify_lft_map_goal. iDestruct "Hs" as "(%M' & _ & Hs)".
+ iApply wps_annot. iApply step_fupdN_intro; first done.
+ iIntros "!> _". iApply ("Hs" with "Hnamed CTX HE HL").
+ Qed.
+
+ (** We instantiate the context folding mechanism for unblocking. *)
+ Inductive CtxFoldStratify : Type :=
+ | CtxFoldStratifyAllInit
+ | CtxFoldStratifyAll.
+
+ (* Note: the following two lemmas introduce evars on application and are thus not suitable to be directly applied with Lithium.
+ They either need an Ltac oracle, or (this is what we do) use some evar magic below.
+ *)
+ Definition typed_context_fold_stratify_interp (π : thread_id) := λ '(ctx, R), (type_ctx_interp π ctx ∗ R)%I.
+ Lemma typed_context_fold_step_stratify π E L l {rt} (lt : ltype rt) (r : place_rfn rt) (tctx : list loc) acc R T :
+ (* TODO: this needs a different stratification strategy *)
+ stratify_ltype_unblock π E L StratRefoldOpened l lt r (Owned false)
+ (λ L' R' rt' lt' r', typed_context_fold (typed_context_fold_stratify_interp π) π E L' (CtxFoldStratifyAll) tctx ((l, mk_bltype _ r' lt') :: acc, R' ∗ R) T)
+ ⊢ typed_context_fold_step (typed_context_fold_stratify_interp π) π E L (CtxFoldStratifyAll) l lt r tctx (acc, R) T.
+ Proof.
+ iIntros "Hstrat". iIntros (? ??) "#CTX #HE HL Hdel Hl".
+ iPoseProof ("Hstrat" $! F with "[//] [//] CTX HE HL Hl") as ">Hc".
+ iDestruct "Hc" as "(%L' & %R' & %rt' & %lt' & %r' & HL & %Hst & Hstep & Hcont)".
+ iApply ("Hcont" $! F with "[//] [//] CTX HE HL [Hstep Hdel]").
+ iApply (logical_step_compose with "Hstep").
+ iApply (logical_step_compose with "Hdel").
+ iApply logical_step_intro.
+ iIntros "(Hctx & HR) (Hl & HR')".
+ iFrame.
+ Qed.
+
+ Lemma typed_context_fold_stratify_init tctx π E L T :
+ typed_context_fold (typed_context_fold_stratify_interp π) π E L (CtxFoldStratifyAll) tctx ([], True%I) (λ L' m' acc, True ∗
+ typed_context_fold_end (typed_context_fold_stratify_interp π) π E L' acc T)
+ ⊢ typed_pre_context_fold π E L CtxFoldStratifyAllInit T.
+ Proof.
+ iIntros "Hf". iApply (typed_context_fold_init (typed_context_fold_stratify_interp π) ([], True%I) _ _ _ (CtxFoldStratifyAll)). iFrame.
+ rewrite /typed_context_fold_stratify_interp/type_ctx_interp; simpl; done.
+ Qed.
+
+ Lemma type_stratify_context_annot E L Ï€ s fn R Ï :
+ typed_pre_context_fold Ï€ E L CtxFoldStratifyAllInit (λ L', typed_stmt Ï€ E L' s fn R Ï)
+ ⊢ typed_stmt Ï€ E L (annot: (StratifyContextAnnot); s) fn R Ï.
+ Proof.
+ iIntros "HT".
+ iIntros "#CTX #HE HL".
+ iApply fupd_wps.
+ iPoseProof ("HT" $! ⊤ with "[//] [//] CTX HE HL") as "Hstep".
+ (* TODO need to unfold logical_step because we cannot eliminate one over a statement wp *)
+ rewrite /logical_step.
+ iMod "Hstep" as "(%n & Hat & Hvs)".
+ iMod (persistent_time_receipt_0) as "Hp".
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iApply (wps_annot_credits with "TIME Hat Hp").
+ iModIntro. iNext. rewrite Nat.add_0_r. rewrite (additive_time_receipt_sep 1).
+ iIntros "[Hcred1 Hcred] [Hat1 Hat]".
+ iApply fupd_wps.
+ iMod ("Hvs" with "Hcred Hat") as "(%L' & HL & HT)".
+ iApply ("HT" with "[$LFT $TIME $LLCTX] HE HL").
+ Qed.
+
+ (** We instantiate the context folding mechanism for extraction of observations. *)
+ Definition typed_context_fold_extract_interp (π : thread_id) := λ '(ctx, R), (type_ctx_interp π ctx ∗ R)%I.
+ Lemma typed_context_fold_step_extract π E L l {rt} (lt : ltype rt) (r : place_rfn rt) (tctx : list loc) acc R κ T :
+ stratify_ltype_extract π E L StratRefoldOpened l lt r (Owned false) κ
+ (λ L' R' rt' lt' r', typed_context_fold (typed_context_fold_stratify_interp π) π E L' (CtxFoldExtractAll κ) tctx ((l, mk_bltype _ r' lt') :: acc, R' ∗ R) T)
+ ⊢ typed_context_fold_step (typed_context_fold_stratify_interp π) π E L (CtxFoldExtractAll κ) l lt r tctx (acc, R) T.
+ Proof.
+ iIntros "Hstrat". iIntros (? ??) "#CTX #HE HL Hdel Hl".
+ iPoseProof ("Hstrat" $! F with "[//] [//] CTX HE HL Hl") as ">Hc".
+ iDestruct "Hc" as "(%L' & %R' & %rt' & %lt' & %r' & HL & %Hst & Hstep & Hcont)".
+ iApply ("Hcont" $! F with "[//] [//] CTX HE HL [Hstep Hdel]").
+ iApply (logical_step_compose with "Hstep").
+ iApply (logical_step_compose with "Hdel").
+ iApply logical_step_intro.
+ iIntros "(Hctx & HR) (Hl & HR')".
+ iFrame.
+ Qed.
+
+ Lemma typed_context_fold_extract_init tctx π E L κ T :
+ typed_context_fold (typed_context_fold_stratify_interp π) π E L (CtxFoldExtractAll κ) tctx ([], True%I) (λ L' m' acc, True ∗
+ typed_context_fold_end (typed_context_fold_stratify_interp π) π E L' acc T)
+ ⊢ typed_pre_context_fold π E L (CtxFoldExtractAllInit κ) T.
+ Proof.
+ iIntros "Hf". iApply (typed_context_fold_init (typed_context_fold_stratify_interp π) ([], True%I) _ _ _ (CtxFoldExtractAll κ)). iFrame.
+ rewrite /typed_context_fold_stratify_interp/type_ctx_interp; simpl; done.
+ Qed.
+
+ (* Typing rule for [Return] *)
+ (*
+ Problem: uninit takes a syn_type, but we only have a layout.
+ Options;
+ - add a "Untyped ly" syn_type that just literally takes a layout.
+ - just track the semantic type in the runtime_function we annotate typed_stmt with;
+ i.e. have a custom notion of runtime_function for the type system that bundles up a bit more info.
+
+ The proper solution would be a tighter integration of the notion of syntactic types into the language, as I had originally planned?
+ - or would it? Really, at runtime we would still have concrete layouts. But in principle, I could then also just store the syn_type, since at runtime a syn_type uniquely identifies its layout.
+
+ What are semantic types? Are they runtime things or static things?
+ - maybe Uninit takes a bit of a special role here. It really specifies a property on the concrete bytes, and that does not make that much sense statically. (it's a "runtime type")
+ => maybe Uninit should be a place type instead?
+ => No. having an uninit value makes sense, it's not inherently tied to a particular location.
+ Still, it takes up a somewhat special role, against the backdrop of the other types that we have (it has no direct correspondence in Rust). Even then, it's also different from e.g. owned-ptr, or place-ptr, which also do not have direct correspondences in Rust.
+ -
+
+ *)
+
+ Lemma type_return E L Ï€ e fn (R : typed_stmt_R_t) Ï:
+ typed_val_expr π E L e (λ L' v rt ty r,
+ v â—áµ¥{Ï€} r @ ty -∗
+ typed_context_fold (typed_context_fold_stratify_interp π) π E L' CtxFoldStratifyAll fn.(rf_locs).*1 ([], True%I) (λ L2 m' acc,
+ introduce_with_hooks E L2 (type_ctx_interp π acc.1 ∗ acc.2) (λ L3,
+ prove_with_subtype E L3 true ProveDirect (
+ foldr (λ (e : (loc * layout)) T, e.1 â—â‚—[Ï€, Owned false] (#()) @ (â— (uninit (UntypedSynType e.2))) ∗ T)
+ True%I
+ fn.(rf_locs)) (λ L3 _ R2, introduce_with_hooks E L3 R2 (λ L4,
+ (* important: when proving the postcondition [R v], we already have the ownership obtained by deinitializing the local variables [R2] available *)
+ prove_with_subtype E L4 false ProveDirect (R v) (λ L5 _ R3,
+ introduce_with_hooks E L5 R3 (λ L6,
+ (* we don't really kill it here, but just need to find it in the context *)
+ li_tactic (llctx_find_llft_goal L6 Ï LlctxFindLftFull) (λ _, True))))))))
+ ⊢ typed_stmt Ï€ E L (return e) fn R Ï.
+ Proof.
+ iIntros "He". iIntros "#CTX #HE HL". wps_bind.
+ wp_bind.
+ iApply ("He" with "CTX HE HL").
+ iIntros (L' v rt ty r) "HL Hv HR".
+ iApply fupd_wp.
+ iMod ("HR" with "Hv [] [] CTX HE HL []") as "(%L2 & %acc & %m' & HL & Hstep & HT)"; [done.. | | ].
+ { simpl. iApply logical_step_intro. iSplitR; last done. rewrite /type_ctx_interp. done. }
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iModIntro. iApply to_expr_wp. wp_bind.
+ iApply (wp_logical_step with "TIME Hstep"); [done.. | ].
+ iApply wp_skip. iNext. iIntros "_ Hacc".
+ rewrite /typed_context_fold_stratify_interp.
+ destruct acc as (ctx & R2).
+ iMod ("HT" with "[] HE HL Hacc") as "(%L3 & HL & HT)"; first done.
+ iMod ("HT" with "[] [] [$] HE HL") as "(%L4 & % & %R3 & HP & HL & HT)"; [done.. | ].
+ iApply (wp_maybe_logical_step with "TIME HP"); [done.. | ].
+ iModIntro. iApply wp_skip. iNext. iIntros "_ (Ha & HR2)".
+ iApply wps_return.
+ rewrite /typed_stmt_post_cond.
+ unfold li_tactic, llctx_find_llft_goal.
+ iMod ("HT" with "[] HE HL HR2") as "(%L5 & HL & HT)"; first done.
+ iMod ("HT" with "[] [] [$TIME $LFT $LLCTX] HE HL") as "(%L6 & % & %R4 & >(HP & HR) & HL & HT)"; [done.. | ].
+ iMod ("HT" with "[] HE HL HR") as "(%L7 & HL & HT)"; first done.
+ iDestruct ("HT") as "(%L8 & %κs1 & %Hfind & _)".
+ destruct Hfind as (L9 & L10 & ? & -> & -> & Hoc).
+ unfold llctx_find_lft_key_interp in Hoc. subst.
+ iDestruct "HL" as "(_ & HÏ & _)".
+ iExists _. iFrame.
+ generalize (rf_locs fn) as ls => ls.
+
+ iInduction ls as [|[l ly] ls] "IH"; csimpl in*; simplify_eq.
+ { by iFrame. }
+ iDestruct "Ha" as "[Hl HR]".
+ iMod ("IH" with "HR") as "(? & ?)".
+ iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly' & %Halg & % & _ & _ & _ & % & <- & Hv)".
+ simpl in Halg. apply syn_type_has_layout_untyped_inv in Halg as [-> _].
+ iMod (fupd_mask_mono with "Hv") as "(%v0 & Hl & Hv)"; first done.
+ iPoseProof (ty_has_layout with "Hv") as "(%ly' & %Halg' & %)".
+ simpl in Halg'. apply syn_type_has_layout_untyped_inv in Halg' as [-> _].
+ iExists _. by iFrame.
+ Qed.
+End typing.
+
+
+(* This must be an hint extern because an instance would be a big slowdown . *)
+Global Hint Extern 1 (Subsume (?v â—áµ¥{_} ?r1 @ ?ty1) (?v â—áµ¥{_} ?r2 @ ?ty2)) =>
+ class_apply own_val_subsume_id_inst : typeclass_instances.
+Global Hint Extern 1 (Subsume (?l â—â‚—{_, _} ?r1 @ ?ty) (?l â—â‚—{_, _} ?r2 @ ?ty)) =>
+ class_apply own_shr_subsume_id_inst : typeclass_instances.
diff --git a/theories/rust_typing/programs.v b/theories/rust_typing/programs.v
new file mode 100644
index 0000000000000000000000000000000000000000..295c46695fb798ccabc73d4eac76ceb4a36a57eb
--- /dev/null
+++ b/theories/rust_typing/programs.v
@@ -0,0 +1,4007 @@
+From stdpp Require Import gmap.
+From refinedrust Require Export base type ltypes lft_contexts annotations.
+From caesium Require Import lang proofmode derived lifting.
+Set Default Proof Using "Type".
+
+
+
+
+ (* TODO move *)
+ Definition option_combine {A B} (a : option A) (b : option B) : option (A * B) :=
+ match a, b with
+ | Some a, Some b => Some (a, b)
+ | _, _ => None
+ end.
+ Lemma option_combine_Some {A B} (a : option A) (b : option B) c :
+ option_combine a b = Some c →
+ ∃ a' b', a = Some a' ∧ b = Some b' ∧ c = (a', b').
+ Proof.
+ rewrite /option_combine. destruct a, b; naive_solver.
+ Qed.
+ Lemma option_combine_None {A B} (a : option A) (b : option B) :
+ option_combine a b = None →
+ a = None ∨ b = None.
+ Proof.
+ rewrite /option_combine. destruct a, b; naive_solver.
+ Qed.
+
+
+
+(* TODO move *)
+Lemma val_of_bool_i2v b :
+ val_of_bool b = i2v (bool_to_Z b) u8.
+Proof.
+ apply val_of_bool_iff_val_of_Z.
+ apply val_of_Z_bool.
+Qed.
+
+(* TODO: move *)
+Lemma lctx_bor_kind_incl_use `{!typeGS Σ} E L b1 b2 :
+ lctx_bor_kind_incl E L b1 b2 →
+ elctx_interp E -∗
+ llctx_interp L -∗
+ b1 ⊑ₖ b2.
+Proof.
+ iIntros (Hincl) "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ by iPoseProof (Hincl with "HL HE") as "Ha".
+Qed.
+
+Lemma lctx_bor_kind_direct_incl_use `{!typeGS Σ} E L b1 b2 :
+ lctx_bor_kind_direct_incl E L b1 b2 →
+ elctx_interp E -∗
+ llctx_interp L -∗
+ b1 ⊑ₛₖ b2.
+Proof.
+ iIntros (Hincl) "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ by iPoseProof (Hincl with "HL HE") as "Ha".
+Qed.
+
+(* TODO move *)
+Lemma subtype_acc `{!typeGS Σ} E L {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) :
+ subtype E L r1 r2 ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp L -∗
+ type_incl r1 r2 ty1 ty2.
+Proof.
+ iIntros (Hsub) "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iPoseProof (Hsub with "HL HE") as "#Hincl". done.
+Qed.
+Lemma full_subtype_acc `{!typeGS Σ} E L {rt} (ty1 : type rt) (ty2 : type rt) :
+ full_subtype E L ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ∀ r, type_incl r r ty1 ty2.
+Proof.
+ iIntros (Hsub) "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iIntros (?). iPoseProof (Hsub with "HL HE") as "#Hincl". done.
+Qed.
+Lemma full_subtype_acc_noend `{!typeGS Σ} E L {rt} (ty1 : type rt) (ty2 : type rt) qL :
+ full_subtype E L ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp_noend L qL -∗
+ ∀ r, type_incl r r ty1 ty2.
+Proof.
+ iIntros (Hsub) "HE HL".
+ iIntros (?). iPoseProof (Hsub with "HL HE") as "#Hincl". done.
+Qed.
+
+Lemma eqtype_acc `{!typeGS Σ} E L {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) :
+ eqtype E L r1 r2 ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp L -∗
+ type_incl r1 r2 ty1 ty2 ∗ type_incl r2 r1 ty2 ty1.
+Proof.
+ iIntros ([Hsub1 Hsub2]) "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iPoseProof (Hsub1 with "HL HE") as "#Hincl1".
+ iPoseProof (Hsub2 with "HL HE") as "#Hincl2".
+ iFrame "#".
+Qed.
+Lemma eqtype_acc_noend `{!typeGS Σ} E L {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) qL :
+ eqtype E L r1 r2 ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp_noend L qL -∗
+ type_incl r1 r2 ty1 ty2 ∗ type_incl r2 r1 ty2 ty1.
+Proof.
+ iIntros ([Hsub1 Hsub2]) "HE HL".
+ iPoseProof (Hsub1 with "HL HE") as "#Hincl1".
+ iPoseProof (Hsub2 with "HL HE") as "#Hincl2".
+ iFrame "#".
+Qed.
+Lemma full_eqtype_acc `{!typeGS Σ} E L {rt} (ty1 : type rt) (ty2 : type rt) :
+ full_eqtype E L ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ∀ r, type_incl r r ty1 ty2 ∗ type_incl r r ty2 ty1.
+Proof.
+ iIntros (Heq) "HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & Hcl_L)".
+ iIntros (r). destruct (Heq r) as [Hsub1 Hsub2].
+ iPoseProof (Hsub1 with "HL HE") as "#$".
+ iPoseProof (Hsub2 with "HL HE") as "#$".
+Qed.
+Lemma full_eqtype_acc_noend `{!typeGS Σ} E L {rt} (ty1 : type rt) (ty2 : type rt) qL :
+ full_eqtype E L ty1 ty2 →
+ elctx_interp E -∗
+ llctx_interp_noend L qL -∗
+ ∀ r, type_incl r r ty1 ty2 ∗ type_incl r r ty2 ty1.
+Proof.
+ iIntros (Heq) "HE HL".
+ iIntros (r). destruct (Heq r) as [Hsub1 Hsub2].
+ iPoseProof (Hsub1 with "HL HE") as "#$".
+ iPoseProof (Hsub2 with "HL HE") as "#$".
+Qed.
+
+(* TODO move *)
+Lemma ltype_incl'_use `{!typeGS Σ} {rt1 rt2} F (lt1 : ltype rt1) (lt2 : ltype rt2) l π b r1 r2 :
+ lftE ⊆ F →
+ ltype_incl' b r1 r2 lt1 lt2 -∗
+ l â—â‚—[Ï€, b] r1 @ lt1 ={F}=∗
+ l â—â‚—[Ï€, b] r2 @ lt2.
+Proof.
+ iIntros (?) "#Hincl Hl".
+ iMod (fupd_mask_subseteq lftE) as "Hcl"; first done.
+ destruct b.
+ - iMod ("Hincl" with "Hl") as "$". by iMod "Hcl".
+ - iMod "Hcl". iModIntro. by iApply "Hincl".
+ - iMod "Hcl". iModIntro. by iApply "Hincl".
+Qed.
+Lemma ltype_incl_use `{!typeGS Σ} {rt1 rt2} π F b r1 r2 l (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ lftE ⊆ F →
+ ltype_incl b r1 r2 lt1 lt2 -∗
+ l â—â‚—[Ï€, b] r1 @ lt1 ={F}=∗ l â—â‚—[Ï€, b] r2 @ lt2.
+Proof.
+ iIntros (?) "Hincl Ha".
+ iDestruct "Hincl" as "(_ & #Hincl & _)".
+ destruct b.
+ - iApply (fupd_mask_mono with "(Hincl Ha)"); done.
+ - by iApply "Hincl".
+ - by iApply "Hincl".
+Qed.
+Lemma ltype_incl_use_core `{!typeGS Σ} {rt1 rt2} π F b r1 r2 l (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ lftE ⊆ F →
+ ltype_incl b r1 r2 lt1 lt2 -∗
+ l â—â‚—[Ï€, b] r1 @ ltype_core lt1 ={F}=∗ l â—â‚—[Ï€, b] r2 @ ltype_core lt2.
+Proof.
+ iIntros (?) "Hincl Ha".
+ iDestruct "Hincl" as "(_ & _ & #Hincl)".
+ destruct b.
+ - iApply (fupd_mask_mono with "(Hincl Ha)"); done.
+ - by iApply "Hincl".
+ - by iApply "Hincl".
+Qed.
+
+
+(* TODO move *)
+Section subltype.
+ Context `{!typeGS Σ}.
+ Lemma subltype_use {rt1 rt2} F E L b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ lftE ⊆ F →
+ subltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ â–¡ ∀ Ï€ l, l â—â‚—[Ï€, b] r1 @ lt1 ={F}=∗ l â—â‚—[Ï€, b] r2 @ lt2.
+ Proof.
+ iIntros (? Hsubt) "#CTX #HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & _)".
+ iPoseProof (Hsubt with "HL CTX HE") as "#Hincl".
+ iModIntro. iIntros (Ï€ l). iApply ltype_incl_use; done.
+ Qed.
+ Lemma subltype_use_core {rt1 rt2} F E L b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ lftE ⊆ F →
+ subltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ â–¡ ∀ Ï€ l, l â—â‚—[Ï€, b] r1 @ ltype_core lt1 ={F}=∗ l â—â‚—[Ï€, b] r2 @ ltype_core lt2.
+ Proof.
+ iIntros (? Hsubt) "#CTX #HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & _)".
+ iPoseProof (Hsubt with "HL CTX HE") as "#Hincl".
+ iModIntro. iIntros (Ï€ l). iApply ltype_incl_use_core; done.
+ Qed.
+
+ Lemma subltype_acc {rt1 rt2} E L b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ subltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ltype_incl b r1 r2 lt1 lt2.
+ Proof.
+ iIntros (Hsubt) "#CTX #HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & _)".
+ iPoseProof (Hsubt with "HL CTX HE") as "#Hincl". done.
+ Qed.
+ Lemma full_subltype_acc E L {rt} (lt1 lt2 : ltype rt) :
+ full_subltype E L lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ∀ b r, ltype_incl b r r lt1 lt2.
+ Proof.
+ iIntros (Hsubt) "#CTX #HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & _)".
+ iPoseProof (Hsubt with "HL CTX HE") as "#Hincl".
+ iIntros (b r). iApply "Hincl".
+ Qed.
+End subltype.
+
+
+(* TODO move *)
+Section eqltype.
+ Context `{!typeGS Σ}.
+ Lemma eqltype_use_noend F E L {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) qL l π :
+ lftE ⊆ F →
+ eqltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp_noend L qL -∗
+ (l â—â‚—[Ï€, b] r1 @ lt1 ={F}=∗ l â—â‚—[Ï€, b] r2 @ lt2) ∗
+ llctx_interp_noend L qL.
+ Proof.
+ iIntros (? Hunfold) "#CTX #HE HL".
+ iPoseProof (Hunfold with "HL CTX HE") as "#Hll". iFrame.
+ iIntros "Hl".
+ iDestruct "Hll" as "((_ & #Ha & _) & _)".
+ destruct b.
+ - iMod (fupd_mask_subseteq lftE) as "Hcl"; first solve_ndisj.
+ iMod ("Ha" with "Hl") as "$". by iMod "Hcl" as "_".
+ - by iApply "Ha".
+ - by iApply "Ha".
+ Qed.
+ Lemma eqltype_use F E L {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) l π :
+ lftE ⊆ F →
+ eqltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ (l â—â‚—[Ï€, b] r1 @ lt1 ={F}=∗ l â—â‚—[Ï€, b] r2 @ lt2) ∗
+ llctx_interp L.
+ Proof.
+ iIntros (? Hunfold) "#CTX #HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iPoseProof (eqltype_use_noend with "CTX HE HL") as "($ & HL)"; [done.. | ].
+ by iApply "HL_cl".
+ Qed.
+ Lemma eqltype_acc E L {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ eqltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ltype_eq b r1 r2 lt1 lt2.
+ Proof.
+ iIntros (Heq) "CTX HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iApply (Heq with "HL CTX HE").
+ Qed.
+ Lemma full_eqltype_acc E L {rt} (lt1 lt2 : ltype rt) :
+ full_eqltype E L lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ∀ b r, ltype_eq b r r lt1 lt2.
+ Proof.
+ iIntros (Heq) "CTX HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iApply (Heq with "HL CTX HE").
+ Qed.
+
+ Lemma all_ltype_eq_alt {rt} b (lt1 lt2 : ltype rt) :
+ (∀ r, ltype_eq b r r lt1 lt2) ⊣⊢ (∀ r, ltype_incl b r r lt1 lt2) ∧ (∀ r, ltype_incl b r r lt2 lt1).
+ Proof.
+ iSplit.
+ - iIntros "#Ha". iSplit; iIntros (r); iSpecialize ("Ha" $! r); iDestruct "Ha" as "[Ha Hb]"; done.
+ - iIntros "#[Ha Hb]". iIntros (r). iSplit; done.
+ Qed.
+ Lemma full_eqltype_use F π E L {rt} b r (lt1 lt2 : ltype rt) l :
+ lftE ⊆ F →
+ full_eqltype E L lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ (l â—â‚—[ Ï€, b] r @ lt1 ={F}=∗ l â—â‚—[ Ï€, b] r @ lt2) ∗
+ llctx_interp L.
+ Proof.
+ iIntros (? Heq) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; [done | ].
+ iFrame. iIntros "Hl". iDestruct ("Heq" $! _ _) as "[Hincl _]".
+ by iApply (ltype_incl_use with "Hincl Hl").
+ Qed.
+
+ Lemma eqltype_syn_type_eq_noend E L {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) qL :
+ eqltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp_noend L qL -∗
+ ⌜ltype_st lt1 = ltype_st lt2âŒ.
+ Proof.
+ iIntros (Hunfold) "#CTX #HE HL".
+ iPoseProof (Hunfold with "HL CTX HE") as "#Hll".
+ iDestruct "Hll" as "((#$ & _) & _)".
+ Qed.
+ Lemma eqltype_syn_type_eq E L {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ eqltype E L b r1 r2 lt1 lt2 →
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ ⌜ltype_st lt1 = ltype_st lt2âŒ.
+ Proof.
+ iIntros (Hunfold) "#CTX #HE HL".
+ iPoseProof (llctx_interp_acc_noend with "HL") as "(HL & HL_cl)".
+ iPoseProof (eqltype_syn_type_eq_noend with "CTX HE HL") as "#$".
+ done.
+ Qed.
+End eqltype.
+
+Section named_lfts.
+ Context `{typeGS Σ}.
+ (** [named_lfts] is a construct used by the automation to map annotated lifetime names to concrete Coq names.
+ This does not have a semantic meaning: we can in principle change this map arbitrarily, the worst thing that
+ can happen is that the automation will make the goal unprovable.
+ Invariant: there is a global singleton around.
+ *)
+ (* TODO: find a better way to seal this off and hide it from basic automation. *)
+ Definition named_lfts (M : gmap string lft) : iProp Σ := True -∗ True.
+ Lemma named_lfts_update M M' : named_lfts M -∗ named_lfts M'.
+ Proof. auto. Qed.
+ Definition lookup_named_lfts (M : gmap string lft) (lfts : list string) :=
+ foldr (λ s oacc, acc ↠oacc; κ ↠M !! s; Some (κ :: acc)) (Some []) lfts.
+
+ Lemma named_lfts_init (M : gmap string lft) : ⊢ named_lfts M.
+ Proof. unfold named_lfts. iIntros "_". done. Qed.
+
+ (* Making it opaque so that simplification doesn't get stuck with it *)
+ Definition named_lft_update (name : string) (κ : lft) (M : gmap string lft) :=
+ <[name := κ]> (M).
+
+ Definition named_lft_delete (name : string) (M : gmap string lft) :=
+ delete name M.
+End named_lfts.
+(* make opaque so that automation does not do weird things (this should not be persistent, etc.) *)
+Global Typeclasses Opaque named_lfts.
+Global Opaque named_lfts.
+Global Arguments named_lfts : simpl never.
+Global Opaque named_lft_update.
+Global Opaque named_lft_delete.
+
+Section named_tyvars.
+ Context `{!typeGS Σ}.
+
+ Definition TYVAR_MAP (m : gmap string (sigT type)) : Set := unit.
+ Arguments TYVAR_MAP : simpl never.
+End named_tyvars.
+
+(** Instances for Lithium to put things into the persistent context *)
+Section intro_persistent.
+ Context `{!typeGS Σ}.
+
+ Global Instance lft_dead_intro_pers κ : IntroPersistent ([†κ]) ([†κ]).
+ Proof. constructor. iIntros "#$". Qed.
+ Global Instance gvar_pobs_intro_pers {T} γ (x : T) : IntroPersistent (gvar_pobs γ x) (gvar_pobs γ x).
+ Proof. constructor. iIntros "#$". Qed.
+ Global Instance ty_sidecond_intro_pers {rt} (ty : type rt) : IntroPersistent (ty_sidecond ty) (ty_sidecond ty).
+ Proof. constructor. iIntros "#$". Qed.
+End intro_persistent.
+
+Section credits.
+ Context `{typeGS Σ}.
+
+ (* We require at least one credit here so that the majority of clients does not need any sideconditions.
+ We require at least one atime here, as place accesses will use the receipt every step gains for boosting, so we need to have at least one here to regenerate a potential credit we use.
+ *)
+ Definition credit_store_def (n m : nat) : iProp Σ :=
+ £(S n) ∗ atime (S m).
+ Definition credit_store_aux : seal (@credit_store_def). by eexists. Qed.
+ Definition credit_store := unseal credit_store_aux.
+ Definition credit_store_eq : @credit_store = @credit_store_def := seal_eq credit_store_aux.
+
+ Lemma credit_store_acc (n m : nat) :
+ credit_store n m -∗
+ £ (S n) ∗ atime (S m) ∗ (∀ n' m', £ (S n') -∗ atime (S m') -∗ credit_store n' m').
+ Proof.
+ rewrite credit_store_eq /credit_store_def.
+ iIntros "($ & $)". eauto with iFrame.
+ Qed.
+
+ (* allows direct access to one credit, and after regenerating some (usually m' = 0 or m' = 1), we get back *)
+ Lemma credit_store_get_reg (n m : nat) :
+ credit_store n m -∗
+ £ 1 ∗ atime (S m) ∗ (∀ m', £ (1 + m' + m) -∗ atime (1 + m' + m) -∗ credit_store (m' + m + n) (m' + m)).
+ Proof.
+ iIntros "Hst". iPoseProof (credit_store_acc with "Hst") as "(Hcred & $ & Hcl)".
+ rewrite lc_succ. iDestruct "Hcred" as "($ & Hcred)".
+ iIntros (m') "Hcred' Hc".
+ iPoseProof (lc_split with "[$Hcred' $Hcred]") as "Hcred".
+ iApply ("Hcl" with "Hcred Hc").
+ Qed.
+
+ (* the two common instantiations of this *)
+ Lemma credit_store_get_reg0 (n m : nat) :
+ credit_store n m -∗
+ £ 1 ∗ atime (S m) ∗ (£ (1 + m) -∗ atime (S m) -∗ credit_store (m + n) (m)).
+ Proof.
+ iIntros "Hst".
+ iPoseProof (credit_store_get_reg with "Hst") as "($ & $ & Hcl)".
+ iApply "Hcl".
+ Qed.
+ Lemma credit_store_get_reg1 (n m : nat) :
+ credit_store n m -∗
+ £ 1 ∗ atime (S m) ∗ (£ (S (S m)) -∗ atime (S (S m)) -∗ credit_store (1 + m + n) (1 + m)).
+ Proof.
+ iIntros "Hst".
+ iPoseProof (credit_store_get_reg with "Hst") as "($ & $ & Hcl)".
+ iApply ("Hcl" $! 1%nat).
+ Qed.
+
+
+ (* TODO move *)
+ Lemma additive_time_receipt_succ n :
+ atime (S n) ⊣⊢ atime 1 ∗ atime n.
+ Proof. by rewrite -additive_time_receipt_sep. Qed.
+
+ Lemma credit_store_borrow_receipt (n m : nat) :
+ credit_store n m -∗
+ atime 1 ∗ (atime 1 -∗ credit_store n m).
+ Proof.
+ iIntros "Hst".
+ iPoseProof (credit_store_acc with "Hst") as "(Hcred & Hat & Hcl)".
+ rewrite additive_time_receipt_succ. iDestruct "Hat" as "(Hat1 & Hat)".
+ iFrame. iIntros "Hat1".
+ iApply ("Hcl" with "Hcred [Hat1 Hat]").
+ iApply additive_time_receipt_succ. iFrame.
+ Qed.
+
+ Lemma credit_store_borrow (n m : nat) :
+ credit_store n m -∗
+ £ 1 ∗ atime 1 ∗ (£ 1 -∗ atime 1 -∗ credit_store n m).
+ Proof.
+ iIntros "Hst".
+ iPoseProof (credit_store_acc with "Hst") as "(Hcred & Hat & Hcl)".
+ rewrite additive_time_receipt_succ. iDestruct "Hat" as "(Hat1 & Hat)".
+ rewrite lc_succ. iDestruct "Hcred" as "(Hc1 & Hc)".
+ iFrame. iIntros "Hc1 Hat1".
+ iApply ("Hcl" with "[Hc Hc1] [Hat1 Hat]").
+ { iApply lc_succ. iFrame. }
+ iApply additive_time_receipt_succ. iFrame.
+ Qed.
+
+ (* allows direct access to credits, but without regenerating and instead requires to prove a sidecondition *)
+ Lemma credit_store_scrounge (n m k : nat) :
+ n ≥ k →
+ credit_store n m -∗
+ £ k ∗ credit_store (n - k) m.
+ Proof.
+ iIntros (?) "Hst". iPoseProof (credit_store_acc with "Hst") as "(Hcred & Hc & Hcl)".
+ replace (S n)%nat with (S (n - k) + k)%nat by lia.
+ rewrite lc_split. iDestruct "Hcred" as "(Hcred & $)".
+ iApply ("Hcl" with "Hcred Hc").
+ Qed.
+ Lemma credit_store_donate n m k :
+ credit_store n m -∗ £ k -∗ credit_store (k + n) m.
+ Proof.
+ iIntros "Hst Hcred0".
+ iPoseProof (credit_store_acc with "Hst") as "(Hcred & Hat & Hcl)".
+ iApply ("Hcl" with "[Hcred0 Hcred] Hat").
+ iApply lc_succ. iDestruct "Hcred" as "($ & ?)".
+ rewrite lc_split. iFrame.
+ Qed.
+ Lemma credit_store_donate_atime n m k :
+ credit_store n m -∗ atime k -∗ credit_store n (k + m).
+ Proof.
+ iIntros "Hst Hat0".
+ iPoseProof (credit_store_acc with "Hst") as "(Hcred & Hat & Hcl)".
+ iApply ("Hcl" with "Hcred [Hat Hat0]").
+ rewrite -Nat.add_succ_r. rewrite additive_time_receipt_sep. iFrame.
+ Qed.
+
+ (* TODO move *)
+ Lemma lc_split_le (m n : nat) :
+ m ≤ n →
+ £ n -∗ £ m ∗ £ (n - m).
+ Proof.
+ intros ?. replace n with (m + (n - m))%nat by lia.
+ replace (m + (n - m) - m)%nat with (n - m)%nat by lia.
+ rewrite lc_split. auto.
+ Qed.
+End credits.
+
+Section option_map.
+ Context `{!typeGS Σ}.
+
+ Definition typed_option_map {A R} (o : option A) (Φ : A → (R → iProp Σ) → iProp Σ) (d : R) (T : R → iProp Σ) :=
+ match o with
+ | Some o => Φ o T
+ | None => T d
+ end.
+ Global Typeclasses Opaque typed_option_map.
+ Class TypedOptionMap {A R} (o : option A) (Φ : A → (R → iProp Σ) → iProp Σ) (d : R) :=
+ typed_option_map_proof T : iProp_to_Prop (typed_option_map o Φ d T).
+ Lemma typed_option_map_some {A R} (a : A) Φ (d : R) T :
+ Φ a T ⊢ typed_option_map (Some a) Φ d T.
+ Proof. rewrite /typed_option_map. iIntros "$". Qed.
+ Global Instance typed_option_map_some_inst {A R} (a : A) Φ (d : R) : TypedOptionMap (Some a) Φ d :=
+ λ T, i2p (typed_option_map_some a Φ d T).
+ Lemma typed_option_map_none {A R} (Φ : A → (R → iProp Σ) → iProp Σ) (d : R) T :
+ T d ⊢ typed_option_map None Φ d T.
+ Proof. rewrite /typed_option_map. eauto. Qed.
+ Global Instance typed_option_map_none_inst {A R} (Φ : A → (R → iProp Σ) → iProp Σ) d : TypedOptionMap None Φ d :=
+ λ T, i2p (typed_option_map_none Φ d T).
+
+ (* If we can find a common predicate [P] that should be satisfied by [r], we can eliminate into that. *)
+ Lemma typed_option_map_elim {A R} (o : option A) (d : R) (Φ : A → (R → iProp Σ) → iProp Σ) (P : R → iProp Σ) (F : iProp Σ) T :
+ typed_option_map o Φ d T -∗
+ (∀ a, ⌜o = Some a⌠-∗ F -∗ Φ a T -∗ ∃ r, F ∗ P r ∗ T r) -∗
+ P d -∗
+ F -∗
+ (∃ r, F ∗ P r ∗ T r).
+ Proof.
+ iIntros "Ha Helim1 Helim2 HF".
+ rewrite /typed_option_map.
+ destruct o as [ a | ].
+ - iPoseProof ("Helim1" with "[//] HF Ha") as "(%r & HF & HP & HT)". iExists r. iFrame.
+ - iExists d. iFrame.
+ Qed.
+ Lemma typed_option_map_elim_fupd {A R E} (o : option A) (d : R) (Φ : A → (R → iProp Σ) → iProp Σ) (P : R → iProp Σ) (F : iProp Σ) T :
+ lftE ⊆ E →
+ typed_option_map o Φ d T -∗
+ (∀ a, ⌜o = Some a⌠-∗ F -∗ Φ a T ={E}=∗ ∃ r, F ∗ P r ∗ T r) -∗
+ P d -∗
+ F ={E}=∗
+ (∃ r, F ∗ P r ∗ T r).
+ Proof.
+ iIntros (?) "Ha Helim1 Helim2 HF".
+ rewrite /typed_option_map.
+ destruct o as [ a | ].
+ - iMod ("Helim1" with "[//] HF Ha") as "(%r & HF & HP & HT)". iExists r. by iFrame.
+ - iModIntro. iExists d. iFrame.
+ Qed.
+End option_map.
+Global Hint Mode TypedOptionMap + + + ! - - : typeclass_instances.
+
+(** find type of val in context *)
+Definition FindVal `{!typeGS Σ} (v : val) (π : thread_id) :=
+ {| fic_A := @sigT Type (λ rt, type rt * rt)%type; fic_Prop '(existT rt (ty, r)) := (v â—áµ¥{Ï€} r @ ty)%I; |}.
+Global Typeclasses Opaque FindVal.
+
+(** find type of val in context -- also allows to find location assignments by accepting an arbitrary prop [P].
+ Thus, this is used mostly for RelatedTo/Subsume *)
+Definition FindValP `{!typeGS Σ} (v : val) (π : thread_id) :=
+ {| fic_A := iProp Σ; fic_Prop P := P |}.
+Global Typeclasses Opaque FindValP.
+
+(** find type of val with known rt in context *)
+Definition FindValWithRt `{!typeGS Σ} (rt : Type) (v : val) (π : thread_id) :=
+ {| fic_A := (type rt * rt)%type; fic_Prop '(ty, r) := (v â—áµ¥{Ï€} r @ ty)%I; |}.
+Global Typeclasses Opaque FindValWithRt.
+
+(** find type of location in context *)
+Definition FindLoc `{!typeGS Σ} (l : loc) (π : thread_id) :=
+ {| fic_A := @sigT Type (λ rt, ltype rt * (place_rfn rt) * bor_kind)%type; fic_Prop '(existT rt (lt, r, b)) := (l â—â‚—[Ï€, b] r @ lt)%I; |}.
+Global Typeclasses Opaque FindLoc.
+
+Definition FindOptLoc `{!typeGS Σ} (l : loc) (π : thread_id) :=
+ {| fic_A := option (@sigT Type (λ rt, ltype rt * (place_rfn rt) * bor_kind)%type); fic_Prop a :=
+ match a with Some (existT rt (lt, r, b)) => (l â—â‚—[Ï€, b] r @ lt)%I | _ => True%I end; |}.
+Global Typeclasses Opaque FindOptLoc.
+
+(** Find freeable_nz for a location *)
+Definition FindFreeable `{!typeGS Σ} (l : loc) :=
+ {| fic_A := (nat * Qp * alloc_kind); fic_Prop '(size, q, kind) := freeable_nz l size q kind |}.
+Global Typeclasses Opaque FindFreeable.
+
+(** find type of location in context -- more flexible by accepting an arbitrary prop [P].
+ Thus, this is used mostly for RelatedTo/Subsume *)
+Definition FindLocP `{!typeGS Σ} (l : loc) (π : thread_id) :=
+ {| fic_A := iProp Σ; fic_Prop P := P |}.
+Global Typeclasses Opaque FindLocP.
+
+(** find type of location with known rt in context *)
+Definition FindLocWithRt `{!typeGS Σ} (rt : Type) (l : loc) (π : thread_id) :=
+ {| fic_A := (ltype rt * (place_rfn rt) * bor_kind)%type; fic_Prop '(lt, r, b) := (l â—â‚—[Ï€, b] r @ lt)%I; |}.
+Global Typeclasses Opaque FindLocWithRt.
+
+(** find a loc_in_bounds fact for l.
+ We also allow other propositions [P], in particular location ownership,
+ and will handle them using subsume instances. *)
+Definition FindLocInBounds `{!typeGS Σ} (l : loc) :=
+ {| fic_A := iProp Σ; fic_Prop P := P |}.
+Global Typeclasses Opaque FindLocInBounds.
+
+(** find the named lifetime judgment *)
+Definition FindNamedLfts `{!typeGS Σ} :=
+ {| fic_A := gmap string lft; fic_Prop M := (named_lfts (Σ := Σ) M)%I; |}.
+Global Typeclasses Opaque FindNamedLfts.
+
+(** find the credit store *)
+Definition FindCreditStore `{!typeGS Σ} :=
+ {| fic_A := nat * nat; fic_Prop '(n, m) := credit_store n m; |}.
+Global Typeclasses Opaque FindCreditStore.
+
+(** find a lft dead token *)
+Definition FindOptLftDead `{!typeGS Σ} (κ : lft) :=
+ {| fic_A := bool; fic_Prop b := (if b then [†κ] else True)%I; |}.
+Global Typeclasses Opaque FindOptLftDead.
+
+(** attempt to find an observation, or give up if there is none *)
+Definition FindOptGvarPobs `{!typeGS Σ} (γ : gname) :=
+ {| fic_A := (@sigT Type (λ rt, rt) + unit)%type;
+ fic_Prop a :=
+ match a with
+ | inl (existT rt r) => (gvar_pobs γ r)%I
+ | inr _ => True%I
+ end
+ |}.
+Global Typeclasses Opaque FindOptGvarPobs.
+
+(** find an observation on a ghost variable *)
+(** NOTE: Ideally, we would also fix the type beforehand.
+ However, that leads to universe trouble when using the definition that I have not yet figured out.
+*)
+Definition FindGvarPobs `{!typeGS Σ} (γ : gname) :=
+ {| fic_A := (@sigT Type (λ rt, rt))%type;
+ fic_Prop '(existT rt r) := (gvar_pobs γ r)%I
+ |}.
+Global Typeclasses Opaque FindGvarPobs.
+Definition FindGvarPobsP `{!typeGS Σ} (γ : gname) :=
+ {| fic_A := iProp Σ;
+ fic_Prop P := P
+ |}.
+Global Typeclasses Opaque FindGvarPobsP.
+
+(** Find a relation with the given gvar on the right hand side. *)
+Definition FindOptGvarRel `{!typeGS Σ} (γ : gname) :=
+ {| fic_A := (@sigT Type (λ rt, gname * (rt → rt → Prop)) + unit)%type;
+ fic_Prop a :=
+ match a with
+ | inl (existT rt (γ', R)) => (Rel2 γ' γ R)%I
+ | inr _ => True%I
+ end
+ |}.
+Global Typeclasses Opaque FindOptGvarRel.
+
+
+
+Definition FindInherit `{!typeGS Σ} {K} (κ : lft) (key : K) (P : iProp Σ) :=
+ {| fic_A := unit;
+ fic_Prop _ := Inherit κ key P;
+ |}.
+Global Typeclasses Opaque FindInherit.
+
+(** Find a type assignment for a location [l] that may be part of a larger type assignment -- e.g. if [l] offsets into an array, this will find a type assignment for an array whose memory range includes [l].
+
+ Note that the obligation stated here does not require that [l] and the actually found here are in any way related -- rather, this will be enforced by the corresponding [FindHypEqual] with a custom [FICRelated] key, defined in [automation/loc_related.v].
+ The client needing this information will have to spawn a sidecondition (re-)proving it.
+*)
+Definition FindRelatedLoc `{!typeGS Σ} (π : thread_id) :=
+ {| fic_A := @sigT Type (λ rt, loc * ltype rt * (place_rfn rt) * bor_kind)%type;
+ fic_Prop '(existT rt (l', lt, r, b)) := (l' â—â‚—[Ï€, b] r @ lt)%I;
+ |}.
+Global Typeclasses Opaque FindRelatedLoc.
+
+
+(** A judgment to trigger TC search on [H] for some output [a : A]. *)
+Definition trigger_tc `{!typeGS Σ} {A} (H : A → Type) (T : A → iProp Σ) : iProp Σ :=
+ ∃ (a : A) (x : H a), T a.
+
+Section judgments.
+ Context `{typeGS Σ}.
+
+ Class SimplifyHypPlace (l : loc) (Ï€ : thread_id) {rt} (ty : type rt) (r : place_rfn rt) (n : option N) : Type :=
+ simplify_hyp_place :: SimplifyHyp (l â—â‚—[Ï€, Owned false] r @ (â— ty)%I) n.
+ Global Hint Mode SimplifyHypPlace + + + + + - : typeclass_instances.
+ Class SimplifyHypVal (v : val) (Ï€ : thread_id) {rt} (ty : type rt) (r : rt) (n : option N) : Type :=
+ simplify_hyp_val :: SimplifyHyp (v â—áµ¥{Ï€} r @ ty) n.
+ Global Hint Mode SimplifyHypVal + + + + + - : typeclass_instances.
+
+ Class SimplifyGoalPlace (l : loc) π (b : bor_kind) {rt} (lty : ltype rt) (r : place_rfn rt) (n : option N) : Type :=
+ simplify_goal_place :: SimplifyGoal (l â—â‚—[Ï€, b] r @ lty) n.
+ Global Hint Mode SimplifyGoalPlace + + + - - - - : typeclass_instances.
+ Class SimplifyGoalVal (v : val) π {rt} (ty : type rt) (r : rt) (n : option N) : Type :=
+ simplify_goal_val :: SimplifyGoal (v â—áµ¥{Ï€} r @ ty) n.
+ Global Hint Mode SimplifyGoalVal + + - - - - : typeclass_instances.
+
+ (** Notion of [subsume] with support for lifetime contexts + executing updates *)
+ Definition subsume_full (E : elctx) (L : llctx) (step : bool) (P : iProp Σ) (Q : iProp Σ) (T : llctx → iProp Σ → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ P -∗ |={F}=>
+ ∃ L' R, maybe_logical_step step F (Q ∗ R) ∗ llctx_interp L' ∗ T L' R.
+ Class SubsumeFull (E : elctx) (L : llctx) (step : bool) (P Q : iProp Σ) : Type :=
+ subsume_full_proof T : iProp_to_Prop (subsume_full E L step P Q T).
+ Global Hint Mode SubsumeFull + + - + - : typeclass_instances.
+ Lemma subsume_full_id E L step P T :
+ T L True ⊢ subsume_full E L step P P T.
+ Proof.
+ iIntros "HT" (???) "CTX HE HL ?".
+ iExists L, True%I. iFrame.
+ iApply maybe_logical_step_intro. by iFrame.
+ Qed.
+ Global Instance subsume_full_id_inst E L step (P : iProp Σ) : SubsumeFull E L step P P := λ T, i2p (subsume_full_id E L step P T).
+
+ Lemma subsume_full_subsume E L step P Q T :
+ subsume P Q (T L True) ⊢
+ subsume_full E L step P Q T.
+ Proof.
+ iIntros "Hsub" (???) "#CTX #HE HL HP". iPoseProof ("Hsub" with "HP") as "(HQ & HT)".
+ iExists L, True%I; iFrame. iApply maybe_logical_step_intro. by iFrame.
+ Qed.
+ (* low priority, should not trigger when there are other more specific instances *)
+ Global Instance subsume_full_subsume_inst E L step P Q : SubsumeFull E L step P Q | 2000 :=
+ λ T, i2p (subsume_full_subsume E L step P Q T).
+
+ Class SubsumeFullPlace (E : elctx) (L : llctx) (step : bool) (l : loc) (Ï€ : thread_id) (b : bor_kind) {rt1} (ty1 : ltype rt1) (r1 : place_rfn rt1) {rt2} (ty2 : ltype rt2) (r2 : place_rfn rt2) : Type :=
+ subsume_full_place :: SubsumeFull E L step (l â—â‚—[Ï€, b] r1 @ ty1) (l â—â‚—[Ï€, b] r2 @ ty2).
+ Global Hint Mode SubsumeFullPlace + + + + + + ! ! ! - - - : typeclass_instances.
+ Class SubsumeFullVal (Ï€ : thread_id) (E : elctx) (L : llctx) (step : bool) (v : val) {rt1} (ty1 : type rt1) (r1 : rt1) {rt2} (ty2 : type rt2) (r2 : rt2) : Type :=
+ subsume_full_val :: SubsumeFull E L step (v â—áµ¥{Ï€} r1 @ ty1) (v â—áµ¥{Ï€} r2 @ ty2).
+ Global Hint Mode SubsumeFullVal + + + + + ! ! ! - - - : typeclass_instances.
+
+ (** *** Expressions *)
+
+ (** Typing of values *)
+ Definition typed_value (v : val) π (T : ∀ rt, type rt → rt → iProp Σ) : iProp Σ :=
+ (rrust_ctx -∗ ∃ rt (ty : type rt) r, v â—áµ¥{Ï€} r @ ty ∗ T rt ty r).
+ Class TypedValue (v : val) π : Type :=
+ typed_value_proof T : iProp_to_Prop (typed_value v π T).
+ Global Hint Mode TypedValue + + : typeclass_instances.
+
+ (** Typing of value expressions (unfolding [typed_value] for easier usage) *)
+ Definition typed_val_expr π (E : elctx) (L : llctx) (e : expr) (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) : iProp Σ :=
+ (∀ Φ, rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (∀ L' v rt (ty : type rt) r, llctx_interp L' -∗ v â—áµ¥{Ï€} r @ ty -∗ T L' v rt ty r -∗ Φ v) -∗
+ WP e {{ Φ }}).
+ Global Arguments typed_val_expr _ _ _ _%E _%I.
+
+ (** Typing of binary op expressions *)
+ Definition typed_bin_op (π : thread_id) (E : elctx) (L : llctx) (v1 : val) (P1 : iProp Σ) (v2 : val) (P2 : iProp Σ)
+ (o : bin_op) (ot1 ot2 : op_type) (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) : iProp Σ :=
+ (P1 -∗ P2 -∗ typed_val_expr π E L (BinOp o ot1 ot2 v1 v2) T).
+ Class TypedBinOp (π : thread_id) (E : elctx) (L : llctx) (v1 : val) (P1 : iProp Σ) (v2 : val) (P2 : iProp Σ) (o : bin_op) (ot1 ot2 : op_type) : Type :=
+ typed_bin_op_proof T : iProp_to_Prop (typed_bin_op π E L v1 P1 v2 P2 o ot1 ot2 T).
+ Global Hint Mode TypedBinOp + + + + + + + + + + : typeclass_instances.
+ (* class for instances specialized to value ownership *)
+ Class TypedBinOpVal (Ï€ : thread_id) (E : elctx) (L : llctx) (v1 : val) {rt1} (ty1 : type rt1) (r1 : rt1) (v2 : val) {rt2} (ty2 : type rt2) (r2 : rt2) (o : bin_op) (ot1 ot2 : op_type) : Type :=
+ typed_bin_op_val :: TypedBinOp Ï€ E L v1 (v1 â—áµ¥{Ï€} r1 @ ty1) v2 (v2 â—áµ¥{Ï€} r2 @ ty2) o ot1 ot2.
+ Global Hint Mode TypedBinOpVal + + + + + + + + + + + + + + : typeclass_instances.
+
+ (** Typing of unary op expressions *)
+ Definition typed_un_op (π : thread_id) (E : elctx) (L : llctx) (v : val) (P : iProp Σ) (o : un_op) (ot : op_type)
+ (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) : iProp Σ :=
+ (P -∗ typed_val_expr π E L (UnOp o ot v) T).
+ Class TypedUnOp π (E : elctx) (L : llctx) (v : val) (P : iProp Σ) (o : un_op) (ot : op_type) : Type :=
+ typed_un_op_proof T : iProp_to_Prop (typed_un_op π E L v P o ot T).
+ Global Hint Mode TypedUnOp + + + + + + + : typeclass_instances.
+ (* class for instances specialized to value ownership *)
+ Class TypedUnOpVal π (E : elctx) (L : llctx) (v : val) {rt} (ty : type rt) (r : rt) (o : un_op) (ot : op_type) : Type :=
+ typed_un_op_val :: TypedUnOp Ï€ E L v (v â—áµ¥{Ï€} r @ ty) o ot.
+ Global Hint Mode TypedUnOpVal + + + + + + + + + : typeclass_instances.
+
+ (** Typed call expressions, assuming a list of argument values with given types and refinements.
+ [P] may state additional preconditions on the function. *)
+ Definition typed_call π E L (eκs : list lft) (v : val) (P : iProp Σ) (vl : list val) (tys : list (sigT (λ rt, type rt * rt)%type)) (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) : iProp Σ :=
+ (P -∗
+ ([∗ list] v;rt∈vl;tys, let '(existT rt (ty, r)) := rt in v â—áµ¥{Ï€} r @ ty) -∗
+ typed_val_expr π E L (Call v (Val <$> vl)) T)%I.
+ Class TypedCall π (E : elctx) (L : llctx) (eκs : list lft) (v : val) (P : iProp Σ) (vl : list val) (tys : list (sigT (λ rt, type rt * rt)%type)) : Type :=
+ typed_call_proof T : iProp_to_Prop (typed_call π E L eκs v P vl tys T).
+ Global Hint Mode TypedCall + + + + + + + + : typeclass_instances.
+
+ Definition typed_if (E : elctx) (L : llctx) (v : val) (P T1 T2 : iProp Σ) : iProp Σ :=
+ (P -∗ ∃ b, ⌜val_to_bool v = Some b⌠∗ (if b then T1 else T2)).
+ Class TypedIf E L (v : val) (P : iProp Σ) : Type :=
+ typed_if_proof T1 T2 : iProp_to_Prop (typed_if E L v P T1 T2).
+ Global Hint Mode TypedIf + + + + : typeclass_instances.
+
+ (** Typing of annotated expressions -- annotation determined by the [A]*)
+ (* A is the annotation from the code *)
+ Definition typed_annot_expr_cont_t := llctx → val → ∀ (rt : Type), type rt → rt → iProp Σ.
+ Definition typed_annot_expr (π : thread_id) (E : elctx) (L : llctx) (n : nat) {A} (a : A) (v : val) (P : iProp Σ) (T : typed_annot_expr_cont_t) : iProp Σ :=
+ (rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ P ={⊤}[∅]â–·=∗^n |={⊤}=> ∃ L2 rt (ty : type rt) r, llctx_interp L2 ∗ v â—áµ¥{Ï€} r @ ty ∗ T L2 v rt ty r).
+ Class TypedAnnotExpr (π : thread_id) (E : elctx) (L : llctx) (n : nat) {A} (a : A) (v : val) (P : iProp Σ) : Type :=
+ typed_annot_expr_proof T : iProp_to_Prop (typed_annot_expr π E L n a v P T).
+ Global Hint Mode TypedAnnotExpr + + + + + + + + : typeclass_instances.
+
+ (** Learn from a hypothesis on introduction with [introduce_with_hooks], defined below *)
+ Class LearnFromHyp (P : iProp Σ) := {
+ learn_from_hyp_Q : Prop;
+ learn_from_hyp_proof :
+ ∀ F, ⌜lftE ⊆ F⌠-∗ P ={F}=∗ P ∗ ⌜learn_from_hyp_QâŒ;
+ }.
+ Global Hint Mode LearnFromHyp - : typeclass_instances.
+
+ Class LearnFromHypVal {rt} (ty : type rt) (r : rt) := {
+ learn_from_hyp_val_Q : Prop;
+ learn_from_hyp_val_proof :
+ ∀ F Ï€ v, ⌜lftE ⊆ F⌠-∗ v â—áµ¥{Ï€} r @ ty ={F}=∗ v â—áµ¥{Ï€} r @ ty ∗ ⌜learn_from_hyp_val_QâŒ;
+ }.
+ Global Hint Mode LearnFromHypVal - - - : typeclass_instances.
+ Global Program Instance learn_hyp_val π v {rt} (ty : type rt) r :
+ LearnFromHypVal ty r → LearnFromHyp (v â—áµ¥{Ï€} r @ ty) :=
+ λ H, {| learn_from_hyp_Q := learn_from_hyp_val_Q |}.
+ Next Obligation. intros π v rt ty r [Q HQ]. done. Qed.
+
+ Global Program Instance learn_hyp_place_owned π l {rt} (ty : type rt) r :
+ LearnFromHypVal ty r → LearnFromHyp (l â—â‚—[Ï€, Owned false] #r @ (â— ty))%I | 10 :=
+ λ H, {| learn_from_hyp_Q := learn_from_hyp_val_Q ∧ ∃ ly, (use_layout_alg (ty_syn_type ty)) = Some ly ∧ l `has_layout_loc` ly |}.
+ Next Obligation.
+ intros π l rt ty r [Q HQ] F.
+ iIntros (?) "Hl".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & % & ? & ? & ? & %r' & -> & HT)".
+ iMod (fupd_mask_mono with "HT") as "(%v & Hl & Hv)"; first done.
+ iMod (HQ with "[//] Hv") as "(Hv & %HQ')".
+ iSplitL. { iModIntro. iExists _. iFrame. iR. iR. iExists _. iR.
+ iModIntro. eauto 8 with iFrame. }
+ iModIntro. iPureIntro. split; first done.
+ exists ly. done.
+ Qed.
+
+ (* Lower-priority instance for other ownership modes and place types *)
+ Global Program Instance learn_hyp_place_layout π l k {rt} (lt : ltype rt) r :
+ LearnFromHyp (l â—â‚—[Ï€, k] r @ lt)%I | 20 :=
+ {| learn_from_hyp_Q := ∃ ly, (use_layout_alg (ltype_st lt)) = Some ly ∧ l `has_layout_loc` ly |}.
+ Next Obligation.
+ intros π l k rt lt r F.
+ iIntros (?) "Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Hst & %Hl)".
+ iModIntro. iFrame. iPureIntro. eauto.
+ Qed.
+
+ (** * Introduce a proposition containing tokens that we want to directly return *)
+ (* TODO also thread na tokens through here *)
+ Definition introduce_with_hooks (E : elctx) (L : llctx) (P : iProp Σ) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ elctx_interp E -∗ llctx_interp L -∗ P ={F}=∗ ∃ L', llctx_interp L' ∗ T L'.
+ Class IntroduceWithHooks (E : elctx) (L : llctx) (P : iProp Σ) : Type :=
+ introduce_with_hooks_proof T : iProp_to_Prop (introduce_with_hooks E L P T).
+ Global Hint Mode IntroduceWithHooks + + - : typeclass_instances.
+
+ Lemma introduce_with_hooks_sep E L P1 P2 T :
+ introduce_with_hooks E L P1 (λ L', introduce_with_hooks E L' P2 T) ⊢
+ introduce_with_hooks E L (P1 ∗ P2) T.
+ Proof.
+ iIntros "Ha" (F ?) "#HE HL [HP1 HP2]".
+ iMod ("Ha" with "[//] HE HL HP1") as "(%L' & HL & Ha)".
+ iApply ("Ha" with "[//] HE HL HP2").
+ Qed.
+ Global Instance introduce_with_hooks_sep_inst E L P1 P2 : IntroduceWithHooks E L (P1 ∗ P2) :=
+ λ T, i2p (introduce_with_hooks_sep E L P1 P2 T).
+
+ Lemma introduce_with_hooks_exists {X} E L (Φ : X → iProp Σ) T :
+ (∀ x, introduce_with_hooks E L (Φ x) T) ⊢
+ introduce_with_hooks E L (∃ x, Φ x) T.
+ Proof.
+ iIntros "Ha" (F ?) "#HE HL (%x & HP)".
+ iApply ("Ha" with "[//] HE HL HP").
+ Qed.
+ Global Instance introduce_with_hooks_exists_inst {X} E L (Φ : X → iProp Σ) : IntroduceWithHooks E L (∃ x, Φ x) :=
+ λ T, i2p (introduce_with_hooks_exists E L Φ T).
+
+ (* low priority base instances so that other more specialized instances trigger first *)
+ Lemma introduce_with_hooks_base_learnable E L P T `{HP : LearnFromHyp P} :
+ (P -∗ ⌜learn_from_hyp_Q⌠-∗ T L) ⊢
+ introduce_with_hooks E L P T.
+ Proof.
+ iIntros "HT" (F ?) "#HE HL HP".
+ iMod (learn_from_hyp_proof with "[//] HP") as "(HP & Hlearn)".
+ iSpecialize ("HT" with "HP Hlearn").
+ iModIntro. iExists L. iFrame.
+ Qed.
+ Global Instance introduce_with_hooks_base_learnable_inst E L P `{!LearnFromHyp P} : IntroduceWithHooks E L P | 100 :=
+ λ T, i2p (introduce_with_hooks_base_learnable E L P T).
+
+ Lemma introduce_with_hooks_base E L P T :
+ (P -∗ T L) ⊢
+ introduce_with_hooks E L P T.
+ Proof.
+ iIntros "HT" (F ?) "#HE HL HP".
+ iSpecialize ("HT" with "HP").
+ iModIntro. iExists L. iFrame.
+ Qed.
+ Global Instance introduce_with_hooks_base_inst E L P : IntroduceWithHooks E L P | 101 :=
+ λ T, i2p (introduce_with_hooks_base E L P T).
+
+ (** credit related instances *)
+ Lemma introduce_with_hooks_credits E L n T :
+ find_in_context (FindCreditStore) (λ '(c, a),
+ credit_store (n + c) a -∗ T L) ⊢
+ introduce_with_hooks E L (£ n) T.
+ Proof.
+ rewrite /FindCreditStore. iIntros "Ha".
+ iDestruct "Ha" as ([c a]) "(Hstore & HT)". simpl.
+ iIntros (??) "#HE HL Hc".
+ iPoseProof (credit_store_donate with "Hstore Hc") as "Hstore".
+ iExists _. iFrame. iApply ("HT" with "Hstore").
+ Qed.
+ Global Instance introduce_with_hooks_credits_inst E L n : IntroduceWithHooks E L (£ n) | 10 :=
+ λ T, i2p (introduce_with_hooks_credits E L n T).
+
+ Lemma introduce_with_hooks_atime E L n T :
+ find_in_context (FindCreditStore) (λ '(c, a),
+ credit_store c (n + a) -∗ T L)
+ ⊢ introduce_with_hooks E L (atime n) T.
+ Proof.
+ rewrite /FindCreditStore. iIntros "Ha".
+ iDestruct "Ha" as ([c a]) "(Hstore & HT)". simpl.
+ iIntros (??) "#HE HL Hc".
+ iPoseProof (credit_store_acc with "Hstore") as "(Hcred & Hat & Hcl)".
+ iPoseProof ("Hcl" $! _ (n + a)%nat with "Hcred [Hat Hc]") as "Hstore".
+ { rewrite -Nat.add_succ_r. rewrite additive_time_receipt_sep. iFrame. }
+ iExists _. iFrame. iApply ("HT" with "Hstore").
+ Qed.
+ Global Instance introduce_with_hooks_atime_inst E L n : IntroduceWithHooks E L (atime n) | 10 :=
+ λ T, i2p (introduce_with_hooks_atime E L n T).
+
+
+
+ (** *** Statements *)
+ (* [fn]: the surrounding function,
+ [ls]: stack (list of locations for args and local variables),
+ *)
+ Definition typed_stmt_R_t := val → iProp Σ.
+ Definition typed_stmt_post_cond (Ï€ : thread_id) (Ï : lft) (fn : runtime_function) (R : typed_stmt_R_t) (v : val) : iProp Σ :=
+ (∃ (κs : list lft),
+ (* return ownership of the stack *)
+ ([∗ list] l ∈ (fn.(rf_locs)), l.1 ↦|l.2|) ∗
+ (* return the function lifetime *)
+ llctx_interp [Ï âŠ‘â‚—{0} κs] ∗
+ (* continuation *)
+ R v)%I.
+
+ (* [Q]: the current function body,
+ [ls]: stack
+ [Ï]: the function lifetime
+
+ [R] is a relation on the result value of this statement and its type: we require that the result value is a well-typed [R]-value at this type.
+ *)
+ Definition typed_stmt (Ï€ : thread_id) (E : elctx) (L : llctx) (s : stmt) (fn : runtime_function) (R : typed_stmt_R_t) (Ï : lft) : iProp Σ :=
+ (rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ WPs s {{fn.(rf_fn).(f_code), typed_stmt_post_cond Ï€ Ï fn R}})%I.
+ Global Arguments typed_stmt _ _ _ _%E _ _%I _.
+
+ (* [P] is an invariant on the context. *)
+ Definition typed_block (Ï€ : thread_id) (P : elctx → llctx → iProp Σ) (b : label) (fn : runtime_function) (R : typed_stmt_R_t) (Ï : lft) : iProp Σ :=
+ (∀ E L, rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ P E L -∗ WPs (Goto b) {{ fn.(rf_fn).(f_code), (typed_stmt_post_cond Ï€ Ï fn R)}}).
+
+ (** for all succeeding statements [s], assuming that [v] has type [ty], it can be converted to a non-zero integer *)
+ Definition typed_assert (Ï€ : thread_id) (E : elctx) (L : llctx) (v : val) {rt} (ty : type rt) (r : rt) (s : stmt) (fn : runtime_function) (R : typed_stmt_R_t) (Ï : lft) : iProp Σ :=
+ (rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ v â—áµ¥{Ï€} r @ ty -∗ ⌜val_to_bool v = Some true⌠∗ llctx_interp L ∗ typed_stmt Ï€ E L s fn R Ï)%I.
+ Class TypedAssert (Ï€ : thread_id) (E : elctx) (L : llctx) (v : val) {rt} (ty : type rt) (r : rt) : Type :=
+ typed_assert_proof s fn R Ï : iProp_to_Prop (typed_assert Ï€ E L v ty r s fn R Ï).
+ Global Hint Mode TypedAssert + + + + + + + : typeclass_instances.
+
+ (** annotated statements are allowed to execute an update and take a step *)
+ (* TODO: make this more useful and actually use it *)
+ Definition typed_annot_stmt {A} (a : A) (T : iProp Σ) : iProp Σ :=
+ (rrust_ctx ={⊤}[∅]▷=∗ T).
+ Class TypedAnnotStmt {A} (a : A) : Type :=
+ typed_annot_stmt_proof T : iProp_to_Prop (typed_annot_stmt a T).
+ Global Hint Mode TypedAnnotStmt + + : typeclass_instances.
+
+ Definition typed_switch (Ï€ : thread_id) (E : elctx) (L : llctx) (v : val) rt (ty : type rt) (r : rt) (it : int_type) (m : gmap Z nat) (ss : list stmt) (def : stmt) (fn : runtime_function) (R : typed_stmt_R_t) (Ï : lft) : iProp Σ :=
+ (v â—áµ¥{Ï€} r @ ty -∗ ∃ z, ⌜val_to_Z v it = Some z⌠∗
+ match m !! z with
+ | Some i => ∃ s, ⌜ss !! i = Some s⌠∗ typed_stmt Ï€ E L s fn R Ï
+ | None => typed_stmt Ï€ E L def fn R Ï
+ end).
+ Class TypedSwitch (Ï€ : thread_id) (E : elctx) (L : llctx) (v : val) rt (ty : type rt) (r : rt) (it : int_type) : Type :=
+ typed_switch_proof m ss def fn R Ï : iProp_to_Prop (typed_switch Ï€ E L v rt ty r it m ss def fn R Ï).
+ Global Hint Mode TypedSwitch + + + + + + + + : typeclass_instances.
+
+
+
+ (** *** Places *)
+
+ (* This defines what place expressions can contain. We cannot reuse
+ W.ectx_item because of BinOpPCtx since there the root of the place
+ expression is not in evaluation position. *)
+ Inductive place_ectx_item :=
+ | DerefPCtx (o : order) (ot : op_type) (mc : bool)
+ | GetMemberPCtx (sls : struct_layout_spec) (m : var_name)
+ | GetMemberUnionPCtx (uls : union_layout_spec) (m : var_name)
+ | AnnotExprPCtx (n : nat) {A} (x : A)
+ (* for PtrOffsetOp, second ot must be PtrOp *)
+ | BinOpPCtx (op : bin_op) (ot : op_type) (v : val) rt (ty : type rt) (r : rt)
+ (* for ptr-to-ptr casts, ot must be PtrOp *)
+ | UnOpPCtx (op : un_op)
+ | EnumDiscriminantPCtx (els : enum_layout_spec)
+ | EnumDataPCtx (els : enum_layout_spec) (variant : var_name)
+ .
+
+ (* Computes the WP one has to prove for the place ectx_item Ki
+ applied to the location l. *)
+ Definition place_item_to_wp (π : thread_id) (Ki : place_ectx_item) (Φ : loc → iProp Σ) (l : loc) : iProp Σ :=
+ match Ki with
+ | DerefPCtx o ot mc => WP !{ot, o, mc} l {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ | GetMemberPCtx sls m => WP l at{sls} m {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ | GetMemberUnionPCtx uls m => WP l at_union{uls} m {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ | AnnotExprPCtx n x => WP AnnotExpr n x l {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ (* we have proved typed_val_expr e1 before so we can use v â—áµ¥ ty here;
+ note that the offset is on the left and evaluated first *)
+ | BinOpPCtx op ot v rt ty r => v â—áµ¥{Ï€} r @ ty -∗ WP BinOp op ot PtrOp v l {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ | UnOpPCtx op => WP UnOp op PtrOp l {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ | EnumDiscriminantPCtx els => WP EnumDiscriminant els l {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ | EnumDataPCtx els variant => WP EnumData els variant l {{ v, ∃ l' : loc, ⌜v = val_of_loc l'⌠∗ Φ l' }}
+ end%I.
+ Definition place_to_wp (π : thread_id) (K : list place_ectx_item) (Φ : loc → iProp Σ) : (loc → iProp Σ) := foldr (place_item_to_wp π) (λ v, |={⊤}=> Φ v)%I K.
+
+ Lemma fupd_place_item_to_wp π Ki Φ l :
+ (|={⊤}=> place_item_to_wp π Ki Φ l) -∗ place_item_to_wp π Ki Φ l.
+ Proof.
+ destruct Ki; simpl; iIntros "Ha"; iIntros; iApply fupd_wp; iMod "Ha"; by iApply "Ha".
+ Qed.
+ Lemma fupd_place_to_wp π K Φ l:
+ (|={⊤}=> place_to_wp π K Φ l) -∗ place_to_wp π K Φ l.
+ Proof.
+ destruct K as [ | Ki K]; simpl.
+ - by iIntros ">>$".
+ - iApply fupd_place_item_to_wp.
+ Qed.
+
+ Global Instance place_item_to_wp_proper π K :
+ Proper (pointwise_relation _ equiv ==> eq ==> equiv) (place_item_to_wp π K).
+ Proof.
+ intros Φ1 Φ2 Hequiv l l' <-.
+ destruct K; simpl.
+ 5: f_equiv.
+ all: apply wp_proper; solve_proper.
+ Qed.
+ Lemma place_to_wp_app π (K1 K2 : list place_ectx_item) Φ l :
+ place_to_wp π (K1 ++ K2) Φ l ≡ place_to_wp π K1 (place_to_wp π K2 Φ) l.
+ Proof.
+ induction K1 as [ | Ki K IH] in l |-*.
+ - simpl. iSplit; [ by eauto | ].
+ iApply fupd_place_to_wp.
+ - simpl. apply place_item_to_wp_proper; last done.
+ intros l'. by rewrite IH.
+ Qed.
+
+ Lemma place_item_to_wp_mono π K Φ1 Φ2 l:
+ place_item_to_wp π K Φ1 l -∗ (∀ l, Φ1 l -∗ Φ2 l) -∗ place_item_to_wp π K Φ2 l.
+ Proof.
+ iIntros "HP HΦ". move: K => [o ly mc|sls m|uls m |n A x|op ot v rt ty r|op | els | els variant]//=.
+ 5: iIntros "Hv".
+ 1-4,6-8: iApply (@wp_wand with "HP").
+ 8: iApply (@wp_wand with "[Hv HP]"); first by iApply "HP".
+ all: iIntros (?); iDestruct 1 as (l' ->) "HΦ1".
+ all: iExists _; iSplit => //; by iApply "HΦ".
+ Qed.
+
+ Lemma place_to_wp_mono π K Φ1 Φ2 l:
+ place_to_wp π K Φ1 l -∗ (∀ l, Φ1 l -∗ Φ2 l) -∗ place_to_wp π K Φ2 l.
+ Proof.
+ iIntros "HP HΦ".
+ iInduction (K) as [] "IH" forall (l) => /=. { by iApply "HΦ". }
+ iApply (place_item_to_wp_mono with "HP").
+ iIntros (l') "HP". by iApply ("IH" with "HP HΦ").
+ Qed.
+
+ Lemma place_to_wp_fupd π K Φ l:
+ (place_to_wp π K (λ l, |={⊤}=> Φ l) l) -∗ place_to_wp π K Φ l.
+ Proof.
+ induction K as [ | Ki K IH] in l |-*; simpl.
+ - by iIntros ">>$".
+ - iIntros "Ha". iApply (place_item_to_wp_mono with "Ha").
+ iIntros (l'). iApply IH.
+ Qed.
+
+ (* We need to take some extra care because the lifetime context may change during this operation. *)
+ Fixpoint find_place_ctx π (E : elctx) (e : W.expr) : option (llctx → (llctx → list place_ectx_item → loc → iProp Σ) → iProp Σ) :=
+ match e with
+ | W.Loc l => Some (λ L T, T L [] l)
+ | W.Deref o ot mc e =>
+ T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [DerefPCtx o ot mc]) l))
+ | W.GetMember e sls m => T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [GetMemberPCtx sls m]) l))
+ | W.GetMemberUnion e uls m => T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [GetMemberUnionPCtx uls m]) l))
+ | W.EnumDiscriminant els e => T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [EnumDiscriminantPCtx els]) l))
+ | W.EnumData els variant e => T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [EnumDataPCtx els variant]) l))
+ | W.AnnotExpr n x e => T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [AnnotExprPCtx n x]) l))
+ | W.LocInfoE a e => find_place_ctx π E e
+
+ (* Here we use the power of having a continuation available to add
+ a typed_val_expr. It is important that this happens before we get
+ to place_to_wp_mono since we will need to give up ownership of the
+ root of the place expression once we hit it. This allows us to
+ support e.g. a[a[0]]. *)
+ | W.BinOp op ot PtrOp e1 e2 =>
+ T' ↠find_place_ctx π E e2;
+ Some (λ L T, typed_val_expr π E L (W.to_expr e1) (λ L' v rt ty r, T' L' (λ L'' K l, T L'' (K ++ [BinOpPCtx op ot v rt ty r]) l)))
+ | W.UnOp op PtrOp e => T' ↠find_place_ctx π E e; Some (λ L T, T' L (λ L' K l, T L' (K ++ [UnOpPCtx op]) l))
+ (* TODO: Is the existential quantifier here a good idea or should this be a fullblown judgment? *)
+ | W.UnOp op (IntOp it) e =>
+ Some (λ L T, typed_val_expr π E L (UnOp op (IntOp it) (W.to_expr e)) (λ L' v rt ty r,
+ v â—áµ¥{Ï€} r @ ty -∗ ∃ l, ⌜v = val_of_loc l⌠∗ T L' [] l)%I)
+ | W.LValue e =>
+ Some (λ L T, typed_val_expr π E L (W.to_expr e) (λ L' v rt ty r,
+ v â—áµ¥{Ï€} r @ ty -∗ ∃ l, ⌜v = val_of_loc l⌠∗ T L' [] l)%I)
+ | _ => None
+ end.
+
+ Class IntoPlaceCtx π E (e : expr) (T : llctx → (llctx → list place_ectx_item → loc → iProp Σ) → iProp Σ) :=
+ into_place_ctx Φ Φ':
+ (⊢ ∀ L, rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ T L Φ' -∗
+ (∀ L' K l, llctx_interp L' -∗ Φ' L' K l -∗ place_to_wp π K (Φ ∘ val_of_loc) l) -∗
+ WP e {{ Φ }}).
+ Global Hint Mode IntoPlaceCtx + + + - : typeclass_instances.
+
+ Section find_place_ctx_correct.
+ Arguments W.to_expr : simpl nomatch.
+ Lemma find_place_ctx_correct E π e T:
+ find_place_ctx π E e = Some T →
+ IntoPlaceCtx π E (W.to_expr e) T.
+ Proof.
+ elim: e T => //= *.
+ all: iIntros (Φ Φ' L) "#LFT #HE HL HT HΦ'".
+ all: iApply ewp_fupd.
+ 2,3: case_match.
+ all: try match goal with
+ | H : ?x ≫= _ = Some _ |- _ => destruct x as [?|] eqn:Hsome
+ end; simplify_eq/=.
+ all: try match goal with
+ | H : context [IntoPlaceCtx _ _ _ _ ] |- _ => rename H into IH
+ end.
+ 1: iApply @wp_value; by iApply ("HΦ'" with "HL HT").
+ 1: {
+ iApply ("HT" with "LFT HE HL"). iIntros (L' rt ty v r) "HL Hv HT".
+ iDestruct ("HT" with "Hv") as (l ?) "HT". subst.
+ by iApply ("HΦ'" $! _ [] with "HL HT").
+ }
+ 4: {
+ rewrite /LValue. iApply ("HT" with "LFT HE HL"). iIntros (L' rt ty v r) "HL Hv HT".
+ iDestruct ("HT" with "Hv") as (l ?) "HT". subst.
+ by iApply ("HΦ'" $! _ [] with "HL").
+ }
+ 2: wp_bind. 1: rewrite -!/(W.to_expr _).
+ 2: iApply ("HT" with "LFT HE HL"); iIntros (L' v rt ty r) "HL Hv HT".
+ 2: iDestruct (IH with "LFT HE HL HT") as "HT" => //.
+ 2: fold W.to_expr.
+ 1, 3-8: iDestruct (IH with "LFT HE HL HT") as " HT" => //.
+ all: wp_bind; iApply "HT".
+ all: iIntros (L'' K l) "HL HT" => /=.
+ all: iDestruct ("HΦ'" with "HL HT") as "HΦ"; rewrite place_to_wp_app /=.
+ all: iApply (place_to_wp_mono with "HΦ"); iIntros (l') "HWP" => /=.
+ 8: iApply (@wp_wand with "[Hv HWP]"); first by iApply "HWP".
+ 1-7: iApply (@wp_wand with "HWP").
+ all: iIntros (?); by iDestruct 1 as (? ->) "$".
+ Qed.
+ End find_place_ctx_correct.
+
+
+ (** ** Condition on places: when is a client allowed to replace [lt] with [lt2]
+ under a context where the intersected [bor_kind] is [b]?
+ *)
+ Section fix_inner.
+ Context {rt rt2 : Type}
+ .
+
+ (** [b] is the intersection of all bor_kinds which are "above" the position affecting this place.
+ This means: [b] expresses what we can do with the place.
+ * [Shared] should not allow mutable borrowing/mutable accesses, refinement needs to stay the same (the refinement is fixed in the fractional borrow).
+ * [Uniq] allows mutation and requires no condition on the refinement.
+ * [Owned] states that there are no borrows above, only "plain" ownership.
+ That means we can do arbitrary strong updates (even changing the refinement type if we need to).
+ *)
+ Import EqNotations.
+
+ (** Condition on type changes from [lt] to [lt2] *)
+ (* NOTE Now that ltype_eq involves the refinement, maybe we should merge this with the condition on the refinement?
+ -> no. since the eq proof is used in the lifetime logic's inheritance vs in the Uniq case, we cannot fix to the current refinement, but rather need to have a proof for all refinements.
+ *)
+ Definition typed_place_cond_ty (b : bor_kind) (lt : ltype rt) (lt2 : ltype rt2) : iProp Σ :=
+ match b with
+ | Owned _ =>
+ (* TODO weaken this? *)
+ ⌜ltype_st lt = ltype_st lt2âŒ
+ | Uniq κ _ =>
+ ∃ (Heq : rt = rt2),
+ (* We could allow a disjunction here:
+ - if we actually change the place type, then we change the contents of the borrow, and we must prove that we can actually unblock the new type [lt2] in time.
+ - if we don't actually change the place type, we've proved this before, and it is fine.
+ (this isn't completely true for products: we will need sideconditions for products to handle components that don't change, because we can't just extract this from the VS again when we change one component).
+ TODO: pinned borrows actually allow to get the VS out now with the strong accessor, so there should be nothing stopping us from allowing this.
+ *)
+ (∀ b r, ltype_eq b r r (ltype_core lt) (ltype_core (rew <- [ltype] Heq in lt2))) ∗ imp_unblockable [κ] lt2
+
+ (* ∨ ⌜lt = rew <- [lty] Heq in lt2⌠*)
+ | Shared κ =>
+ (* TODO: Is this is too strict? It does not directly allow shared reborrows below shared references.
+ Maybe change this to [ltype_incl lt2 lt]?
+ OTOH, it's not really clear that that would be the right way to model shared reborrows...
+ *)
+ ∃ (Heq: rt = rt2),
+ ( ∀ b r, ltype_eq b r r lt (rew <- [ltype] Heq in lt2)) ∗ imp_unblockable [κ] lt2
+ end%I.
+
+ (** Condition on the refinement *)
+ Definition typed_place_cond_rfn (b : bor_kind) (r : place_rfn rt) (r2 : place_rfn rt2) : iProp Σ :=
+ match b with
+ | Shared _ =>
+ ∃ (Heq: rt = rt2), ⌜rew <- [place_rfn] Heq in r2 = râŒ
+ | _ => True
+ end%I.
+
+ (** Combined condition *)
+ Definition typed_place_cond (b : bor_kind) (lt : ltype rt) (lt2 : ltype rt2) (r : place_rfn rt) (r2 : place_rfn rt2) : iProp Σ :=
+ typed_place_cond_ty b lt lt2 ∗ typed_place_cond_rfn b r r2.
+
+ Global Instance typed_place_cond_ty_pers b lt lt2 :
+ Persistent (typed_place_cond_ty b lt lt2).
+ Proof. destruct b; apply _. Qed.
+ Global Instance typed_place_cond_pers b lt1 lt2 r1 r2 :
+ Persistent (typed_place_cond b lt1 lt2 r1 r2).
+ Proof. destruct b; apply _. Qed.
+
+ Lemma typed_place_cond_incl b1 b2 r1 r2 lt1 lt2 :
+ b1 ⊑ₖ b2 -∗ typed_place_cond b1 lt1 lt2 r1 r2 -∗ typed_place_cond b2 lt1 lt2 r1 r2.
+ Proof using Type*.
+ iIntros "? [Hcond Hrfn]//". iSplit.
+ + destruct b1, b2; simpl; try done.
+ - iDestruct "Hcond" as (<-) "(Ha & _)".
+ iDestruct ("Ha" $! inhabitant inhabitant) as "((#$ & _) & _)".
+ - iDestruct "Hcond" as (<-) "(Heq & Hub)"; cbn in *.
+ iExists eq_refl. cbn. iFrame.
+ iApply (imp_unblockable_shorten' with "[$] Hub").
+ - iDestruct "Hcond" as (<-) "Heq"; cbn in *.
+ iDestruct "Heq" as "(Heq & Hub)". iExists eq_refl.
+ iSplitL "Heq".
+ * iIntros (b r). iApply ltype_eq_core. done.
+ * iApply (imp_unblockable_shorten' with "[$] Hub").
+ - iDestruct "Hcond" as (<-) "(Ha & _)".
+ iDestruct ("Ha" $! inhabitant inhabitant) as "(( #Hly & _) & _)".
+ rewrite !ltype_core_syn_type_eq. done.
+ - iDestruct "Hcond" as (<-) "(Heq & Hub)"; cbn in *.
+ iExists eq_refl. cbn. iFrame.
+ iApply (imp_unblockable_shorten' with "[$] Hub").
+ + destruct b1, b2; done.
+ Qed.
+ End fix_inner.
+
+ Lemma typed_place_cond_rfn_trans {rt1 rt2 rt3} bmin (r1 : place_rfn rt1) (r2 : place_rfn rt2) (r3 : place_rfn rt3) :
+ typed_place_cond_rfn bmin r1 r2 -∗ typed_place_cond_rfn bmin r2 r3 -∗ typed_place_cond_rfn bmin r1 r3 : iProp Σ.
+ Proof.
+ iIntros "H1 H2". destruct bmin; simpl; [done | | done].
+ iDestruct "H1" as "(%Heq1 & %Ha)".
+ iDestruct "H2" as "(%Heq2 & %Hb)".
+ subst. iExists eq_refl. done.
+ Qed.
+ Lemma typed_place_cond_ty_trans {rt1 rt2 rt3} (lt1 : ltype rt1) (lt2 : ltype rt2) (lt3 : ltype rt3) b :
+ typed_place_cond_ty b lt1 lt2 -∗
+ typed_place_cond_ty b lt2 lt3 -∗
+ typed_place_cond_ty b lt1 lt3 .
+ Proof.
+ destruct b; simpl.
+ - iIntros "% % !%". congruence.
+ - iIntros "(%Heq & Heq & Hub) (%Heq' & Heq' & Hub')". subst.
+ iExists eq_refl. iFrame. iIntros (b r). iApply (ltype_eq_trans with "Heq Heq'").
+ - iIntros "(%Heq & Heq & Hub) (%Heq' & Heq' & Hub')".
+ subst.
+ iExists eq_refl. iFrame. cbn.
+ iIntros (b r). iApply (ltype_eq_trans with "Heq Heq'").
+ Qed.
+ Lemma typed_place_cond_trans {rt1 rt2 rt3} r1 r2 r3 (lt1 : ltype rt1) (lt2 : ltype rt2) (lt3 : ltype rt3) b :
+ typed_place_cond b lt1 lt2 r1 r2 -∗
+ typed_place_cond b lt2 lt3 r2 r3 -∗
+ typed_place_cond b lt1 lt3 r1 r3.
+ Proof.
+ iIntros "(Ht1 & Hr1) (Ht2 & Hr2)". iSplit.
+ - iApply (typed_place_cond_ty_trans with "Ht1 Ht2").
+ - iApply (typed_place_cond_rfn_trans with "Hr1 Hr2").
+ Qed.
+
+ Lemma imp_unblockable_incl_blocked_lfts {rt} κ (lt : ltype rt) :
+ ([∗ list] κ' ∈ ltype_blocked_lfts lt, κ' ⊑ κ) -∗
+ imp_unblockable [κ] lt.
+ Proof.
+ iIntros "#Houtl".
+ iApply (imp_unblockable_shorten with "[Houtl]"); last iApply imp_unblockable_blocked_dead.
+ iModIntro. iIntros "(#Hdead & _)".
+ iApply big_sepL_fupd. iApply big_sepL_intro.
+ iIntros "!>" (? κ' Hlook). iPoseProof (big_sepL_lookup with "Houtl") as "Hincl"; first done.
+ iApply (lft_incl_dead with "Hincl Hdead"). done.
+ Qed.
+
+ (** Requires a sidecondition to make sure we can actually do the unblocking. *)
+ (* NOTE: if we were to revise the use of unblocking and have a disjunct to just show ltype_eq instead of unblockable, we could get rid of the sidecondition *)
+ Lemma typed_place_cond_ty_refl {rt} b (lt : ltype rt) :
+ ([∗ list] κ' ∈ ltype_blocked_lfts lt, bor_kind_outlives b κ') -∗
+ typed_place_cond_ty b lt lt.
+ Proof.
+ iIntros "#Houtl".
+ destruct b => /=.
+ - by iPureIntro.
+ - iExists eq_refl. cbn. iSplitR.
+ { iIntros (??). iApply ltype_eq_refl. }
+ by iApply imp_unblockable_incl_blocked_lfts.
+ - iExists eq_refl. cbn. iSplitR.
+ { iIntros (??). iApply ltype_eq_refl. }
+ by iApply imp_unblockable_incl_blocked_lfts.
+ Qed.
+ Lemma typed_place_cond_refl {rt} b r (lt : ltype rt) :
+ ([∗ list] κ' ∈ ltype_blocked_lfts lt, bor_kind_outlives b κ') -∗
+ typed_place_cond b lt lt r r.
+ Proof.
+ iIntros "Huniq". iSplit.
+ + by iApply typed_place_cond_ty_refl.
+ + destruct b => //. iExists eq_refl. done.
+ Qed.
+
+ Lemma typed_place_cond_ty_refl_ofty {rt} b (ty : type rt) :
+ ⊢ typed_place_cond_ty b (◠ty)%I (◠ty)%I.
+ Proof.
+ iApply typed_place_cond_ty_refl. done.
+ Qed.
+
+ Lemma typed_place_cond_ty_syn_type_eq {rt1 rt2} b (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ typed_place_cond_ty b lt1 lt2 -∗
+ ⌜ltype_st lt1 = ltype_st lt2âŒ.
+ Proof.
+ iIntros "Hcond". destruct b; simpl.
+ - done.
+ - iDestruct "Hcond" as "(%Heq & Heq & _)". subst. cbn.
+ iDestruct ("Heq" $! inhabitant inhabitant) as "((#$ & _) & _)".
+ - iDestruct "Hcond" as "(%Heq & [Heq Hub])".
+ iDestruct ("Heq" $! inhabitant inhabitant) as "((%Hly & _) & _)". subst; cbn in *.
+ rewrite !ltype_core_syn_type_eq in Hly. iPureIntro. done.
+ Qed.
+ Lemma typed_place_cond_syn_type_eq {rt1 rt2} b (lt1 : ltype rt1) (lt2 : ltype rt2) r1 r2 :
+ typed_place_cond b lt1 lt2 r1 r2 -∗
+ ⌜ltype_st lt1 = ltype_st lt2âŒ.
+ Proof.
+ iIntros "(Ha & _)". by iApply typed_place_cond_ty_syn_type_eq.
+ Qed.
+
+ (* controls conditions on refinement type changes *)
+ Definition place_access_rt_rel (bmin : bor_kind) (rt1 rt2 : Type) :=
+ match bmin with
+ | Owned _ => True
+ | _ => rt1 = rt2
+ end.
+ Lemma place_access_rt_rel_refl bmin rt : place_access_rt_rel bmin rt rt.
+ Proof. by destruct bmin. Qed.
+
+ Lemma typed_place_cond_rfn_lift b {rt rto} (r1 : place_rfn rt) (r2 : place_rfn rt) (f : place_rfn rt → place_rfn rto):
+ typed_place_cond_rfn b r1 r2 -∗
+ typed_place_cond_rfn b (f r1) (f r2).
+ Proof.
+ destruct b; try by auto. iIntros "(%Hrefl & Ha)".
+ rewrite (UIP_refl _ _ Hrefl). cbn.
+ iDestruct "Ha" as "->". iExists eq_refl. done.
+ Qed.
+ Lemma typed_place_cond_rfn_refl b {rt} (r : place_rfn rt) :
+ ⊢ typed_place_cond_rfn b r r.
+ Proof.
+ destruct b => //. iExists eq_refl. done.
+ Qed.
+
+ Lemma place_cond_ty_Uniq_rt_eq {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) k κ γ :
+ k ⊑ₖ Uniq κ γ -∗
+ typed_place_cond_ty k lt1 lt2 -∗
+ ⌜rt1 = rt2âŒ.
+ Proof.
+ iIntros "Hincl Hcond".
+ destruct k; simpl; first done.
+ (* TODO why does the following not work? *)
+ (*all: iDestruct "Hcond" as "(%Heq & _)". *)
+ all: iDestruct "Hcond" as "(%Heq & Ha)"; iClear "Ha"; by done.
+ Qed.
+ Lemma place_cond_ty_Shared_rt_eq {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) k κ :
+ k ⊑ₖ Shared κ -∗
+ typed_place_cond_ty k lt1 lt2 -∗
+ ⌜rt1 = rt2âŒ.
+ Proof.
+ iIntros "Hincl Hcond".
+ destruct k; simpl; [done | | done].
+ iDestruct "Hcond" as "(%Heq & Ha)"; iClear "Ha"; by done.
+ Qed.
+
+ (* NOTE: if put the ltype_eq disjunct for the Uniq case into typed_place_cond,
+ then we would get a direct subsumption lemma. *)
+ Lemma ltype_eq_place_cond_ty_trans {rt rt2} (lt1 lt2 : ltype rt) (lt3 : ltype rt2) b :
+ (∀ b' r, ltype_eq b' r r lt1 lt2) -∗
+ typed_place_cond_ty b lt2 lt3 -∗
+ typed_place_cond_ty b lt1 lt3.
+ Proof.
+ iIntros "Heq Hc".
+ destruct b; simpl.
+ - iDestruct "Hc" as "<-". iDestruct ("Heq" $! inhabitant inhabitant) as "((#$ & _) & _)".
+ - iDestruct "Hc" as "(%Heq & Heq' & Hub')". subst. iExists eq_refl.
+ iFrame. iIntros (??). iApply (ltype_eq_trans with "Heq Heq'").
+ - iDestruct "Hc" as "(%Heq & Heq' & $)". subst. iExists eq_refl.
+ iIntros (??).
+ iPoseProof (ltype_eq_core with "Heq") as "Heq".
+ iApply (ltype_eq_trans with "Heq Heq'").
+ Qed.
+ Lemma place_cond_ty_ltype_eq_trans b {rt1 rt2} (lt1 : ltype rt1) (lt2 lt3 : ltype rt2) :
+ typed_place_cond_ty b lt1 lt2 -∗
+ (∀ b' r, ltype_eq b' r r lt2 lt3) -∗
+ typed_place_cond_ty b lt1 lt3.
+ Proof.
+ iIntros "Hcond #Heq".
+ destruct b; simpl.
+ - iPoseProof (ltype_eq_syn_type inhabitant inhabitant with "Heq") as "->". done.
+ - iDestruct "Hcond" as "(%Heq & #Heq2 & Hub)". subst rt2.
+ iExists eq_refl.
+ iSplitR. { iIntros (??). iApply ltype_eq_trans; done. }
+ iApply ltype_eq_imp_unblockable; done.
+ - iDestruct "Hcond" as "(%Heq & #Heq2 & Hub)". subst rt2.
+ iExists eq_refl.
+ iSplitR. { iIntros (??). iPoseProof (ltype_eq_core with "Heq") as "Heq'". iApply ltype_eq_trans; done. }
+ iApply ltype_eq_imp_unblockable; done.
+ Qed.
+ Lemma ltype_eq_place_cond_trans {rt rt2} (lt1 lt2 : ltype rt) (lt3 : ltype rt2) b r r' :
+ (∀ b' r, ltype_eq b' r r lt1 lt2) -∗
+ typed_place_cond b lt2 lt3 r r' -∗
+ typed_place_cond b lt1 lt3 r r'.
+ Proof.
+ iIntros "Heq (Hc & Hr)". iSplit; last done.
+ iApply (ltype_eq_place_cond_ty_trans with "Heq Hc").
+ Qed.
+
+ Lemma typed_place_cond_ltype_eq_ofty {rt rt2} (lt1 : ltype rt) (lt2 : ltype rt2) (ty3 : type rt2) b r r' :
+ typed_place_cond b lt1 lt2 r r' -∗
+ (∀ b' r, ltype_eq b' r r lt2 (◠ty3)%I) -∗
+ typed_place_cond b lt1 (â— ty3)%I r r'.
+ Proof.
+ iIntros "[Hc Hr] Heq". iSplit; last done.
+ destruct b; simpl.
+ - iDestruct "Hc" as "->". iDestruct ("Heq" $! inhabitant inhabitant) as "((#$ & _) & _)".
+ - iDestruct "Hc" as "(%Heq & Heq' & Hub)".
+ destruct Heq. iExists eq_refl. cbn. iSplitL.
+ { iIntros (??). iApply (ltype_eq_trans with "Heq' Heq"). }
+ iApply ofty_imp_unblockable.
+ - iDestruct "Hc" as "(%Heq & Heq' & Hub)". destruct Heq. iExists eq_refl. cbn.
+ iSplitL. {
+ iIntros (??).
+ iApply (ltype_eq_trans with "Heq'").
+ iApply (ltype_eq_core _ _ _ _ (â— _)%I). done.
+ }
+ iApply ofty_imp_unblockable.
+ Qed.
+
+ (** We can mutably borrow from the place, assuming that the ownership [b] of the place is at least Uniq κ. *)
+ Lemma ofty_blocked_place_cond_ty b κ {rt} (ty : type rt) :
+ (∀ γ, Uniq κ γ ⊑ₖ b) -∗
+ typed_place_cond_ty b (◠ty)%I (BlockedLtype ty κ).
+ Proof.
+ destruct b; simpl.
+ - iIntros "_". done.
+ - iIntros "Ha". iDestruct ("Ha" $! 1%positive) as "[]".
+ - iIntros "Hincl". iDestruct ("Hincl" $! 1%positive) as "Hincl".
+ iExists eq_refl. cbn. iSplitR.
+ + simp_ltypes. iIntros (??). iApply ltype_eq_refl.
+ + iApply (imp_unblockable_shorten' with "Hincl"). iApply blocked_imp_unblockable.
+ Qed.
+
+ (** TODO: this should only require [b] to be [Shared κ], in order to allow shared reborrows from shared references?
+ Alternatively, maybe shared reborrows below shared references require special handling.
+ They can also be justified by just copying the sharing predicate from the place?
+ *)
+ Lemma ofty_shr_blocked_place_cond_ty b κ {rt} (ty : type rt) :
+ (∀ γ, Uniq κ γ ⊑ₖ b) -∗
+ typed_place_cond_ty b (◠ty)%I (ShrBlockedLtype ty κ).
+ Proof.
+ destruct b; simpl.
+ - iIntros "_". done.
+ - iIntros "Ha". iDestruct ("Ha" $! 1%positive) as "[]".
+ - iIntros "Hincl". iDestruct ("Hincl" $! 1%positive) as "Hincl".
+ iExists eq_refl. cbn. iSplitR.
+ + simp_ltypes. iIntros (??). iApply ltype_eq_refl.
+ + iApply (imp_unblockable_shorten' with "Hincl"). iApply shr_blocked_imp_unblockable.
+ Qed.
+
+ (* TODO later on generalize this to also capture condition on when we are allowed to do strong updates/
+ change the refinement type *)
+ Definition bor_kind_writeable (b : bor_kind) :=
+ match b with
+ | Owned _ => True
+ | Uniq _ _ => True
+ | Shared _ => False
+ end.
+ Definition bor_kind_strongly_writeable (b : bor_kind) :=
+ match b with
+ | Owned _ => True
+ | Uniq _ _ => False
+ | Shared _ => False
+ end.
+
+ Record weak_ctx (rto rti : Type) : Type := mk_weak {
+ weak_lt : (ltype rti → place_rfn rti → ltype rto);
+ weak_rfn : (place_rfn rti → place_rfn rto);
+ weak_R : (ltype rti → place_rfn rti → iProp Σ)
+ }.
+ Global Arguments weak_lt {_ _}.
+ Global Arguments weak_rfn {_ _}.
+ Global Arguments weak_R {_ _}.
+ Global Arguments mk_weak {_ _}.
+ Add Printing Constructor weak_ctx.
+
+ Record strong_ctx (rti : Type) : Type := mk_strong {
+ strong_rt : Type → Type;
+ strong_lt : (∀ rti2, ltype rti2 → place_rfn rti2 → ltype (strong_rt rti2));
+ strong_rfn : (∀ rti2, place_rfn rti2 → place_rfn (strong_rt rti2));
+ strong_R : (∀ rti2, ltype rti2 → place_rfn rti2 → iProp Σ)
+ }.
+ Global Arguments strong_rt {_}.
+ Global Arguments strong_lt {_}.
+ Global Arguments strong_rfn {_}.
+ Global Arguments strong_R {_}.
+ Global Arguments mk_strong {_}.
+ Add Printing Constructor strong_ctx.
+
+ (* TODO: change typed_place to use mstrong_ctx instead. Then we can also do OpenedLtype unfolding below arrays *)
+ Record mstrong_ctx (rti rto : Type) : Type := mk_mstrong {
+ (* rt-changing *)
+ mstrong_strong : option (strong_ctx rti);
+ (* non-rt-changing *)
+ mstrong_weak : weak_ctx rti rto;
+ }.
+ (* Note: this gives us three distinct update modes, and we cannot subsume one into the other, because all of this is invariant. *)
+
+
+ (* Problem with the current approach is just that I can't practically use the result of the boolean flag
+ -- I can't state the tctx without without the equality proof.
+ The alternative is that this should be directly embedded in the strong continuation.
+ *)
+
+ (*
+ Parameters:
+ - [Ï€]: thread id
+ - [E]: external lifetime context
+ - [L]: local lifetime context
+ - [l1]: location that we access
+ - [ltyo]: ltype of [l1]
+ - [r1]: refinement of [ltyo] at [l1]
+ - [bmin0]: the intersection of all [bor_kind]s of places above this one on the way of the access
+ - [b1]: the immediate [bor_kind] at which [ltyo] is owned
+ - [P]: place ctx, the accesses that we go through
+ - [T]: client continuation, with the following arguments:
+ + [L' : llctx]: the new local lifetime context
+ + [κs] : lifetimes for which we have obtained tokens to access the place
+ + [l2 : loc] : inner location that is acessed by the place access (the "result")
+ + [b2 : bor_kind] : inner [bor_kind] at which the accessed place is immediately owned
+ + [bmin : bor_kind] : the intersection of all [bor_kind]s on the way to [l2]
+ + [br] : true if the place requires the refinement type to be unchanged
+ + [rti : Type] : refinement type of [l2]
+ + [tyli : lty rti] : the ltype at [l2]
+ + [rti : place_rfn rti] : the refinement of [tyli]
+ + [strong : option (strong_ctx rti)] : describes how an update to the accessed place at [l2] is reflected in an update to [l1] in case we need to do a strong refinement update
+ + [weak : option (weak_ctx rto rti)] : describes how an update to the accessed place at [l2] is reflected in an update to [l1] in case do a weak update.
+
+
+ Note that the [strong] and [weak] options are incomparable. [weak] does not only give stronger assumptions, but also requires giving stronger guarantees, which not all place types can do.
+ In particular, [OpenedLtype] can not guarantee that an update will uphold the contract of the place it is nested under, so it cannot support [weak] updates.
+ *)
+ Definition place_cont_t rto : Type := llctx → list lft → loc → bor_kind → bor_kind → ∀ rti, ltype rti → place_rfn rti → option (strong_ctx rti) → option (weak_ctx rto rti) → iProp Σ.
+ Definition typed_place π (E : elctx) (L : llctx) (l1 : loc) {rto} (ltyo : ltype rto) (r1 : place_rfn rto) (bmin0 : bor_kind) (b1 : bor_kind) (P : list place_ectx_item) (T : place_cont_t rto) : iProp Σ :=
+ (∀ Φ F, ⌜lftE ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (* [bmin0] is the intersection of all bor_kinds to this place, including [b1] *)
+ bmin0 ⊑ₖ b1 -∗
+ (* assume ownership of l1 *)
+ l1 â—â‚—[Ï€, b1] r1 @ ltyo -∗
+ (* precondition provided by the client that we necessarily need to go through to get Φ *)
+ (∀ (L' : llctx) (κs : list lft) (l2 : loc) (b2 bmin : bor_kind) (rti : Type) (ltyi : ltype rti) (ri : place_rfn rti)
+ (strong : option (strong_ctx rti))
+ (weak : option (weak_ctx rto rti)),
+ (* sanity check *)
+ (*bmin ⊑ₖ bmin0 -∗*)
+ bmin ⊑ₖ b2 -∗
+ (* l2 is the inner location we eventually access, provide that to the client *)
+ l2 â—â‚—[Ï€, b2] ri @ ltyi -∗
+
+ (* for any update to l2 by the client, we need to update our "outer" place accordingly: *)
+ (* we have a conjunction: the client can choose to do a strong, refinement-type changing update, or a weak update *)
+ (match strong with | Some strong =>
+ ∀ (rti2 : Type) (ltyi2 : ltype rti2) (ri2 : place_rfn rti2),
+ (* assume an update by the client *)
+ l2 â—â‚—[Ï€, b2] ri2 @ ltyi2 -∗
+ (* needs to have the same st *)
+ ⌜ltype_st ltyi = ltype_st ltyi2⌠={F}=∗
+ (* provide the updated ownership of l1 *)
+ l1 â—â‚—[Ï€, b1] (strong.(strong_rfn) rti2 ri2) @ strong.(strong_lt) rti2 ltyi2 ri2 ∗
+ (* and a proof that the "outer" update is legal *)
+ ⌜ltype_st ltyo = ltype_st (strong.(strong_lt) rti2 ltyi2 ri2)⌠∗
+ (* as well as a "remaining" ownership that we get out from the update *)
+ strong.(strong_R) rti2 ltyi2 ri2
+ | None => True
+ end) ∧
+
+ (* weak update *)
+ (match weak with | Some weak =>
+ ∀ (ltyi2 : ltype rti) (ri2 : place_rfn rti) (bmin' : bor_kind),
+ (* the update made by the client is allowed by the intersected bmin *)
+ bmin' ⊑ₖ bmin -∗
+ (* assume an update by the client *)
+ l2 â—â‚—[Ï€, b2] ri2 @ ltyi2 -∗
+ (* we can assume that the update by the client obeys the intersected kind bmin along the current path *)
+ typed_place_cond bmin' ltyi ltyi2 ri ri2 ={F}=∗
+ (* provide the updated ownership of l1 *)
+ l1 â—â‚—[Ï€, b1] (weak.(weak_rfn) ri2) @ weak.(weak_lt) ltyi2 ri2 ∗
+ (* and a proof that the "outer" update is legal *)
+ typed_place_cond bmin0 ltyo (weak.(weak_lt) ltyi2 ri2) r1 (weak.(weak_rfn) ri2) ∗
+ (* the tokens for the lifetime *)
+ llft_elt_toks κs ∗
+ (* as well as a "remaining" ownership that we get out from the update *)
+ weak.(weak_R) ltyi2 ri2
+ | None => True
+ end) -∗
+
+ (* provide the continuation condition *)
+ T L' κs l2 b2 bmin rti ltyi ri strong weak -∗
+ (* and the context: we hand the client the new context [L'] *)
+ llctx_interp L' -∗
+ (* then we can assume the postcondition *)
+ Φ l2) -∗
+ place_to_wp π P Φ l1).
+
+ (** Instances need to have priority >= 10, the ones below are reserved for ghost resolution, id, etc. *)
+ Class TypedPlace E L π l1 {rto} (ltyo : ltype rto) (r1 : place_rfn rto) (bmin0 b1 : bor_kind) (P : list place_ectx_item) : Type :=
+ typed_place_proof T : iProp_to_Prop (typed_place π E L l1 ltyo r1 bmin0 b1 P T).
+ Global Hint Mode TypedPlace + + + + + + + + + + : typeclass_instances.
+
+ Import EqNotations.
+ Lemma typed_place_id {rt} π E L (lt : ltype rt) bmin0 b r l (T : place_cont_t rt) :
+ ⌜lctx_bor_kind_incl E L bmin0 b⌠∗ T L [] l b bmin0 rt lt r (Some $ mk_strong id (λ _ lti2 _, lti2) (λ _ , id) (λ _ _ _, True)) (Some $ mk_weak (λ lti2 _, lti2) id (λ _ _, True))
+ ⊢ typed_place π E L l lt r bmin0 b [] T.
+ Proof.
+ iIntros "(%Hincl & Hs)" (Φ F ??). iIntros "#LFT #HE HL Hincl0 HP HΦ /=".
+ iPoseProof (lctx_bor_kind_incl_use with "HE HL") as "#Hincl"; first apply Hincl.
+ iSpecialize ("HΦ" $! _ _ _ _ _ _ _ _ _ _ with "[] HP").
+ { iApply "Hincl". }
+ iApply ("HΦ" with "[] Hs HL").
+ iSplit.
+ - iIntros (rti2 tyli2 ri2) "Hl Hcond" => /=. iFrame. done.
+ - iIntros (tyli2 ri2 bmin') "Hincl' Hl Hcond" => /=. iFrame.
+ iSplitL. { iApply (typed_place_cond_incl with "Hincl' Hcond"). }
+ rewrite /llft_elt_toks.
+ iSplitR; first iApply big_sepL_nil; done.
+ Qed.
+ Global Instance typed_place_id_inst {rt} π E L (lt : ltype rt) bmin0 b r l :
+ TypedPlace E L π l lt r bmin0 b [] | 9 := λ T, i2p (typed_place_id π E L lt bmin0 b r l T).
+
+ Lemma typed_place_eqltype {rto} π E L (lt1 lt2 : ltype rto) bmin0 b r l P T :
+ full_eqltype E L lt1 lt2 →
+ typed_place π E L l lt2 r bmin0 b P T -∗
+ typed_place π E L l lt1 r bmin0 b P T.
+ Proof.
+ iIntros (Heq) "Hp". iIntros (????) "#CTX #HE HL Hincl0 Hl HΦ".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; [apply Heq | ].
+ iDestruct ("Heq" $! b r) as "[Hi1 _]".
+ iApply fupd_place_to_wp.
+ iMod (ltype_incl_use with "Hi1 Hl") as "Hl"; first done. iModIntro.
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+
+ iApply ("Hp" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hincl0 Hl").
+ iIntros (L' κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hl2 Hs HT HL".
+ iApply ("HΦ" $! _ _ _ _ _ _ _ _ with "Hincl1 Hl2 [Hs] HT HL").
+ iSplit.
+ - destruct strong as [ strong | ]; last done.
+ iIntros (rti2 tyli2 ri2) "Hl2 %Hcond". iDestruct "Hs" as "[Hs _]".
+ iMod ("Hs" with "Hl2 [//]") as "(Hl & %Hcond2 & HR)".
+ iFrame. iModIntro.
+ iDestruct ("Hi1") as "(-> & _)".
+ iPureIntro. rewrite -Hcond2. done.
+ - destruct weak as [ weak | ]; last done.
+ iIntros (tyli2 ri2 bmin') "Hincl Hl2 Hcond". iDestruct "Hs" as "[_ Hs]".
+ iMod ("Hs" with "Hincl Hl2 Hcond") as "(Hl & Hcond & Htoks & HR)".
+ iFrame. iModIntro.
+ iApply ltype_eq_place_cond_trans; last done.
+ iApply "Heq".
+ Qed.
+ (* intentionally not an instance -- since [eqltype] is transitive, that would not be a good idea. *)
+
+ (** Fold an [lty] to a [type].
+ This is usually used after accessing a place, to push the â— to the outside again.
+ *)
+ (* TODO: consider replacing this with a tactic hint *)
+ Definition cast_ltype_to_type E L {rt} (lt : ltype rt) (T : type rt → iProp Σ) : iProp Σ :=
+ ∃ ty, ⌜full_eqltype E L lt (◠ty)⌠∗ T ty.
+ Class CastLtypeToType {rt} (E : elctx) (L : llctx) (lt : ltype rt) : Type :=
+ cast_ltype_to_type_proof T : iProp_to_Prop (cast_ltype_to_type E L lt T).
+ Global Hint Mode CastLtypeToType + + + + : typeclass_instances.
+
+ (** Update the refinement of an [ltype]. If [lb = true], this can take a logical step and thus descend below other types.
+ On the other hand, if [lb = false], this should only do an update at the top-level.
+ User-defined ADTs should provide an instance of this if they provide means of borrowing below their abstraction-level.
+
+ [R] is additional ownership that will be available after the (optional) logical step. We usually use this to return lifetime tokens that we first take, e.g. when resolving below a borrow.
+ (We need this because we need to return the lifetime context immediately (not below the logical step) in order to support parallel operation when stratifying products.) *)
+ (** [ResolveAll] will fail if we cannot resolve some variable. [ResolveTry] will just leave a [PlaceGhost] if we cannot resolve it. *)
+ Inductive ResolutionMode := ResolveAll | ResolveTry.
+ Definition resolve_ghost {rt} π E L (rm : ResolutionMode) (lb : bool) l (lt : ltype rt) b (r : place_rfn rt) (T : llctx → place_rfn rt → iProp Σ → bool → iProp Σ) : iProp Σ :=
+ ∀ F,
+ ⌜lftE ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ l â—â‚—[Ï€, b] r @ lt ={F}=∗
+ ∃ L' r' R progress,
+ maybe_logical_step lb F (l â—â‚—[Ï€, b] r' @ lt ∗ R) ∗
+ llctx_interp L' ∗ T L' r' R progress.
+ Class ResolveGhost {rt} π E L rm lb l (lt : ltype rt) b γ : Type :=
+ resolve_ghost_proof T : iProp_to_Prop (resolve_ghost π E L rm lb l lt b γ T).
+ Global Hint Mode ResolveGhost + + + + + + + + + + : typeclass_instances.
+
+ Inductive FindObsMode : Set :=
+ | FindObsModeDirect
+ | FindObsModeRel.
+ Definition find_observation_cont_t (rt : Type) : Type := option rt → iProp Σ.
+ Definition find_observation (rt : Type) (γ : gname) (m : FindObsMode) (T : find_observation_cont_t rt) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ |={F}=> (∃ r : rt, gvar_pobs γ r ∗ T (Some r)) ∨ T None.
+ Class FindObservation (rt : Type) (γ : gname) (m : FindObsMode) : Type :=
+ find_observation_proof T : iProp_to_Prop (find_observation rt γ m T).
+ Global Hint Mode FindObservation + + + : typeclass_instances.
+
+
+ (** *** Stratification: unfold, unblock, and fold an ltype. *)
+ (** Determines whether we descend below references.
+ [StratMutStrong] will only descend below places with strong ownership mode (no references).
+ [StratMutWeak] will also descend below mutable references.
+ [StratMutNone] will in addition descend below shared references. *)
+ Inductive StratifyMutabilityMode :=
+ | StratMutStrong
+ | StratMutWeak
+ | StratMutNone
+ .
+ Global Instance StratifyMutabilityMode_eqdec : EqDecision StratifyMutabilityMode.
+ Proof. solve_decision. Defined.
+
+ (** Unfold ltypes upon descending or treat â— as a leaf? *)
+ Inductive StratifyDescendUnfoldMode :=
+ | StratDoUnfold
+ | StratNoUnfold
+ .
+ Global Instance StratifyDescendUnfoldMode_eqdec : EqDecision StratifyDescendUnfoldMode.
+ Proof. solve_decision. Defined.
+
+ (** Fold ltypes when ascending? *)
+ Inductive StratifyAscendMode :=
+ | StratRefoldFull (* failure if it cannot be folded to a [â— ty] *)
+ | StratRefoldOpened (* need to fold at least all [OpenedLtype]s, but keeping blocked places is okay. *)
+ | StratNoRefold (* don't even try to fold *)
+ .
+ Global Instance StratifyAscendMode_eqdec : EqDecision StratifyAscendMode.
+ Proof. solve_decision. Defined.
+
+ (** Stratification is parameterized by four flags (that don't have any semantic meaning, but guide the automation):
+ - [mu] determines whether it should descend below references.
+ - [mdu] determines whether it should unfold ltypes upon descending or treat â— as a leaf.
+ - [ma] determines whether ltypes are folded on ascending.
+ - [ml] determines the operation at leaf nodes. This is generic, as it is determined by the concrete operation we take.
+
+ Note that stratification is not parameterized by a [bmin] giving the allowed updates at the current place.
+ This is motivated by the fact that our operations should anyways not be influenced by how the place is owned - we have one canonical shape the type should get into.
+ Instead, we prove the corresponding [typed_place_cond] condition after the fact, where needed.
+ *)
+ Definition stratify_ltype_cont_t := llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ.
+ Definition stratify_ltype {rt} (Ï€ : thread_id) (E : elctx) (L : llctx) (mu : StratifyMutabilityMode) (mdu : StratifyDescendUnfoldMode)
+ (ma : StratifyAscendMode) {M} (ml : M) (l : loc) (lt : ltype rt) (r : place_rfn rt) (b : bor_kind)
+ (T : stratify_ltype_cont_t) : iProp Σ :=
+ ∀ F,
+ ⌜lftE ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ l â—â‚—[Ï€, b] r @ lt ={F}=∗
+ ∃ L' R (rt' : Type) (lt' : ltype rt') (r' : place_rfn rt'),
+ llctx_interp L' ∗
+ ⌜ltype_st lt = ltype_st lt'⌠∗
+ logical_step F (l â—â‚—[Ï€, b] r' @ lt' ∗ R) ∗
+ T L' R rt' lt' r'.
+
+ Class StratifyLtype {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : place_rfn rt) b : Type :=
+ stratify_ltype_proof T : iProp_to_Prop (stratify_ltype π E L mu mdu ma ml l lt r b T).
+ Global Hint Mode StratifyLtype + + + + + + + + + + + + + : typeclass_instances.
+
+ (** Post-hook that is run after stratification visits a node.
+ This is intended to be overridden by different stratification clients, depending on [ml]. *)
+ Definition stratify_ltype_post_hook_cont_t := llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ.
+ Definition stratify_ltype_post_hook {rt} (π : thread_id) (E : elctx) (L : llctx) {M} (ml : M) (l : loc) (lt : ltype rt) (r : place_rfn rt) (b : bor_kind) (T : stratify_ltype_post_hook_cont_t) : iProp Σ :=
+ ∀ F,
+ ⌜lftE ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ l â—â‚—[Ï€, b] r @ lt ={F}=∗
+ ∃ L' R (rt' : Type) (lt' : ltype rt') (r' : place_rfn rt'),
+ llctx_interp L' ∗
+ ⌜ltype_st lt = ltype_st lt'⌠∗
+ l â—â‚—[Ï€, b] r' @ lt' ∗ R ∗
+ T L' R rt' lt' r'.
+ Class StratifyLtypePostHook {rt} π E L {M} (ml : M) l (lt : ltype rt) (r : place_rfn rt) b : Type :=
+ stratify_ltype_post_hook_proof T : iProp_to_Prop (stratify_ltype_post_hook π E L ml l lt r b T).
+ Global Hint Mode StratifyLtypePostHook + + + + + + + + + + : typeclass_instances.
+
+ (** Low-priority instance in case no overrides are provided for this [ml]. *)
+ Lemma stratify_ltype_post_hook_id {rt} (Ï€ : thread_id) (E : elctx) (L : llctx) {M} (ml : M) (l : loc) (lt : ltype rt) (r : place_rfn rt) (b : bor_kind) (T : stratify_ltype_post_hook_cont_t) :
+ T L True%I _ lt r ⊢ stratify_ltype_post_hook π E L ml l lt r b T.
+ Proof.
+ iIntros "HT" (?? ?) "CTX HE HL Hb".
+ iExists _, _, _, _, _. iFrame. done.
+ Qed.
+ Global Instance stratify_ltype_post_hook_id_inst {rt} π E L {M} (ml : M) l (lt : ltype rt) r b :
+ StratifyLtypePostHook π E L ml l lt r b | 1000 := λ T, i2p (stratify_ltype_post_hook_id π E L ml l lt r b T).
+
+ Lemma stratify_ltype_id {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : place_rfn rt) b T :
+ stratify_ltype_post_hook π E L ml l lt r b T
+ ⊢ stratify_ltype π E L mu mdu ma ml l lt r b T.
+ Proof.
+ iIntros "HT" (?? ?) "CTX HE HL Hb".
+ iMod ("HT" with "[//] [//] CTX HE HL Hb") as "(%L2 & %R2 & %rt2 & %lt2 & %r2 & HL & Hst & Hb & HR & HT)".
+ iExists _, _, _, _, _. iFrame. iApply logical_step_intro. by iFrame.
+ Qed.
+ (* TODO: remove this instance *)
+ Global Instance stratify_ltype_id_inst {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) (r : place_rfn rt) b :
+ StratifyLtype π E L mu mdu ma ml l lt r b | 1000 := λ T, i2p (stratify_ltype_id π E L mu mdu ma ml l lt r b T).
+
+ Lemma stratify_ltype_eqltype {rt} π E L mu mdu ma {M} (ml : M) l (lt1 lt2 : ltype rt) (r1 r2 : place_rfn rt) b T :
+ ⌜eqltype E L b r1 r2 lt1 lt2⌠∗ stratify_ltype π E L mu mdu ma ml l lt2 r2 b T -∗
+ stratify_ltype π E L mu mdu ma ml l lt1 r1 b T.
+ Proof.
+ iIntros "(%Heq & Hs)".
+ iIntros (???) "#CTX #HE HL Hb".
+ iPoseProof (eqltype_use F with "CTX HE HL") as "(Hvs & HL)"; [done.. | ].
+ iMod ("Hvs" with "Hb") as "Hb".
+ iPoseProof (eqltype_acc with "CTX HE HL") as "#Heq"; first done.
+ iPoseProof (ltype_eq_syn_type with "Heq") as "->".
+ iPoseProof ("Hs" with "[//] [//] CTX HE HL Hb") as ">Hb". iModIntro.
+ iDestruct "Hb" as "(%L' & %R & %rt' & %lt' & %r' & HL & Hstep & HT)".
+ iExists L', R, rt', lt', r'. iFrame.
+ Qed.
+
+ (** Operation for unblocking (remove Blocked and ShrBlocked at leaves). *)
+ Inductive StratifyUnblock :=
+ | StratifyUnblockOp.
+ (* We specialize all flags except for the ascend mode, as that needs to be different for different operations. *)
+ Definition stratify_ltype_unblock {rt} (π : thread_id) (E : elctx) (L : llctx) (ma : StratifyAscendMode) (l : loc) (lt : ltype rt) (r : place_rfn rt) (b : bor_kind) (T : llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ) :=
+ stratify_ltype π E L StratMutNone StratNoUnfold ma StratifyUnblockOp l lt r b T.
+
+ (** Operation for extracting observations from dead references. *)
+ Inductive StratifyExtract :=
+ | StratifyExtractOp (κ : lft).
+ Definition stratify_ltype_extract {rt} (π : thread_id) (E : elctx) (L : llctx) (ma : StratifyAscendMode) (l : loc) (lt : ltype rt) (r : place_rfn rt) (b : bor_kind) (κ : lft) (T : llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ) :=
+ stratify_ltype π E L StratMutStrong StratDoUnfold ma (StratifyExtractOp κ) l lt r b T.
+
+
+
+ (* TODO: even shared borrows and reads should not always refold, in order to handle ShrBlocked.
+ We might want to have an operation on ltypes that captures this in some way, e.g. by "slicing" out a part that can be copied or so.
+ But probably this will have to be pretty specific to those. The best I can do is to unblock beforehand, at least.
+
+ TODO: The unblocking should, in the case of shared-borrowing from shr_blocked, not apply to all shr_blocked that we can find, but only those that are dead.
+ *)
+
+
+ (** ** Subtyping judgment with access to lifetime contexts. *)
+ (*
+ Conceptually, what is subtyping in our type system? Does subtyping in our type system allow refinement updates?
+ For now: seems to be mostly relevant for uninit. But uninit is somewhat special, maybe, at least if you consider safe Rust.
+ But later for unsafe code, uninit should conceivably take a stronger role.
+ Also for loops now, we should have reasonable subsumption for uninit.
+ e.g. what if the loop leaves one component of a struct uninitialized in the invariant, but always initializes at the start of an iteration?
+
+ I would like to say that (i32, i32) is a subtype of (i32, uninit i32), because I can always deinitialize something. (Note: does not work for types with non-trivial drop)
+ - with non-trivial drop, an explicit destructor call beforehand would deinitialize it.
+ - in general, I could alternatively say that a "storagedead" should explicitly deinitialize primitive types like i32.
+ Currently, we have this weird subsume instance that only works at top-level.
+
+ TODO: think on whether the current solution is the right way.
+ *)
+
+ (** These are the core judgments used for subtyping by the type system.
+ The main entry point is from [subsume_full].
+ These judgments enforce stronger requirements than, e.g., [subsume_full]:
+ - they require compatibility of [ty_sidecond] and [ty_syn_type]
+ - they require subtyping to be persistent
+ This allows to get compatibility lemmas, including for shared references.
+ However, they are not compatible with mutable references, which have stronger requirements still. *)
+
+ (** This is called "weak" because it just requires the subtyping to hold for a particular combination of refinements. *)
+ Definition weak_subtype E L {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) (T : iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L ={F}=∗
+ type_incl r1 r2 ty1 ty2 ∗ llctx_interp L ∗ T.
+ Class Subtype (E : elctx) (L : llctx) {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) : Type :=
+ subtype_proof T : iProp_to_Prop (weak_subtype E L r1 r2 ty1 ty2 T).
+ Global Hint Mode Subtype + + + - + - + - : typeclass_instances.
+
+ Definition weak_subltype E L {rt1 rt2} (b : bor_kind) r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) (T : iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L ={F}=∗
+ ltype_incl b r1 r2 lt1 lt2 ∗ llctx_interp L ∗ T.
+ Class SubLtype (E : elctx) (L : llctx) {rt1 rt2} b r1 r2 (lt1 : ltype rt1) (lt2 : ltype rt2) : Type :=
+ subltype_proof T : iProp_to_Prop (weak_subltype E L b r1 r2 lt1 lt2 T).
+ Global Hint Mode SubLtype + + + - + + - + - : typeclass_instances.
+
+ (** Owned value subtyping (is NOT compatible with shared references). *)
+ Definition owned_type_incl π {rt1 rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) : iProp Σ :=
+ ⌜∀ ly1 ly2, syn_type_has_layout (ty_syn_type ty1) ly1 → syn_type_has_layout (ty_syn_type ty2) ly2 → ly_size ly1 = ly_size ly2⌠∗
+ (ty_sidecond ty1 -∗ ty_sidecond ty2) ∗
+ (∀ (v : val), v â—áµ¥{ Ï€} r1 @ ty1 -∗ v â—áµ¥{ Ï€} r2 @ ty2).
+
+ Lemma type_incl_owned_type_incl π {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) :
+ type_incl r1 r2 ty1 ty2 -∗ owned_type_incl π r1 r2 ty1 ty2.
+ Proof.
+ iIntros "(%Hst & #$ & #Hv & _)".
+ iDestruct ("Hv" $! π) as "$".
+ iPureIntro. rewrite Hst.
+ intros ly1 ly2 Hst1 Hst2. f_equiv. by eapply syn_type_has_layout_inj.
+ Qed.
+
+ Definition owned_subtype π E L (pers : bool) {rt1 rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F,
+ ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗ |={F}=> ∃ L',
+ (□?pers owned_type_incl π r1 r2 ty1 ty2) ∗ llctx_interp L' ∗ T L'.
+ Class OwnedSubtype (Ï€ : thread_id) (E : elctx) (L : llctx) (pers : bool) {rt1 rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) : Type :=
+ owned_subtype_proof T : iProp_to_Prop (owned_subtype π E L pers r1 r2 ty1 ty2 T).
+ Global Hint Mode OwnedSubtype + + + + + - + - + - : typeclass_instances.
+
+ Lemma owned_subtype_weak_subtype π E L pers {rt1 rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) T :
+ weak_subtype E L r1 r2 ty1 ty2 (T L)
+ ⊢ owned_subtype π E L pers r1 r2 ty1 ty2 T.
+ Proof.
+ iIntros "HT" (???) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & ? & ?)".
+ iExists L. iFrame.
+ iModIntro. iApply bi.intuitionistically_intuitionistically_if. iModIntro.
+ by iApply type_incl_owned_type_incl.
+ Qed.
+ Global Instance owned_subtype_weak_subtype_inst π E L pers {rt1 rt2} (r1 : rt1) (r2 : rt2) ty1 ty2 :
+ OwnedSubtype π E L pers r1 r2 ty1 ty2 | 1000 := λ T, i2p (owned_subtype_weak_subtype π E L pers r1 r2 ty1 ty2 T).
+
+ Lemma owned_type_incl_refl π {rt} (ty : type rt) (r : rt) :
+ ⊢ owned_type_incl π r r ty ty.
+ Proof.
+ iSplitR. { iPureIntro. iIntros (ly1 ly2 Halg1 Halg2). f_equiv. by eapply syn_type_has_layout_inj. }
+ iSplitR. { eauto. }
+ iIntros (v). eauto.
+ Qed.
+ Lemma owned_subtype_id π E L step {rt} (r1 r2 : rt) (ty : type rt) T :
+ ⌜r1 = r2⌠∗ T L ⊢ owned_subtype π E L step r1 r2 ty ty T.
+ Proof.
+ iIntros "(-> & HT)".
+ iIntros (???) "#CTX #HE HL". iExists L. iFrame.
+ iModIntro. destruct step; simpl; try iModIntro. all: iApply owned_type_incl_refl.
+ Qed.
+ Global Instance owned_subtype_id_inst π E L step {rt} (r1 r2 : rt) (ty : type rt) :
+ OwnedSubtype π E L step r1 r2 ty ty | 5 := λ T, i2p (owned_subtype_id π E L step r1 r2 ty T).
+
+ (** Owned location subtyping with a logical step (used for extracting ghost observations) *)
+ Definition owned_subltype_step (π : thread_id) E L {rt1 rt2} (r1 : place_rfn rt1) (r2 : place_rfn rt2) (lt1 : ltype rt1) (lt2 : ltype rt2) (T : llctx → iProp Σ → iProp Σ) : iProp Σ :=
+ ∀ F l,
+ ⌜lftE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ l â—â‚—[Ï€, Owned false] r1 @ lt1 -∗ |={F}=>
+ ∃ L' R,
+ (logical_step F (l â—â‚—[Ï€, Owned false] r2 @ lt2 ∗ R)) ∗
+ (⌜∀ ly1 ly2, syn_type_has_layout (ltype_st lt1) ly1 → syn_type_has_layout (ltype_st lt2) ly2 → ly1 = ly2âŒ) ∗
+ llctx_interp L' ∗ T L' R.
+ Class OwnedSubltypeStep (Ï€ : thread_id) (E : elctx) (L : llctx) {rt1 rt2} (r1 : place_rfn rt1) (r2 : place_rfn rt2) (lt1 : ltype rt1) (lt2 : ltype rt2) : Type :=
+ owned_subltype_step_proof T : iProp_to_Prop (owned_subltype_step π E L r1 r2 lt1 lt2 T).
+ Global Hint Mode OwnedSubltypeStep + + + + - + - + - : typeclass_instances.
+
+ Lemma owned_subltype_step_weak_subltype π E L {rt1 rt2} (r1 : place_rfn rt1) (r2 : place_rfn rt2) lt1 lt2 T :
+ weak_subltype E L (Owned false) r1 r2 lt1 lt2 (T L True)
+ ⊢ owned_subltype_step π E L r1 r2 lt1 lt2 T.
+ Proof.
+ iIntros "HT" (???) "CTX HE HL Hl".
+ iExists L, True%I. iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iModIntro. iDestruct "Hincl" as "(%Hst & #Hincl & _)".
+ iSplitL; first last.
+ { iPureIntro. rewrite Hst. intros ly1 ly2 Hst1 Hst2. by eapply syn_type_has_layout_inj. }
+ iApply fupd_logical_step. iMod (fupd_mask_mono with "(Hincl Hl)"); first done.
+ iApply logical_step_intro. eauto.
+ Qed.
+ Global Instance owned_subltype_step_weak_subltype_inst π E L {rt1 rt2} (r1 : place_rfn rt1) (r2 : place_rfn rt2) lt1 lt2 :
+ OwnedSubltypeStep π E L r1 r2 lt1 lt2 | 1000 := λ T, i2p (owned_subltype_step_weak_subltype π E L r1 r2 lt1 lt2 T).
+
+ (** Subtyping for compatibility with mutable references. Importantly, this is independent of the refinement. *)
+ Definition mut_subtype E L {rt} (ty1 ty2 : type rt) (T : iProp Σ) : iProp Σ :=
+ ⌜full_subtype E L ty1 ty2⌠∗ T.
+ Class MutSubtype (E : elctx) (L : llctx) {rt} (ty1 ty2 : type rt) : Type :=
+ mut_subtype_proof T : iProp_to_Prop (mut_subtype E L ty1 ty2 T).
+ Global Hint Mode MutSubtype + + + + - : typeclass_instances.
+
+ Definition mut_subltype E L {rt} (lt1 lt2 : ltype rt) (T : iProp Σ) : iProp Σ :=
+ ⌜full_subltype E L lt1 lt2⌠∗ T.
+ Class MutSubLtype (E : elctx) (L : llctx) {rt} (lt1 lt2 : ltype rt) : Type :=
+ mut_subltype_proof T : iProp_to_Prop (mut_subltype E L lt1 lt2 T).
+ Global Hint Mode MutSubLtype + + + + - : typeclass_instances.
+
+ Definition mut_eqtype E L {rt} (ty1 ty2 : type rt) (T : iProp Σ) : iProp Σ :=
+ ⌜full_eqtype E L ty1 ty2⌠∗ T.
+ Class MutEqtype (E : elctx) (L : llctx) {rt} (ty1 ty2 : type rt) : Type :=
+ mut_eqtype_proof T : iProp_to_Prop (mut_eqtype E L ty1 ty2 T).
+ Global Hint Mode MutEqtype + + + + - : typeclass_instances.
+
+ Definition mut_eqltype E L {rt} (lt1 lt2 : ltype rt) (T : iProp Σ) : iProp Σ :=
+ ⌜full_eqltype E L lt1 lt2⌠∗ T.
+ Class MutEqLtype (E : elctx) (L : llctx) {rt} (lt1 lt2 : ltype rt) : Type :=
+ mut_eqltype_proof T : iProp_to_Prop (mut_eqltype E L lt1 lt2 T).
+ Global Hint Mode MutEqLtype + + + + - : typeclass_instances.
+
+ (** ** Prove a proposition using subtyping *)
+ Inductive ProofMode :=
+ | ProveDirect
+ | ProveWithStratify.
+ Global Instance ProofMode_eqdecision : EqDecision ProofMode.
+ Proof. solve_decision. Defined.
+ (* ideally, would like to both stratify and then subsume.
+ But the problem is that both will take steps in the return case.
+ So for return, I could either have two steps, or keep the context fold. *)
+ Definition prove_with_subtype (E : elctx) (L : llctx) (step : bool) (pm : ProofMode) (P : iProp Σ) (T : llctx → list lft → iProp Σ → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ |={F}=>
+ ∃ L' κs R, maybe_logical_step step F ((if pm is ProveWithStratify then (lft_dead_list κs ={lftE}=∗ P) else P) ∗ R) ∗ llctx_interp L' ∗ T L' κs R.
+ Class ProveWithSubtype (E : elctx) (L : llctx) (step : bool) (pm : ProofMode) (P : iProp Σ) : Type :=
+ prove_with_subtype_proof T : iProp_to_Prop (prove_with_subtype E L step pm P T).
+ Global Hint Mode ProveWithSubtype + + + + ! : typeclass_instances.
+
+ (* TODO: move *)
+ Lemma maybe_logical_step_compose (E : coPset) step (P Q : iProp Σ) :
+ maybe_logical_step step E P -∗ maybe_logical_step step E (P -∗ Q) -∗ maybe_logical_step step E Q.
+ Proof.
+ iIntros "Ha Hb". destruct step; simpl.
+ - iApply (logical_step_compose with "Ha Hb").
+ - iMod "Ha". iMod "Hb". by iApply "Hb".
+ Qed.
+
+ Lemma prove_with_subtype_sep E L step pm P1 P2 T :
+ prove_with_subtype E L step pm P1 (λ L' κs R1, prove_with_subtype E L' step pm P2 (λ L'' κs2 R2, T L'' (κs ++ κs2) (R1 ∗ R2)))
+ ⊢ prove_with_subtype E L step pm (P1 ∗ P2) T.
+ Proof.
+ iIntros "Hs" (F ??) "#CTX #HE HL".
+ iMod ("Hs" with "[//] [//] CTX HE HL") as "(%L' & %κs1 & %R1 & Ha & HL & Hs)".
+ iMod ("Hs" with "[//] [//] CTX HE HL") as "(%L'' & %κs2 & %R2 & Hb & ? & ?)".
+ iExists L'', (κs1 ++ κs2), (R1 ∗ R2)%I. iFrame.
+ iApply (maybe_logical_step_compose with "Ha").
+ iApply (maybe_logical_step_compose with "Hb").
+ iApply maybe_logical_step_intro.
+ iIntros "!> (Ha2 & $) (Ha1 & $)".
+ destruct pm; first by iFrame.
+ rewrite lft_dead_list_app. iIntros "(Ht1 & Ht2)".
+ iMod ("Ha1" with "Ht1") as "$". iMod ("Ha2" with "Ht2") as "$". done.
+ Qed.
+ Global Instance prove_with_subtype_sep_inst E L step pm P1 P2 : ProveWithSubtype E L step pm (P1 ∗ P2) :=
+ λ T, i2p (prove_with_subtype_sep E L step pm P1 P2 T).
+
+ Lemma prove_with_subtype_exists {X} E L step pm (Φ : X → iProp Σ) T :
+ (∃ x, prove_with_subtype E L step pm (Φ x) T)
+ ⊢ prove_with_subtype E L step pm (∃ x, Φ x) T.
+ Proof.
+ iIntros "(%x & Hs)" (F ??) "#CTX #HE HL".
+ iMod ("Hs" with "[//] [//] CTX HE HL") as "(%L' & %κs & %R & Hs & ? & ?)".
+ iExists L', κs, R. iFrame.
+ iApply (maybe_logical_step_wand with "[] Hs").
+ destruct pm. { iIntros "(? & ?)". eauto with iFrame. }
+ iIntros "(Ha & $) Htok". iMod ("Ha" with "Htok") as "?". eauto with iFrame.
+ Qed.
+ Global Instance prove_with_subtype_exists_inst {X} E L step pm (Φ : X → iProp Σ) : ProveWithSubtype E L step pm (∃ x, Φ x) :=
+ λ T, i2p (prove_with_subtype_exists E L step pm Φ T).
+
+ (* TODO move *)
+ Lemma imp_unblockable_use π F κs {rt} (lt : ltype rt) (r : place_rfn rt) l bk :
+ lftE ⊆ F →
+ imp_unblockable κs lt -∗
+ lft_dead_list κs -∗
+ l â—â‚—[Ï€, bk] r @ lt ={F}=∗ l â—â‚—[Ï€, bk] r @ ltype_core lt.
+ Proof.
+ iIntros (?) "(#Hub_uniq & #Hub_owned) Hdead Hl".
+ destruct bk.
+ - iMod (fupd_mask_mono with "(Hub_owned Hdead Hl)") as "Hl"; first done.
+ rewrite ltype_own_core_equiv. done.
+ - iApply (ltype_own_shared_to_core with "Hl").
+ - iMod (fupd_mask_mono with "(Hub_uniq Hdead Hl)") as "Hl"; first done.
+ rewrite ltype_own_core_equiv. done.
+ Qed.
+
+ (** For ofty location ownership, we have special handling to stratify first, if possible.
+ This only happens in the [ProveWithStratify] proof mode though, because we sometimes directly want to get into [Subsume]. *)
+ Lemma prove_with_subtype_ofty_step π E L (l : loc) bk {rt} (ty : type rt) (r : place_rfn rt) T :
+ find_in_context (FindLoc l π) (λ '(existT rt' (lt', r', bk')),
+ stratify_ltype π E L StratMutNone StratNoUnfold StratRefoldFull StratifyUnblockOp l lt' r' bk' (λ L2 R2 rt2 lt2 r2,
+ (* can't take a step, because we already took one. *)
+ (*owned_subltype_step E L false (l â—â‚—[Ï€, bk'] r' @ lt') (l â—â‚—[Ï€, bk] r @ â— ty) T*)
+ match ltype_blocked_lfts lt2 with
+ | [] =>
+ (* we could unblock everything, directly subsume *) ⌜bk = bk'⌠∗ weak_subltype E L2 bk r2 r lt2 (◠ty) (T L2 [] R2)
+ | κs =>
+ ⌜bk = bk'⌠∗ weak_subltype E L2 bk r2 r (ltype_core lt2) (◠ty) (T L2 κs R2)
+ end))
+ ⊢ prove_with_subtype E L true ProveWithStratify (l â—â‚—[Ï€, bk] r @ (â— ty))%I T.
+ Proof.
+ rewrite /FindLoc.
+ iIntros "Ha". iDestruct "Ha" as ([rt' [[lt' r'] bk']]) "(Hl & Ha)". simpl.
+ iIntros (???) "#CTX #HE HL". iMod ("Ha" with "[//] [//] CTX HE HL Hl") as "(%L2 & %R2 & %rt2 & %lt2 & %r2 & HL & %Hsteq & Hstep & HT)".
+ destruct (decide (ltype_blocked_lfts lt2 = [])) as [-> | Hneq].
+ - iDestruct "HT" as "(<- & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & HT)".
+ iExists _, [], _. iFrame.
+ simpl. iModIntro. iApply logical_step_fupd. iApply (logical_step_wand with "Hstep").
+ iIntros "(Hl & $)".
+ iDestruct "Hincl" as "(_ & Hincl & _)".
+ iMod (ltype_incl'_use with "Hincl Hl"); first done.
+ iModIntro. by iIntros "_ !>".
+ - iAssert (⌜bk = bk'⌠∗ weak_subltype E L2 bk r2 r (ltype_core lt2) (◠ty) (T L2 (ltype_blocked_lfts lt2) R2))%I with "[HT]" as "(<- & HT)".
+ { destruct (ltype_blocked_lfts lt2); done. }
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hincl & HL & HT)".
+ iModIntro. iExists _, _, _. iFrame.
+ iApply (logical_step_wand with "Hstep").
+ iIntros "(Hl & $)".
+ iIntros "Hdead".
+ iPoseProof (imp_unblockable_blocked_dead lt2) as "Hunblock".
+ iDestruct "Hincl" as "(_ & Hincl & _)".
+ iMod (imp_unblockable_use with "Hunblock Hdead Hl") as "Hl"; first done.
+ by iMod (ltype_incl'_use with "Hincl Hl") as "$".
+ Qed.
+ Global Instance prove_with_subtype_ofty_step_inst Ï€ E L (l : loc) bk {rt} (ty : type rt) (r : place_rfn rt) : ProveWithSubtype E L true ProveWithStratify (l â—â‚—[Ï€, bk] r @ â— ty)%I | 500 :=
+ λ T, i2p (prove_with_subtype_ofty_step π E L l bk ty r T).
+
+ Lemma prove_with_subtype_pure E L step pm (P : Prop) T :
+ ⌜P⌠∗ T L [] True ⊢ prove_with_subtype E L step pm (⌜PâŒ) T.
+ Proof.
+ iIntros "(% & HT)". iIntros (???) "#CTX #HE HL".
+ iExists L, [], True%I. iFrame.
+ destruct pm.
+ - by iApply maybe_logical_step_intro.
+ - iIntros "!>". iApply maybe_logical_step_intro. iSplitL; last done.
+ iIntros "_ !>". done.
+ Qed.
+ Global Instance prove_with_subtype_pure_inst E L step pm (P : Prop) : ProveWithSubtype E L step pm (⌜PâŒ) | 50:=
+ λ T, i2p (prove_with_subtype_pure E L step pm P T).
+
+ Lemma prove_with_subtype_simplify_goal E L step pm P T (n : N) {SG : SimplifyGoal P (Some n)} :
+ prove_with_subtype E L step pm (SG True).(i2p_P) T
+ ⊢ prove_with_subtype E L step pm P T.
+ Proof.
+ iIntros "Ha" (???) "#CTX #HE HL".
+ iMod ("Ha" with "[//] [//] CTX HE HL") as "(%L' & %κs & %R & Ha & HL & HT)".
+ unfold SimplifyGoal in SG.
+ destruct SG as [P' Ha].
+ iExists L', κs, R. iFrame.
+ iApply (maybe_logical_step_wand with "[] Ha").
+ iIntros "(Ha & $)".
+ destruct pm.
+ - iPoseProof (Ha with "Ha") as "Ha".
+ rewrite /simplify_goal. iDestruct "Ha" as "($ & _)".
+ - iIntros "Hdead". iMod ("Ha" with "Hdead") as "Ha".
+ iPoseProof (Ha with "Ha") as "Ha".
+ rewrite /simplify_goal. iDestruct "Ha" as "($ & _)".
+ done.
+ Qed.
+ Global Instance prove_with_subtype_simplify_goal_inst E L step pm P {SG : SimplifyGoal P (Some 0%N)} :
+ ProveWithSubtype E L step pm P := λ T, i2p (prove_with_subtype_simplify_goal E L step pm P T 0).
+
+ (** Note: run fully-fledged simplification only after context search *)
+ Global Instance prove_with_subtype_simplify_goal_full_inst E L step pm P n {SG : SimplifyGoal P (Some n)} :
+ ProveWithSubtype E L step pm P | 1001 := λ T, i2p (prove_with_subtype_simplify_goal E L step pm P T n).
+
+ (* Make low priority to enable overrides before we initiate context search. *)
+ Lemma prove_with_subtype_find_direct E L step pm P T `{!CheckOwnInContext P} :
+ P ∗ T L [] True%I
+ ⊢ prove_with_subtype E L step pm P T.
+ Proof.
+ iIntros "(HP & HT)". iIntros (???) "#CTX #HE HL".
+ iExists L, [], True%I. iFrame.
+ iApply maybe_logical_step_intro. iSplitL; last done.
+ destruct pm; first done. iIntros "!> _ !>". done.
+ Qed.
+ Global Instance prove_with_subtype_find_direct_inst E L step pm P `{!CheckOwnInContext P} :
+ ProveWithSubtype E L step pm P | 1000 := λ T, i2p (prove_with_subtype_find_direct E L step pm P T).
+
+ Lemma prove_with_subtype_primitive E L step pm P `{Hrel : !RelatedTo P} T :
+ find_in_context Hrel.(rt_fic) (λ a,
+ subsume_full E L step (fic_Prop Hrel.(rt_fic) a) P (λ L, T L []))
+ ⊢ prove_with_subtype E L step pm P T.
+ Proof.
+ iIntros "(%a & Ha & Hsub)" (???) "#CTX #HE HL".
+ iMod ("Hsub" with "[//] [//] CTX HE HL Ha") as "(%L2 & %R & Ha & ? & ?)".
+ iModIntro. iExists _, _, _. iFrame.
+ iApply (maybe_logical_step_wand with "[] Ha").
+ iIntros "(? & $)".
+ destruct pm; first done. iIntros "_ !>". done.
+ Qed.
+ (* only after running full simplification *)
+ Global Instance prove_with_subtype_primitive_inst E L step pm P `{Hrel : !RelatedTo P} : ProveWithSubtype E L step pm P | 1002 :=
+ λ T, i2p (prove_with_subtype_primitive E L step pm P T).
+
+ Lemma prove_with_subtype_case_destruct E L step pm {A} (b : A) P T :
+ case_destruct b (λ b r, (prove_with_subtype E L step pm (P b r) T))
+ ⊢ prove_with_subtype E L step pm (case_destruct b P) T.
+ Proof.
+ rewrite /case_destruct. apply prove_with_subtype_exists.
+ Qed.
+ Global Instance prove_with_subtype_case_destruct_inst E L step pm {A} (b : A) P :
+ ProveWithSubtype E L step pm (case_destruct b P) :=
+ λ T, i2p (prove_with_subtype_case_destruct E L step pm b P T).
+
+ Lemma prove_with_subtype_li_trace E L step pm {M} (m : M) P T :
+ li_trace m (prove_with_subtype E L step pm P T)
+ ⊢ prove_with_subtype E L step pm (li_trace m P) T.
+ Proof.
+ rewrite /li_trace. done.
+ Qed.
+ Global Instance prove_with_subtype_li_trace_inst E L step pm {M} (m : M) P :
+ ProveWithSubtype E L step pm (li_trace m P) :=
+ λ T, i2p (prove_with_subtype_li_trace E L step pm m P T).
+
+ Lemma prove_with_subtype_scrounge_credits E L step pm (n : nat) T :
+ find_in_context (FindCreditStore) (λ '(c, a),
+ ⌜n ≤ c⌠∗ (credit_store (c - n)%nat a -∗ T L [] True%I))
+ ⊢ prove_with_subtype E L step pm (£ n) T.
+ Proof.
+ iIntros "Ha". rewrite /FindCreditStore.
+ iDestruct "Ha" as ([c a]) "(Hstore & %Hn & HT)". simpl.
+ iPoseProof (credit_store_scrounge _ _ n with "Hstore") as "(Hcred & Hstore)"; first lia.
+ iPoseProof ("HT" with "Hstore") as "HT".
+ iIntros (???) "CTX HE HL". iModIntro. iExists _, _, _. iFrame.
+ iApply maybe_logical_step_intro.
+ iSplitL; last done.
+ destruct pm; first done. iIntros "_ !>". done.
+ Qed.
+ Global Instance prove_with_subtype_scrounge_credits_inst E L step pm (n : nat) :
+ ProveWithSubtype E L step pm (£ n) | 10 := λ T, i2p (prove_with_subtype_scrounge_credits E L step pm n T).
+
+ Lemma prove_with_subtype_scrounge_atime E L step pm (n : nat) T :
+ find_in_context (FindCreditStore) (λ '(c, a),
+ ⌜n ≤ a⌠∗ (credit_store c (a - n)%nat -∗ T L [] True%I))
+ ⊢ prove_with_subtype E L step pm (atime n) T.
+ Proof.
+ iIntros "Ha". rewrite /FindCreditStore.
+ iDestruct "Ha" as ([c a]) "(Hstore & %Hn & HT)". simpl.
+ iPoseProof (credit_store_acc with "Hstore") as "(Hcred & Hat & Hcl)".
+ replace (S a) with (S (a - n) + n)%nat by lia.
+ iDestruct "Hat" as "(Hat & Hat')".
+ iPoseProof ("Hcl" with "Hcred Hat") as "Hstore".
+ iPoseProof ("HT" with "Hstore") as "HT".
+ iIntros (???) "CTX HE HL". iModIntro. iExists _, _, _. iFrame.
+ iApply maybe_logical_step_intro.
+ iSplitL; last done.
+ destruct pm; first done. iIntros "_ !>". done.
+ Qed.
+ Global Instance prove_with_subtype_scrounge_atime_inst E L step pm (n : nat) :
+ ProveWithSubtype E L step pm (atime n) | 10 := λ T, i2p (prove_with_subtype_scrounge_atime E L step pm n T).
+
+
+ (* TODO figure out how to nicely key the Rel2. Is there always a canonical order in which we want to have that?
+ doesn't seem like it. *)
+ Lemma prove_with_subtype_inherit_manual E L step pm {K} (k : K) κ κ' P Q T :
+ lctx_lft_incl E L κ' κ →
+ Inherit κ' k Q -∗
+ (Q -∗ P) -∗
+ T L [] True%I -∗
+ prove_with_subtype E L step pm (Inherit κ k P) T.
+ Proof.
+ iIntros (Hi1) "Hinh HQP HT".
+ iIntros (???) "#CTX #HE HL".
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hincl1"; first apply Hi1.
+ (*iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hincl2"; first apply Hi2. *)
+ iPoseProof (Inherit_mono with "Hincl1 Hinh") as "Hinh".
+ iPoseProof (Inherit_update with "[HQP] Hinh") as "Hinh".
+ { iIntros (?) "HQ". iApply ("HQP" with "HQ"). }
+ iExists _, _, _. iFrame. iApply maybe_logical_step_intro.
+ iModIntro. iL. destruct pm; iFrame. eauto.
+ Qed.
+
+
+ (** ** Prove a typed_place_cond (used together with [stratify_ltype]) *)
+
+ (* Lattice with AllowWeak < AllowStrong. *)
+ Inductive access_allowed : Type :=
+ | AllowStrong
+ | AllowWeak.
+ (* Lattice with ResultStrong < ResultWeak *)
+ Inductive access_result (rti rti2 : Type) : Type :=
+ | ResultWeak (Heq : rti = rti2)
+ | ResultStrong.
+ Global Arguments ResultStrong {_ _}.
+ Global Arguments ResultWeak {_ _}.
+
+ Definition access_result_meet {rti1 rti2 rti3 : Type} (r1 : access_result rti1 rti2) (r2 : access_result rti2 rti3) : access_result rti1 rti3 :=
+ match r1, r2 with
+ | ResultWeak Heq1, ResultWeak Heq2 => ResultWeak $ eq_trans Heq1 Heq2
+ | _, _ => ResultStrong
+ end.
+ Lemma access_result_meet_strong_r {rt1 rt2 rt3} (o : access_result rt1 rt2) :
+ @access_result_meet rt1 rt2 rt3 o ResultStrong = ResultStrong.
+ Proof. destruct o; done. Qed.
+ Lemma access_result_meet_strong_l {rt1 rt2 rt3} (o : access_result rt2 rt3) :
+ @access_result_meet rt1 rt2 rt3 ResultStrong o = ResultStrong.
+ Proof. done. Qed.
+
+ Lemma access_result_lift (f : Type → Type) {rt1 rt2} :
+ access_result rt1 rt2 → access_result (f rt1) (f rt2).
+ Proof.
+ refine (λ Ha,
+ match Ha with
+ | ResultWeak Heq => ResultWeak _
+ | ResultStrong => ResultStrong
+ end).
+ exact (rew [λ rt, f rt1 = f rt] Heq in @eq_refl _ (f rt1)).
+ Defined.
+
+ Definition access_result_refl {rt} : access_result rt rt := ResultWeak (eq_refl).
+
+
+
+ Definition prove_place_cond (E : elctx) (L : llctx) {rt1 rt2} (bmin : bor_kind) (lt1 : ltype rt1) (lt2 : ltype rt2) (T : access_result rt1 rt2 → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L ={F}=∗
+ llctx_interp L ∗ ∃ upd,
+ (match upd with ResultWeak _ => typed_place_cond_ty bmin lt1 lt2 | ResultStrong => ⌜ltype_st lt1 = ltype_st lt2⌠end) ∗
+ T upd.
+ Class ProvePlaceCond (E : elctx) (L : llctx) {rt1 rt2} (bmin : bor_kind) (lt1 : ltype rt1) (lt2 : ltype rt2) : Type :=
+ prove_place_cond_proof T : iProp_to_Prop (prove_place_cond E L bmin lt1 lt2 T).
+ Global Hint Mode ProvePlaceCond + + + + + + + : typeclass_instances.
+
+ Lemma prove_place_cond_eqltype_l E L bmin {rt1 rt2} (lt1 lt1' : ltype rt1) (lt2 : ltype rt2) T :
+ full_eqltype E L lt1 lt1' →
+ prove_place_cond E L bmin lt1' lt2 T -∗
+ prove_place_cond E L bmin lt1 lt2 T.
+ Proof.
+ iIntros (Heq) "Hcond". iIntros (F ?) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; [done.. | ].
+ iMod ("Hcond" with "[//] CTX HE HL") as "($ & Hcond)".
+ iDestruct "Hcond" as "(%upd & Hcond & HT)".
+ iExists upd. iFrame.
+ destruct upd.
+ - iApply ltype_eq_place_cond_ty_trans; done.
+ - iPoseProof (ltype_eq_syn_type inhabitant inhabitant with "Heq") as "->". done.
+ Qed.
+ Lemma prove_place_cond_eqltype_r E L bmin {rt1 rt2} (lt1 : ltype rt1) (lt2 lt2' : ltype rt2) T :
+ full_eqltype E L lt2 lt2' →
+ prove_place_cond E L bmin lt1 lt2' T -∗
+ prove_place_cond E L bmin lt1 lt2 T.
+ Proof.
+ iIntros (Heq) "Hcond". iIntros (F ?) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; [done.. | ].
+ iMod ("Hcond" with "[//] CTX HE HL") as "($ & Hcond)".
+ iDestruct "Hcond" as "(%upd & Hcond & HT)".
+ iExists upd. iFrame.
+ destruct upd.
+ - iApply (place_cond_ty_ltype_eq_trans with "Hcond").
+ iModIntro. iIntros (??). iApply ltype_eq_sym. done.
+ - iPoseProof (ltype_eq_syn_type inhabitant inhabitant with "Heq") as "->". done.
+ Qed.
+
+
+ Definition prove_place_rfn_cond {rt1 rt2} (b : bool) (bmin : bor_kind) (r1 : place_rfn rt1) (r2 : place_rfn rt2) (T : iProp Σ) : iProp Σ :=
+ (if b then typed_place_cond_rfn bmin r1 r2 else True%I) ∗ T.
+ Class ProvePlaceRfnCond {rt1 rt2} b bmin (r1 : place_rfn rt1) (r2 : place_rfn rt2) :=
+ prove_place_rfn_cond_proof T : iProp_to_Prop (prove_place_rfn_cond b bmin r1 r2 T).
+ Global Hint Mode ProvePlaceRfnCond + + + + + + : typeclass_instances.
+
+ Lemma prove_place_rfn_cond_shared {rt} κ (r1 r2 : place_rfn rt) T :
+ ⌜r1 = r2⌠∗ T ⊢ prove_place_rfn_cond true (Shared κ) r1 r2 T.
+ Proof.
+ iIntros "(-> & HT)". iSplitR; last done.
+ iExists eq_refl. done.
+ Qed.
+ Global Instance prove_place_rfn_cond_shared_inst {rt} κ (r1 r2 : place_rfn rt) :
+ ProvePlaceRfnCond true (Shared κ) r1 r2 := λ T, i2p (prove_place_rfn_cond_shared κ r1 r2 T).
+
+ Lemma prove_place_rfn_cond_shared' {rt} κ (r1 r2 : place_rfn rt) T :
+ T ⊢ prove_place_rfn_cond false (Shared κ) r1 r2 T.
+ Proof.
+ iIntros "HT". iSplitR; last done. done.
+ Qed.
+ Global Instance prove_place_rfn_cond_shared'_inst {rt} κ (r1 r2 : place_rfn rt) :
+ ProvePlaceRfnCond false (Shared κ) r1 r2 := λ T, i2p (prove_place_rfn_cond_shared' κ r1 r2 T).
+
+ Lemma prove_place_rfn_cond_uniq {rt1 rt2} b κ γ (r1 : place_rfn rt1) (r2 : place_rfn rt2) T :
+ T ⊢ prove_place_rfn_cond b (Uniq κ γ) r1 r2 T.
+ Proof.
+ iIntros "HT". iSplitR; last done. destruct b; done.
+ Qed.
+ Global Instance prove_place_rfn_cond_uniq_inst {rt} b κ γ (r1 r2 : place_rfn rt) :
+ ProvePlaceRfnCond b (Uniq κ γ) r1 r2 := λ T, i2p (prove_place_rfn_cond_uniq b κ γ r1 r2 T).
+
+ Lemma prove_place_rfn_cond_owned {rt1 rt2} b wl (r1 : place_rfn rt1) (r2 : place_rfn rt2) T :
+ T ⊢ prove_place_rfn_cond b (Owned wl) r1 r2 T.
+ Proof.
+ iIntros "HT". iSplitR; last done. destruct b; done.
+ Qed.
+ Global Instance prove_place_rfn_cond_owned_inst {rt} b wl (r1 r2 : place_rfn rt) :
+ ProvePlaceRfnCond b (Owned wl) r1 r2 := λ T, i2p (prove_place_rfn_cond_owned b wl r1 r2 T).
+
+ (** ** Solving [lctx_lft_alive_count] *)
+ (** the continuation gets the list of opened lifetimes + the new local lifetime context *)
+ Definition lctx_lft_alive_count_goal (E : elctx) (L : llctx) (κ : lft)
+ (T : (list lft) * llctx → iProp Σ) : iProp Σ :=
+ ∃ κs L', ⌜lctx_lft_alive_count E L κ κs L'⌠∗ T (κs, L').
+ Typeclasses Opaque lctx_lft_alive_count_goal.
+ Program Definition lctx_lft_alive_count_hint E L κ (κs : list lft) (L' : llctx) :
+ lctx_lft_alive_count E L κ κs L' →
+ LiTactic (lctx_lft_alive_count_goal E L κ) := λ a, {|
+ li_tactic_P T := T (κs, L');
+ |}.
+ Next Obligation.
+ simpl. iIntros (E L κ κs L' ? T) "HT".
+ iExists κs, L'. iFrame. done.
+ Qed.
+
+ (** ** Releasing lifetime tokens *)
+ Definition llctx_release_toks_goal (L : llctx) (κs : list lft) (T : llctx → iProp Σ) : iProp Σ :=
+ ∃ L', ⌜llctx_release_toks L κs L'⌠∗ T L'.
+ Typeclasses Opaque llctx_release_toks_goal.
+ Program Definition llctx_release_toks_hint L κs (L' : llctx) :
+ llctx_release_toks L κs L' →
+ LiTactic (llctx_release_toks_goal L κs) := λ a, {|
+ li_tactic_P T := T L';
+ |}.
+ Next Obligation.
+ iIntros (L κs L' ? T) "HT". iExists L'. iFrame. done.
+ Qed.
+
+ Lemma introduce_with_hooks_lft_toks E L κs T :
+ li_tactic (llctx_release_toks_goal L κs) T ⊢
+ introduce_with_hooks E L (llft_elt_toks κs) T.
+ Proof.
+ rewrite /li_tactic /llctx_release_toks_goal.
+ iIntros "(%L' & %HL & HT)".
+ iIntros (F ?) "#HE HL Htoks".
+ iMod (llctx_return_elt_toks _ _ L' with "HL Htoks") as "HL"; first done.
+ eauto with iFrame.
+ Qed.
+ Global Instance introduce_with_hooks_lft_toks_inst E L κs : IntroduceWithHooks E L (llft_elt_toks κs) | 10 :=
+ λ T, i2p (introduce_with_hooks_lft_toks E L κs T).
+
+
+
+ (** ** Some utilities for finishing a place access by either using the strong or the weak VS *)
+
+
+ (* When finishing a place access:
+ - done a weak update without rt change
+ - done a strong update without rt change
+ - done a strong update with rt change
+
+ In which cases do I do a strong update? Currently, this is an input to typed_read_end etc.
+ typed_read_end etc. should know which access is allowed: is it allowed to do an rt change or not? is it allowed to do a strong update or not?
+ for most practical purposes, however, we don't need to distinguish strong updates and rt changes.
+ So let's just keep the strong update flag for now.
+ *)
+
+
+ Definition typed_place_finish π (E : elctx) (L : llctx) {rto rti rti2} (strong : option (strong_ctx rti)) (weak : option (weak_ctx rto rti))
+ (upd : access_result rti rti2) (R : iProp Σ) (R_weak : iProp Σ) l b (lt2 : ltype rti2) (r2 : place_rfn rti2) (T : llctx → iProp Σ) : iProp Σ :=
+ (* use a weak update if possible, otherwise a strong update *)
+ match upd with
+ | ResultWeak Heq =>
+ match weak with
+ | Some weak =>
+ l â—â‚—[Ï€, b] (weak.(weak_rfn) (rew <- Heq in r2)) @ (weak.(weak_lt) (rew <- Heq in lt2) (rew <- Heq in r2)) -∗
+ weak.(weak_R) (rew <- Heq in lt2) (rew <- Heq in r2) -∗
+ introduce_with_hooks E L (R_weak ∗ R) T
+ | None =>
+ match strong with
+ | Some strong =>
+ l â—â‚—[Ï€, b] (strong.(strong_rfn) rti2 r2) @ (strong.(strong_lt) rti2 lt2 r2) -∗
+ strong.(strong_R) rti2 lt2 r2 -∗
+ introduce_with_hooks E L R T
+ | None => False
+ end
+ end
+ | ResultStrong =>
+ match strong with
+ | Some strong =>
+ l â—â‚—[Ï€, b] (strong.(strong_rfn) rti2 r2) @ (strong.(strong_lt) rti2 lt2 r2) -∗
+ strong.(strong_R) rti2 lt2 r2 -∗
+ introduce_with_hooks E L R T
+ | _ => False
+ end
+ end.
+
+ Lemma typed_place_finish_elim π (E : elctx) (L : llctx) {rto rti rti2} (strong : option (strong_ctx rti)) (weak : option (weak_ctx rto rti))
+ (upd : access_result rti rti2) (R : iProp Σ) (R_weak : iProp Σ) l b (lt2 : ltype rti2) (r2 : place_rfn rti2) (T : llctx → iProp Σ) :
+ typed_place_finish π E L strong weak upd R R_weak l b lt2 r2 T -∗
+ (∃ weak' Heq, ⌜weak = Some weak'⌠∗ ⌜upd = ResultWeak Heq⌠∗
+ (l â—â‚—[Ï€, b] (weak'.(weak_rfn) (rew <- Heq in r2)) @ (weak'.(weak_lt) (rew <- Heq in lt2) (rew <- Heq in r2)) -∗
+ weak'.(weak_R) (rew <- Heq in lt2) (rew <- Heq in r2) -∗
+ introduce_with_hooks E L (R_weak ∗ R) T)) ∨
+ (∃ strong', ⌜strong = Some strong'⌠∗ (⌜weak = None⌠∨ ⌜upd = ResultStrongâŒ) ∗
+ (l â—â‚—[Ï€, b] (strong'.(strong_rfn) rti2 r2) @ (strong'.(strong_lt) rti2 lt2 r2) -∗
+ strong'.(strong_R) rti2 lt2 r2 -∗
+ introduce_with_hooks E L R T)).
+ Proof.
+ iIntros "Ha". destruct upd as [ Heq | ]; first destruct weak as [ weak | ].
+ - iLeft. iExists _, _. iR. iR. done.
+ - destruct strong as [ strong | ]; last done. iRight. iExists _. iR.
+ iSplitR; last done. by iLeft.
+ - destruct strong as [ strong | ]; last done. iRight. iExists _. iR.
+ iSplitR; last done. by iRight.
+ Qed.
+
+ (*
+ match option_combine upd weak with
+ | Some (Heq, weak) =>
+ l â—â‚—[Ï€, b] (weak.(weak_rfn) (rew <- Heq in r2)) @ (weak.(weak_lt) (rew <- Heq in lt2)) -∗
+ weak.(weak_R) (rew <- Heq in lt2) (rew <- Heq in r2) -∗
+ introduce_with_hooks E L (R_weak ∗ R) T
+ | None =>
+ match strong with
+ | Some strong =>
+ l â—â‚—[Ï€, b] (strong.(strong_rfn) rti2 r2) @ (strong.(strong_lt) rti2 lt2) -∗
+ strong.(strong_R) rti2 lt2 r2 -∗
+ introduce_with_hooks E L R T
+ | _ => False
+ end
+ end.
+ *)
+ Global Typeclasses Transparent typed_place_finish.
+
+ (** ** Read judgments *)
+ (* In a given lifetime context, we can read from [e], in the process determining that [e] reads from a location [l] and getting a value typed at a type [ty] with a layout compatible with [ot], and afterwards, the remaining [T L' v ty' r'] needs to be proved, where [ty'] is the new type of the read value and [v] is the read value.
+
+ The prover will prove a [typed_read] in a number of steps:
+ - first, the place that is read is checked with [typed_place].
+ - then, the actual type-checking of the read is performed with [typed_read_end]
+ *)
+ (* Parameters:
+ - [Ï€] : the thread id
+ - [E] : external lifetime context
+ - [L] : local lifetime context
+ - [e] : read expression
+ - [ot] : [op_type] to use for the read
+ - [T] : continuation for the client, receiving the following arguments:
+ + [L' : llctx] : the updated lifetime context, as the read may have side-effects
+ + [v : val] : the read value
+ + [rt' : Type] : the refinement type of the read value
+ + [ty' : type rt] : the type of the read value
+ + [r' : rt] : the refinement of the read value
+ *)
+ (* TODO: thread through [na_own] at [F]? *)
+ Definition typed_read (π : thread_id) (E : elctx) (L : llctx) (e : expr) (ot : op_type) (T : llctx → val → ∀ rt, type rt → rt → iProp Σ) : iProp Σ :=
+ (∀ Φ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (∀ (l : loc),
+ (* the client gets ownership of the read value and fractional ownership of the location *)
+ (* this is below a logical step in order to execute stratification here.
+ TODO we may want to move this into a separate thing, together with moving the skip in Use to a separate annotation *)
+ logical_step F (∃ v q rt (ty : type rt) r,
+ ⌜l `has_layout_loc` ot_layout ot⌠∗ ⌜v `has_layout_val` ot_layout ot⌠∗ l ↦{q} v ∗ â–· v â—áµ¥{Ï€} r @ ty ∗
+ (* additionally, the client can assume that it can transform this to the ownership required by the continuation T *)
+ logical_step F (∀ st,
+ l ↦{q} v -∗
+ v â—áµ¥{Ï€} r @ ty ={F}=∗
+ ∃ L' rt' (ty' : type rt') r',
+ llctx_interp L' ∗
+ mem_cast v ot st â—áµ¥{Ï€} r' @ ty' ∗
+ T L' (mem_cast v ot st) rt' ty' r')) -∗
+ (* under this knowledge, the client has to prove the postcondition *)
+ Φ (val_of_loc l)) -∗
+ (* TODO: maybe different mask F *)
+ WP e {{ Φ }})%I.
+
+
+ (* The core of reading from a location [l] with [ot] that is typed at [lt] and immediately owned at [b2] below a path with intersected [bor_kind] [bmin].
+
+ This is called [typed_read_end] because it ends the chain of typing rules applied to do the read, after typing all the places that are accessed to get to [l].
+
+ The continuation [T] has access to the new place type and refinement of [l] after reading ([lt']),
+ and the type ([ty3]) and refinement that is "moved out" of [l] for the client to keep (i.e., the ownership of the read value)
+ *)
+ Definition typed_read_end_cont_t (rt : Type) : Type :=
+ llctx → val → ∀ rt3, type rt3 → rt3 → ∀ rt', ltype rt' → place_rfn rt' → access_result rt rt' → iProp Σ.
+ Definition typed_read_end (π : thread_id) (E : elctx) (L : llctx) (l : loc) {rt} (lt : ltype rt) (r : place_rfn rt) (b2 bmin : bor_kind) (ac : access_allowed) (ot : op_type) (T : typed_read_end_cont_t rt) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ bmin ⊑ₖ b2 -∗
+ (* given ownership of the read location *)
+ l â—â‚—[Ï€, b2] r @ lt ={F}=∗
+ ∃ q v
+ (* the type of the object we read *)
+ (* TODO: why do we quantify over rt2? can we also make this rt? *)
+ rt2 (ty2 : type rt2) r2,
+ (* we can provide fractional permission ownership of the stored value [v] to the client,
+ typed at an actual type [ty2] (that we can extract from [lt]) *)
+ ⌜l `has_layout_loc` ot_layout ot⌠∗ ⌜v `has_layout_val` ot_layout ot⌠∗ l ↦{q} v ∗ â–· v â—áµ¥{Ï€} r2 @ ty2 ∗
+ (* prove the continuation after the client is done *)
+ logical_step F (∀ st,
+ (* assuming that the client provides the ownership back... *)
+ l ↦{q} v -∗
+ v â—áµ¥{Ï€} r2 @ ty2 ={F}=∗
+ (* ... we transform to some new ownership [ty3] that the client "can keep" (imagine we move out of [l]) *)
+ ∃ (L' : llctx) (rt3 : Type) (ty3 : type rt3) r3,
+ (mem_cast v ot st) â—áµ¥{Ï€} r3 @ ty3 ∗
+ (* and the lifetime context *)
+ llctx_interp L' ∗
+ (∃ rt' (lt' : ltype rt') (r' : place_rfn rt') res,
+ (* and the remaining ownership for the location *)
+ l â—â‚—[Ï€, b2] r' @ lt' ∗
+ ⌜ltype_st lt' = ltype_st lt⌠∗
+ match res with
+ | ResultStrong => ⌜ac = AllowStrongâŒ
+ | ResultWeak _ => typed_place_cond bmin lt lt' r r'
+ end ∗
+ T L' (mem_cast v ot st) rt3 ty3 r3 rt' lt' r' res))).
+ Class TypedReadEnd (Ï€ : thread_id) (E : elctx) (L : llctx) (l : loc) {rt} (lt : ltype rt) (r : place_rfn rt) (b2 bmin : bor_kind) (br : access_allowed) (ot : op_type) : Type :=
+ typed_read_end_proof T : iProp_to_Prop (typed_read_end π E L l lt r b2 bmin br ot T).
+ Global Hint Mode TypedReadEnd + + + + + + + + + + + : typeclass_instances.
+
+ (** ** Write judgments *)
+ (* In a given lifetime context, we can write [v] to [e], compatible with [ot], where the written value has type [ty] at refinement [r], and afterwards, the remaining [T] needs to be proved.
+
+ The prover will prove a [typed_write] in a number of steps:
+ - first, the place that is read is checked with [typed_place].
+ - then, the actual type-checking of the read is performed with [typed_read_end]
+ *)
+ (* TODO: thread through [na_own] at [F]? *)
+ Definition typed_write (π : thread_id) (E : elctx) (L : llctx) (e : expr) (ot : op_type) (v : val) {rt} (ty : type rt) (r : rt) (T : llctx → iProp Σ) : iProp Σ :=
+ (∀ Φ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (* provided by the client: for any location l... *)
+ (∀ (l : loc),
+ (* we can hand out ownership to [l], and when the client has written [v] to it,
+ the postcondition holds. *)
+ (* if the client provides ownership of v... *)
+ (v â—áµ¥{Ï€} r @ ty -∗ logical_step F (
+ (* This is something the client learns (in order to prove its wp), rather than something that is provided.
+ That the type is compatible with the ot is something that actually needs to be proven as part of [typed_write_end],
+ and so we provide it here to the client. *)
+ ⌜v `has_layout_val` ot_layout ot⌠∗
+ (* then it gets access to l *)
+ l ↦|ot_layout ot| ∗
+ (* and after having written v to it, it gets access to T *)
+ logical_step F (l ↦ v ={F}=∗ ∃ L', llctx_interp L' ∗ T L'))) -∗
+ Φ (val_of_loc l)) -∗
+ (* TODO: maybe different mask F *)
+ WP e {{ Φ }})%I.
+
+
+ (* The core of writing a value [v1] typed at [ty1] to a location [l2] typed at [lt2] with [ot], where [l2] immediately owned at [b2] below a path with intersected [bor_kind] [bmin].
+
+ After the write, [l2] has a new type [ty3] that is passed on to the continuation.
+ *)
+ Definition typed_write_end_cont_t rt2 := llctx → ∀ rt3 : Type, type rt3 → rt3 → access_result rt2 rt3 → iProp Σ.
+ Definition typed_write_end (π : thread_id) (E : elctx) (L : llctx) (ot : op_type) (v1 : val) {rt1} (ty1 : type rt1) (r1 : rt1) (b2 bmin : bor_kind) (ac : access_allowed) (l2 : loc) {rt2} (lt2 : ltype rt2) (r2 : place_rfn rt2) (T : typed_write_end_cont_t rt2) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ bmin ⊑ₖ b2 -∗
+ (* given ownership of the written-to location *)
+ l2 â—â‚—[Ï€, b2] r2 @ lt2 -∗
+ (* assuming that the client provides ownership of [v1] *)
+ v1 â—áµ¥{Ï€} r1 @ ty1 ={F}=∗
+ (* we need to prove that [v1]'s layout is compatible with [ot], and provide it to the client *)
+ ⌜v1 `has_layout_val` ot_layout ot⌠∗
+ (* we provide [l2] *)
+ l2 ↦|ot_layout ot| ∗
+
+ (* and after the client has written to [l2] ... *)
+ logical_step F (l2 ↦ v1 ={F}=∗
+ ((∃ L' (rt3 : Type) (ty3 : type rt3) (r3 : rt3) res,
+ llctx_interp L' ∗
+ (* [l2] is typed at a new type [ty3] satisfying the postcondition *)
+ l2 â—â‚—[Ï€, b2] PlaceIn r3 @ (â— ty3) ∗
+ ⌜ltype_st lt2 = ty_syn_type ty3⌠∗
+ (* rt-changing, require br = false *)
+ match res with
+ | ResultStrong => ⌜ac = AllowStrongâŒ
+ | ResultWeak _ => typed_place_cond bmin lt2 (â— ty3) r2 (PlaceIn r3)
+ end ∗
+ T L' rt3 ty3 r3 res)))).
+ Class TypedWriteEnd (Ï€ : thread_id) (E : elctx) (L : llctx) (ot : op_type) (v1 : val) {rt1} (ty1 : type rt1) (r1 : rt1) (b2 bmin : bor_kind) (br : access_allowed) (l2 : loc) {rt2} (lt2 : ltype rt2) (r2 : place_rfn rt2) : Type :=
+ typed_write_end_proof T : iProp_to_Prop (typed_write_end π E L ot v1 ty1 r1 b2 bmin br l2 lt2 r2 T).
+ Global Hint Mode TypedWriteEnd + + + + + + + + + + + + + + + : typeclass_instances.
+
+ (** ** Borrow judgments *)
+ (** [typed_borrow_mut] gets triggered when we borrow mutably at lifetime [κ] from a place [e].
+
+ Usually, this will be proved in multiple steps:
+ * we decompose [e] to a place context and a location
+ * we find a typing for the location in the context
+ * we type the place context with [typed_place]
+ * we use [typed_borrow_mut_end] to do the final checking
+ *)
+ Definition typed_borrow_mut_cont_t := llctx → val → gname → ∀ (rt : Type), type rt → rt → iProp Σ.
+ Definition typed_borrow_mut (π : thread_id) (E : elctx) (L : llctx) (e : expr) (κ : lft) (ty_annot : option rust_type) (T : typed_borrow_mut_cont_t) : iProp Σ :=
+ (∀ Φ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (* for any location provided to the client *)
+ (∀ (l : loc),
+ (* and a time receipt we provide for generating our credits *)
+ atime 1 -∗
+ (* the client can assume after an update... *)
+ logical_step F (
+ (* credits to prepay the borrow *)
+ £ num_cred -∗
+ (* and the returned receipt *)
+ atime 1 ={F}=∗
+ ∃ L' (rt : Type) (ty : type rt) (r : rt) (γ : gname) (ly : layout),
+ (* a new observation *)
+ gvar_obs γ r ∗
+ (* and a borrow *)
+ &{κ}(∃ (r': rt), gvar_auth γ r' ∗ |={lftE}=> l ↦: ty.(ty_own_val) π r') ∗
+ (* + some well-formedness *)
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly.(ly_size)) ∗ ty_sidecond ty ∗
+ (* + the condition T *)
+ llctx_interp L' ∗
+
+ T L' (val_of_loc l) γ rt ty r) -∗
+ Φ (val_of_loc l)) -∗
+ WP e {{ Φ }})%I.
+
+ Definition typed_borrow_mut_end_cont_t rt := gname → ltype rt → place_rfn rt → iProp Σ.
+ Definition typed_borrow_mut_end (π : thread_id) (E : elctx) (L : llctx) (κ : lft) (l : loc) {rt} (ty : type rt) (r : place_rfn rt) (b2 bmin : bor_kind) (T : typed_borrow_mut_end_cont_t rt) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ bmin ⊑ₖ b2 -∗
+ (* given ownership of the location we borrow from *)
+ (* TODO should we require a PlaceIn refinement here? *)
+ l â—â‚—[Ï€, b2] r @ (â— ty) -∗ £(num_cred) ={F}=∗
+ (* we provide a borrow of ty *)
+ ∃ (γ : gname) (ly : layout), place_rfn_interp_mut r γ ∗
+ &{κ}(∃ (r': rt), gvar_auth γ r' ∗ |={lftE}=> l ↦: ty.(ty_own_val) π r') ∗
+ ty_sidecond ty ∗
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗ loc_in_bounds l 0 (ly.(ly_size)) ∗
+ (* and a blocked ownership of the borrowed location *)
+ l â—â‚—[Ï€, b2] (PlaceGhost γ: place_rfn rt) @ (BlockedLtype ty κ) ∗
+ (* and a proof that we can unblock again *)
+ typed_place_cond bmin (◠ty) (BlockedLtype ty κ) r (PlaceGhost γ) ∗
+ (* and the context and postco *)
+ llctx_interp L ∗
+ T γ (BlockedLtype ty κ) (PlaceGhost γ)).
+ Class TypedBorrowMutEnd π (E : elctx) (L : llctx) (κ : lft) (l : loc) {rt} (ty : type rt) (r : place_rfn rt) (b2 bmin : bor_kind) : Type :=
+ typed_borrow_mut_end_proof T : iProp_to_Prop (typed_borrow_mut_end π E L κ l ty r b2 bmin T).
+ Global Hint Mode TypedBorrowMutEnd + + + + + + + + + + : typeclass_instances.
+
+ (** [typed_borrow_shr] gets triggered when we do a shared borrow at lifetime [κ] from a place [e].
+
+ Usually, this will be proved in multiple steps:
+ * we decompose [e] to a place context and a location
+ * we find a typing for the location in the context
+ * we type the place context with [typed_place]
+ * we use [typed_borrow_shr_end] to do the final checking
+ *)
+ Definition typed_borrow_shr_cont_t := llctx → val → ∀ (rt : Type), type rt → rt → iProp Σ.
+ Definition typed_borrow_shr π (E : elctx) (L : llctx) (e : expr) (κ : lft) (ty_annot : option rust_type) (T : typed_borrow_shr_cont_t) : iProp Σ :=
+ (∀ Φ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (* for any location provided to the client... *)
+ (∀ (l : loc),
+ (* the client needs to prove the postcondition, assuming shared ownership after an update *)
+ (* this requires two logical steps: one for stratifying, and one for initiating sharing *)
+ logical_step F (logical_step F (
+ (* one credit for the inheritance VS *)
+ £1 ={F}=∗
+ ∃ (L' : llctx) (rt : Type) (ty : type rt) (r : rt) (ly : layout),
+ ty.(ty_shr) κ π r l ∗
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 (ly.(ly_size)) ∗ ty.(ty_sidecond) ∗
+ (* as well as the condition T *)
+ llctx_interp L' ∗
+ T L' (val_of_loc l) rt ty r)) -∗
+ Φ (val_of_loc l)) -∗
+ WP e {{ Φ }})%I.
+
+ Definition typed_borrow_shr_end_cont_t rt := ltype rt → place_rfn rt → iProp Σ.
+ Definition typed_borrow_shr_end π (E : elctx) (L : llctx) (κ : lft) (l : loc) {rt} (ty : type rt) (r : rt) (b2 bmin : bor_kind) (T : typed_borrow_shr_end_cont_t rt) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ bmin ⊑ₖ b2 -∗
+ (* given ownership of the location we borrow from
+
+ TODO (this might well be an lty and not simply â— ty, to handle the case that a subplace was already shared-borrowed)
+ but how to formulate this properly?
+ Really, I want to say that [lt]'s core should be equivalent to â—ty for some ty?
+ *)
+ l â—â‚—[Ï€, b2] PlaceIn r @ (â— ty) ={F}=∗
+ (* we provide a borrow of ty *)
+ logical_step F (
+ (* one credit for the inheritance VS *)
+ £1 ={F}=∗
+ ∃ ly (lt : ltype rt), ty.(ty_shr) κ π r l ∗
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ loc_in_bounds l 0 (ly.(ly_size)) ∗ ty.(ty_sidecond) ∗
+ (* and a blocked ownership of the borrowed location *)
+ l â—â‚—[Ï€, b2] PlaceIn r @ lt ∗
+ (* and a proof that we can unblock again *)
+ typed_place_cond bmin (◠ty) lt (PlaceIn r) (PlaceIn r) ∗
+ (* and the context and postco *)
+ llctx_interp L ∗
+ T lt (PlaceIn r))).
+ Class TypedBorrowShrEnd π (E : elctx) (L : llctx) (κ : lft) (l : loc) {rt} (ty : type rt) (r : rt) (b2 bmin : bor_kind) : Type :=
+ typed_borrow_shr_end_proof T : iProp_to_Prop (typed_borrow_shr_end π E L κ l ty r b2 bmin T).
+ Global Hint Mode TypedBorrowShrEnd + + + + + + + + + + : typeclass_instances.
+
+ (** ** Address-of judgments *)
+ (** [*mut] address of *)
+ Definition typed_addr_of_mut_cont_t := llctx → val → ∀ (rt : Type), type rt → rt → iProp Σ.
+ Definition typed_addr_of_mut π (E : elctx) (L : llctx) (e : expr) (T : typed_addr_of_mut_cont_t) : iProp Σ :=
+ (∀ Φ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ (* for any location provided to the client *)
+ (∀ (l : loc),
+ logical_step F (
+ ∃ L' (rt : Type) (ty : type rt) (r : rt),
+ l â—áµ¥{Ï€} r @ ty ∗
+ llctx_interp L' ∗
+ T L' (val_of_loc l) rt ty r) -∗
+ Φ (val_of_loc l)) -∗
+ WP e {{ Φ }})%I.
+
+ (** This does not work below shared references, as we cannot get a full fraction out of the sharing predicate.
+ This does not seem that terrible, because we should not take *mut references from shared borrows anyways.
+ (Note: we are really using here that the difference between *mut and *const have the role of providing some intent by the programmer.) *)
+ Definition typed_addr_of_mut_end_cont_t := llctx → ∀ rt0, type rt0 → rt0 → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ.
+ Definition typed_addr_of_mut_end (π : thread_id) (E : elctx) (L : llctx) (l : loc) {rt} (lt : ltype rt) (r : place_rfn rt) (b2 bmin : bor_kind) (T : typed_addr_of_mut_end_cont_t) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠→ ⌜↑rrustN ⊆ F⌠→ ⌜lft_userE ⊆ F⌠→
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ bmin ⊑ₖ b2 -∗
+ (* given ownership of the location we borrow from *)
+ l â—â‚—[Ï€, b2] r @ lt -∗
+ (* do a logical step in order to be able to create [OpenedLtype] *)
+ logical_step F (
+ ∃ (L' : llctx)
+ (rt0 : Type) (ty0 : type rt0) (r0 : rt0)
+ (rt' : Type) (lt' : ltype rt') (r' : place_rfn rt'),
+ (* provide ownership of some ty0, the result of the operation -- usually will be alias_ptr_t *)
+ l â—áµ¥{Ï€} r0 @ ty0 ∗
+ (* and blocked ownership of the borrowed location (where the notion of blocking is not fixed, and determined by the existentially-quantified lt');
+ usually it will be AliasLtype l or OpenedLtype (AliasLtype l) .. *)
+ l â—â‚—[Ï€, b2] r' @ lt' ∗
+ (* and the ownership to move out *)
+ l â—â‚—[Ï€, Owned false] r @ lt ∗
+ ⌜ltype_st lt' = ltype_st lt⌠∗
+ (* and the context and postco *)
+ llctx_interp L' ∗
+ T L' rt0 ty0 r0 rt' lt' r')).
+ Class TypedAddrOfMutEnd (Ï€ : thread_id) (E : elctx) (L : llctx) (l : loc) {rt} (lt : ltype rt) (r : place_rfn rt) (b2 bmin : bor_kind) : Type :=
+ typed_addr_of_mut_end_proof T : iProp_to_Prop (typed_addr_of_mut_end π E L l lt r b2 bmin T).
+ Global Hint Mode TypedAddrOfMutEnd + + + + + + + + + : typeclass_instances.
+
+ (*
+ expected flow:
+ - we do a typed_place
+ - now we need to reshape the resulting ltype to an Owned ofty
+ in order to be able to take that ownership out.
+ - one possibility to do this: just have different _end instances for Owned, Uniq and Shared.
+ Owned is straight; for Uniq and Shared we do a strong update.
+ Shared is more challenging though: we can only get one fraction out.
+ Also, we can't write here.
+ There we again face the problem of specifying shared pointers in a reasonable way.
+ For now: just don't support it for shared pointers.
+ *)
+
+ (* TODO addr_of_const
+ This should give us some kind of shared ownership.
+ *)
+
+End judgments.
+
+(* TODO: can we just make this a li_tactic? *)
+Ltac solve_into_place_ctx :=
+ match goal with
+ | |- IntoPlaceCtx ?Ï€ ?E ?e ?T =>
+ let e' := W.of_expr e in
+ change_no_check (IntoPlaceCtx π E (W.to_expr e') T);
+ refine (find_place_ctx_correct E π _ _ _); rewrite/=/W.to_expr/=; done
+ end.
+Global Hint Extern 0 (IntoPlaceCtx _ _ _ _) => solve_into_place_ctx : typeclass_instances.
+
+(* we want this to be transparent because it's just a cosmetic wrapper around [stratify_ltype], but the same typeclasses should fire *)
+Global Typeclasses Transparent stratify_ltype_unblock.
+
+(** Tactic hint to compute a map lookup, either as [None] or [Some v]. *)
+Definition compute_map_lookup_goal `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) (k : K) (T : option V → iProp Σ) : iProp Σ :=
+ ∃ res, ⌜M !! k = res⌠∗ T res.
+#[global] Typeclasses Opaque compute_map_lookup_goal.
+Program Definition compute_map_lookup_hint `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) k res :
+ M !! k = res →
+ LiTactic (compute_map_lookup_goal M k) := λ a, {|
+ li_tactic_P T := T res;
+ |}.
+Next Obligation.
+ iIntros (?? K ?? V M k res Hlook T) "HT". iExists res. iFrame. done.
+Qed.
+
+(** Variant of [compute_map_lookup_goal] that expects a [Some v]. *)
+Definition compute_map_lookup_nofail_goal `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) (k : K) (T : V → iProp Σ) : iProp Σ :=
+ ∃ res, ⌜M !! k = Some res⌠∗ T res.
+#[global] Typeclasses Opaque compute_map_lookup_nofail_goal.
+Program Definition compute_map_lookup_nofail_hint `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) k res :
+ M !! k = Some res →
+ LiTactic (compute_map_lookup_nofail_goal M k) := λ a, {|
+ li_tactic_P T := T res;
+ |}.
+Next Obligation.
+ iIntros (?? K ?? V M k res Hlook T) "HT". iExists res. iFrame. done.
+Qed.
+
+(** Tactic hint to compute an iterated map lookup *)
+Definition compute_map_lookups_nofail_goal `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) (ks : list K) (T : (list V) → iProp Σ) : iProp Σ :=
+ ∃ res, ⌜Forall2 (λ k v, M !! k = Some v) ks res⌠∗ T (res).
+#[global] Typeclasses Opaque compute_map_lookups_nofail_goal.
+Program Definition compute_map_lookups_nofail_hint `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) ks res :
+ Forall2 (λ k v, M !! k = Some v) ks res →
+ LiTactic (compute_map_lookups_nofail_goal M ks) := λ a, {|
+ li_tactic_P T := T res;
+ |}.
+Next Obligation.
+ iIntros (?? K ?? V M ks res Hlook T) "HT". iExists res. iFrame. done.
+Qed.
+
+(** Tactic hint to simplify a map, e.g. compute deletes *)
+Definition simplify_gmap_goal `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) (T : gmap K V → iProp Σ) : iProp Σ :=
+ ∃ M', ⌜M = M'⌠∗ T M'.
+#[global] Typeclasses Opaque simplify_gmap_goal.
+Program Definition simplify_gmap_hint `{!typeGS Σ} `{Countable K} {V} (M M' : gmap K V) :
+ M = M' →
+ LiTactic (simplify_gmap_goal M) := λ a, {|
+ li_tactic_P T := T M';
+ |}.
+Next Obligation.
+ iIntros (?? K ?? V M M' -> T) "HT". iExists M'. iFrame. done.
+Qed.
+
+(** Tactic hint to simplify a lft map, e.g. compute deletes *)
+(* We don't actually require an equality here, since the map doesn't have any semantic meaning *)
+Definition opaque_eq {A} (a b : A) := True.
+Global Opaque opaque_eq.
+Definition simplify_lft_map_goal `{!typeGS Σ} `{Countable K} {V} (M : gmap K V) (T : gmap K V → iProp Σ) : iProp Σ :=
+ ∃ M', ⌜opaque_eq M M'⌠∗ T M'.
+#[global] Typeclasses Opaque simplify_lft_map_goal.
+Program Definition simplify_lft_map_hint `{!typeGS Σ} `{Countable K} {V} (M M' : gmap K V) :
+ opaque_eq M M' →
+ LiTactic (simplify_lft_map_goal M) := λ a, {|
+ li_tactic_P T := T M';
+ |}.
+Next Obligation.
+ iIntros (?? K ?? V M M' ? T) "HT". iExists M'. iFrame. done.
+Qed.
+
+(** Tactic hint to find a local lifetime and split it off from the context *)
+Definition llctx_find_llft_goal `{!typeGS Σ} (L : llctx) (κ : lft) (key : llctx_find_llft_key) (T : (list lft * llctx) → iProp Σ) : iProp Σ :=
+ ∃ L' κs, ⌜llctx_find_llft L κ key κs L'⌠∗ T (κs, L').
+#[global] Typeclasses Opaque llctx_find_llft_goal.
+Program Definition llctx_find_llft_hint `{!typeGS Σ} (L : llctx) (κ : lft) (key : llctx_find_llft_key) (κs : list lft) (L' : llctx) :
+ llctx_find_llft L κ key κs L' →
+ LiTactic (llctx_find_llft_goal L κ key) := λ H, {|
+ li_tactic_P T := T (κs, L');
+|}.
+Next Obligation.
+ iIntros (?? L κ key κs L' Hsplit T) "HL'". iExists L', κs. eauto.
+Qed.
+
+(** Tactic hint to compute a layout for a syn_type *)
+Definition compute_layout_goal `{!typeGS Σ} (st : syn_type) (T : layout → iProp Σ) : iProp Σ :=
+ ∃ ly, ⌜syn_type_has_layout st ly⌠∗ T ly.
+#[global] Typeclasses Opaque compute_layout_goal.
+Program Definition compute_layout_hint `{!typeGS Σ} (st : syn_type) (ly : layout) :
+ syn_type_has_layout st ly →
+ LiTactic (compute_layout_goal st) := λ a, {|
+ li_tactic_P T := T ly;
+ |}.
+Next Obligation.
+ iIntros (?? st ly Hly T) "HT". iExists ly. iFrame. done.
+Qed.
+
+(** Tactic hint to compute a struct_layout for a struct_layout_spec *)
+Definition compute_struct_layout_goal `{!typeGS Σ} (sls : struct_layout_spec) (T : struct_layout → iProp Σ) : iProp Σ :=
+ ∃ sl, ⌜struct_layout_spec_has_layout sls sl⌠∗ T sl.
+#[global] Typeclasses Opaque compute_struct_layout_goal.
+Program Definition compute_struct_layout_hint `{!typeGS Σ} (sls : struct_layout_spec) (sl : struct_layout) :
+ struct_layout_spec_has_layout sls sl →
+ LiTactic (compute_struct_layout_goal sls) := λ a, {|
+ li_tactic_P T := T sl;
+ |}.
+Next Obligation.
+ iIntros (?? sls sl Hly T) "HT". iExists sl. iFrame. done.
+Qed.
+
+(** Tactic hint to compute a semantic Rust type for a given syntactic [rust_type] *)
+Definition interpret_rust_type_goal `{!typeGS Σ} (lfts : gmap string lft) (sty : rust_type) (T : sigT type → iProp Σ) : iProp Σ :=
+ ∃ (rt : Type) (ty : type rt), T (existT _ ty).
+#[global] Typeclasses Opaque interpret_rust_type_goal.
+Definition interpret_rust_type_pure_goal `{!typeGS Σ} (lfts : gmap string lft) (sty : rust_type) {rt} (ty : type rt) := True.
+Global Typeclasses Opaque interpret_rust_type_pure_goal.
+Arguments interpret_rust_type_pure_goal : simpl never.
+Program Definition interpret_rust_type_hint `{!typeGS Σ} (lfts : gmap string lft) (sty : rust_type) {rt} (ty : type rt) :
+ interpret_rust_type_pure_goal lfts sty ty →
+ LiTactic (interpret_rust_type_goal lfts sty) := λ a, {|
+ li_tactic_P T := T (existT _ ty);
+ |}.
+Next Obligation.
+ iIntros (??? sty rt ty _ T) "Ha". simpl.
+ iExists _, _. done.
+Qed.
+
+Global Typeclasses Opaque llctx_find_llft_goal.
+Ltac solve_llctx_find_llft := fail "implement llctx_find_llft_solve".
+Global Hint Extern 10 (LiTactic (llctx_find_llft_goal _ _ _)) =>
+ eapply llctx_find_llft_hint; solve_llctx_find_llft : typeclass_instances.
+
+Global Typeclasses Opaque lctx_lft_alive_count_goal.
+Ltac solve_lft_alive_count := fail "implement solve_lft_alive_count".
+#[global] Hint Extern 10 (LiTactic (lctx_lft_alive_count_goal _ _ _)) =>
+ refine (lctx_lft_alive_count_hint _ _ _ _ _ _); solve_lft_alive_count : typeclass_instances.
+
+Global Typeclasses Opaque llctx_release_toks_goal.
+Ltac solve_llctx_release_toks := fail "implement solve_llctx_release_toks".
+#[global] Hint Extern 10 (LiTactic (llctx_release_toks_goal _ _)) =>
+ refine (llctx_release_toks_hint _ _ _ _); solve_llctx_release_toks : typeclass_instances.
+
+Global Typeclasses Opaque simplify_gmap_goal.
+Ltac solve_simplify_gmap := fail "implement solve_simplify_gmap".
+#[global] Hint Extern 10 (LiTactic (simplify_gmap_goal _)) =>
+ refine (simplify_gmap_hint _ _ _); solve_simplify_gmap : typeclass_instances.
+
+Global Typeclasses Opaque simplify_lft_map_goal.
+Ltac solve_simplify_lft_map := fail "implement solve_simplify_lft_map".
+#[global] Hint Extern 10 (LiTactic (simplify_lft_map_goal _)) =>
+ refine (simplify_lft_map_hint _ _ _); solve_simplify_lft_map : typeclass_instances.
+
+Global Typeclasses Opaque compute_map_lookup_goal.
+Ltac solve_compute_map_lookup := fail "implement solve_compute_map_lookup".
+#[global] Hint Extern 10 (LiTactic (compute_map_lookup_goal _ _)) =>
+ refine (compute_map_lookup_hint _ _ _ _); solve_compute_map_lookup : typeclass_instances.
+
+Global Typeclasses Opaque compute_map_lookup_nofail_goal.
+Ltac solve_compute_map_lookup_nofail := fail "implement solve_compute_map_lookup_nofail".
+#[global] Hint Extern 10 (LiTactic (compute_map_lookup_nofail_goal _ _)) =>
+ refine (compute_map_lookup_nofail_hint _ _ _ _); solve_compute_map_lookup_nofail : typeclass_instances.
+
+Global Typeclasses Opaque compute_map_lookups_nofail_goal.
+Ltac solve_compute_map_lookups_nofail := fail "implement solve_compute_map_lookups_nofail".
+#[global] Hint Extern 10 (LiTactic (compute_map_lookups_nofail_goal _ _)) =>
+ refine (compute_map_lookups_nofail_hint _ _ _ _); solve_compute_map_lookups_nofail : typeclass_instances.
+
+Global Typeclasses Opaque compute_layout_goal.
+Ltac solve_compute_layout := fail "implement solve_compute_layout".
+#[global] Hint Extern 1 (LiTactic (compute_layout_goal _)) =>
+ refine (compute_layout_hint _ _ _); solve_compute_layout : typeclass_instances.
+
+Global Typeclasses Opaque compute_struct_layout_goal.
+Ltac solve_compute_struct_layout := fail "implement solve_compute_struct_layout".
+#[global] Hint Extern 1 (LiTactic (compute_struct_layout_goal _)) =>
+ refine (compute_struct_layout_hint _ _ _); solve_compute_struct_layout : typeclass_instances.
+
+Global Typeclasses Opaque interpret_rust_type_goal.
+Ltac solve_interpret_rust_type := fail "implement solve_interpret_rust_type".
+#[global] Hint Extern 1 (LiTactic (interpret_rust_type_goal _ _)) =>
+ refine (interpret_rust_type_hint _ _ _ _); solve_interpret_rust_type : typeclass_instances.
+
+
+(** ** Generic context folding mechanism *)
+Section folding.
+ Context `{!typeGS Σ}.
+ (** We (formerly) use this primarily for unblocking the typing context when ending a lifetime *)
+
+ (* bundled ltypes *)
+ Record bltype := mk_bltype {
+ bltype_rt : Type;
+ bltype_rfn : place_rfn bltype_rt;
+ bltype_ltype : ltype bltype_rt;
+ }.
+ Definition type_ctx := list (loc * bltype).
+ Implicit Types (tctx : type_ctx).
+
+ Definition type_ctx_interp π tctx : iProp Σ :=
+ [∗ list] i ∈ tctx, let '(l, bt) := i in l â—â‚—[Ï€, Owned false] bt.(bltype_rfn) @ bt.(bltype_ltype).
+ Lemma type_ctx_interp_cons π l t tctx :
+ type_ctx_interp Ï€ ((l, t) :: tctx) ⊣⊢ (l â—â‚—[Ï€, Owned false] t.(bltype_rfn) @ t.(bltype_ltype)) ∗ type_ctx_interp Ï€ tctx.
+ Proof. iApply big_sepL_cons. Qed.
+
+ (* TODO maybe we should just put the locations in the tctx queue, instead of the whole type assignment? We're going to look for them in the context anyways. *)
+ Section folder.
+ Arguments delayed_prop : simpl never.
+ Context {Acc : Type} (Acc_interp : Acc → iProp Σ).
+ (** Initializer for doing a context fold with action [m].
+ The automation will use this typing judgment as a hint to gather up the context and
+ start folding over the context.
+
+ Clients that want to initiate context folding should generate a goal with this judgment,
+ with a [m] that identifies the folding action.
+ *)
+ Definition typed_pre_context_fold (π : thread_id) (E : elctx) (L : llctx) {M} (m : M) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ logical_step F (∃ L', llctx_interp L' ∗ T L').
+ (* no TC for this -- typing rules for this will be directly applied by Ltac automation *)
+
+ (** The main context folding judgment. [tctx] is the list of types to fold. *)
+ Definition typed_context_fold {M} (π : thread_id) (E : elctx) (L : llctx) (m : M) (tctx : list loc) (acc : Acc) (T : llctx → M → Acc → iProp Σ) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ logical_step F (Acc_interp acc) ={F}=∗
+ ∃ L' acc' m', llctx_interp L' ∗ logical_step F (Acc_interp acc') ∗ T L' m' acc').
+ Class TypedContextFold (Ï€ : thread_id) (E : elctx) (L : llctx) {M} (m : M) (tctx : list loc) (acc : Acc) :=
+ typed_context_fold_proof T : iProp_to_Prop (typed_context_fold π E L m tctx acc T).
+ Global Hint Mode TypedContextFold + + + + + + + : typeclass_instances.
+
+ (**
+ This does a context fold step, by transforming [tctx] and [acc].
+ Clients of context folding should register instances of this (for the right [m]) in
+ order to register the folding action.
+ Every such rule should make progress, so that the whole thing is terminating.
+ *)
+ Definition typed_context_fold_step {M} (π : thread_id) (E : elctx) (L : llctx) (m : M) (l : loc) {rt} (lt : ltype rt) (r : place_rfn rt) (tctx : list loc) (acc : Acc) (T : llctx → M → Acc → iProp Σ) : iProp Σ :=
+ (∀ F, ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗
+ logical_step F (Acc_interp acc) -∗
+ l â—â‚—[ Ï€, Owned false] r @ lt -∗ |={F}=>
+ (∃ L' acc' m', llctx_interp L' ∗ logical_step F (Acc_interp acc') ∗ T L' m' acc')).
+ Class TypedContextFoldStep {M} (Ï€ : thread_id) (E : elctx) (L : llctx) (m : M) (l : loc) {rt} (lt : ltype rt) (r : place_rfn rt) (tctx : list loc) (acc : Acc) :=
+ typed_context_fold_step_proof T : iProp_to_Prop (typed_context_fold_step π E L m l lt r tctx acc T).
+ Global Hint Mode TypedContextFoldStep + + + + + + + + + + + : typeclass_instances.
+
+ (** Terminator for the context folding typing process.
+ It gathers up the folding result and takes a program step to strip the accumulated laters.
+ *)
+ Definition typed_context_fold_end (π : thread_id) (E : elctx) (L : llctx) (acc : Acc) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ ⌜lft_userE ⊆ F⌠-∗
+ rrust_ctx -∗
+ elctx_interp E -∗
+ llctx_interp L -∗
+ logical_step F (Acc_interp acc) -∗
+ logical_step F (∃ L2, llctx_interp L2 ∗ T L2).
+ (* no type class -- we should directly apply the typing rule for this. *)
+
+ (** Finish context folding when the whole list has been processed. *)
+ Lemma typed_context_fold_nil {M} E L π (m : M) acc T :
+ T L m acc
+ ⊢ typed_context_fold π E L m [] acc T.
+ Proof.
+ iIntros "HT".
+ iIntros (? ??) "#CTX #HE HL Hdel".
+ iExists L, acc, m. by iFrame.
+ Qed.
+ Global Instance typed_context_fold_nil_inst {M} E L π (m : M) acc :
+ TypedContextFold π E L m [] acc :=
+ λ T, i2p (typed_context_fold_nil E L π m acc T).
+
+ (** Take a context folding step. *)
+ (* We make this optional, because some of the items may already have been used for stratifying other types (e.g. for invariant folding) *)
+ Lemma typed_context_fold_cons {M} π E L (m : M) l (tctx : list loc) acc T :
+ find_in_context (FindOptLoc l π) (λ res,
+ match res with
+ | None => typed_context_fold π E L m tctx acc T
+ | Some (existT rt' (lt', r', bk')) =>
+ ⌜bk' = Owned false⌠∗ (typed_context_fold_step π E L m l lt' r' tctx acc T)
+ end)
+ ⊢ typed_context_fold π E L m (l :: tctx) acc T.
+ Proof.
+ rewrite /FindOptLoc. iIntros "(%res & HT)".
+ destruct res as [ [rt' [[lt' r'] bk']] | ]; simpl.
+ - iDestruct "HT" as "(Hl & HT)". iPoseProof ("HT") as "(-> & HT)".
+ iIntros (? ??) "#CTX #HE HL Hdel".
+ iDestruct ("HT" with "[//] [//] CTX HE HL Hdel Hl") as ">Hs".
+ done.
+ - iDestruct "HT" as "(_ & HT)". iApply "HT".
+ Qed.
+ Global Instance typed_context_fold_cons_inst {M} E L π (m : M) l (tctx : list loc) acc :
+ TypedContextFold π E L m (l :: tctx) acc :=
+ λ T, i2p (typed_context_fold_cons π E L m l tctx acc T).
+
+ (** Typing rule for ending context folding.
+ Yields the accumulated result and continues with the next statement.
+ *)
+ Lemma type_context_fold_end E L π acc T :
+ (introduce_with_hooks E L (Acc_interp acc) T)
+ ⊢ typed_context_fold_end π E L acc T.
+ Proof.
+ iIntros "Hs". iIntros (? ??) "#(LFT & TIME & LLCTX) #HE HL Hstep".
+ iApply logical_step_fupd.
+ iApply (logical_step_wand with "Hstep").
+ iIntros "Hacc". iMod ("Hs" with "[//] HE HL Hacc") as "(%L3 & HL & HT)".
+ eauto with iFrame.
+ Qed.
+
+ (** Initialize context folding.
+ This rule should be directly applied by Ltac automation, after it has gathere Inherit κ1 InheritDynIncl (llft_elt_toks κs)d up the [tctx]
+ from the Iris context.
+ *)
+ Lemma typed_context_fold_init {M} (init_acc : Acc) E L π (m : M) (tctx : list loc) Φ T :
+ Acc_interp init_acc ∗
+ typed_context_fold π E L m tctx init_acc (λ L' m' acc, Φ m' acc ∗ typed_context_fold_end π E L' acc T) -∗
+ typed_pre_context_fold π E L m T.
+ Proof.
+ iIntros "(Hinit & Hfold)".
+ iIntros (???) "#CTX #HE HL".
+ iApply fupd_logical_step.
+ iDestruct ("Hfold" $! F with "[//] [//] CTX HE HL [Hinit]") as ">Hs".
+ { iApply logical_step_intro. iFrame. }
+ iDestruct "Hs" as (L' acc' m') "(HL & Hdel & ? & Hs)".
+ rewrite /typed_context_fold_end.
+ iApply ("Hs" with "[//] [//] CTX HE HL Hdel").
+ Qed.
+ End folder.
+
+ (* Unfold the type context so Lithium separates the big_sep *)
+ Lemma simplify_type_context π tctx T :
+ (([∗ list] i ∈ tctx, let '(l, bt) := i in l â—â‚—[ Ï€, Owned false] bltype_rfn bt @ bltype_ltype bt) -∗ T) ⊢
+ simplify_hyp (type_ctx_interp π tctx) T.
+ Proof. done. Qed.
+ Global Instance simplify_type_context_inst π tctx :
+ SimplifyHyp (type_ctx_interp π tctx) (Some 0%N) :=
+ λ T, i2p (simplify_type_context π tctx T).
+End folding.
+
+Section relate_list.
+ Context `{!typeGS Σ}.
+ (** A generalization of subsume_list. *)
+ Record FoldableRelation {A B} : Type := FR {
+ fr_rel : elctx → llctx → nat → A → B → iProp Σ → iProp Σ;
+ fr_cap : nat;
+ fr_inv : Prop;
+ fr_core_rel : elctx → llctx → nat → A → B → iProp Σ;
+ fr_elim_mode : bool;
+ fr_elim E L i a b :
+ ⊢ if fr_elim_mode then
+ ∀ T F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ fr_rel E L i a b T ={F}=∗ fr_core_rel E L i a b ∗ llctx_interp L ∗ T
+ else ∀ T, fr_rel E L i a b T -∗ fr_core_rel E L i a b ∗ T;
+ }.
+ Arguments fr_rel {_ _}.
+ Arguments fr_core_rel {_ _}.
+ Arguments fr_elim_mode {_ _}.
+
+ Definition relate_list {A B} (E : elctx) (L : llctx) (ig : list nat) (l1 : list A) (l2 : list B) (i0 : nat) (R : FoldableRelation) (T : iProp Σ) : iProp Σ :=
+ if R.(fr_elim_mode) then
+ (∀ F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L ={F}=∗
+ (⌜i0 + length l1 ≤ R.(fr_cap)⌠-∗ ⌜R.(fr_inv)⌠-∗
+ [∗ list] i ↦ a; b ∈ l1; l2, if decide ((i + i0)%nat ∈ ig) then True else R.(fr_core_rel) E L (i + i0)%nat a b) ∗ llctx_interp L ∗ T)%I
+ else ((⌜i0 + length l1 ≤ R.(fr_cap)⌠-∗ ⌜R.(fr_inv)⌠-∗
+ [∗ list] i ↦ a; b ∈ l1; l2, if decide ((i + i0)%nat ∈ ig) then True else R.(fr_core_rel) E L (i + i0)%nat a b) ∗ T)%I
+ .
+ Class RelateList {A B} (E : elctx) (L : llctx) (ig : list nat) (l1 : list A) (l2 : list B) (i0 : nat) (R : FoldableRelation) : Type :=
+ relate_list_proof T : iProp_to_Prop (relate_list E L ig l1 l2 i0 R T).
+ Global Hint Mode RelateList + + + + + + ! + + : typeclass_instances.
+
+ Lemma relate_list_ig_cons_le {A B} E L ig (j i0 : nat) (l1 : list A) (l2 : list B) (R : FoldableRelation) :
+ (j < i0)%nat →
+ ([∗ list] i ↦ a; b ∈ l1; l2, if decide (i + i0 ∈ (j :: ig))%nat then True else fr_core_rel R E L (i + i0)%nat a b) -∗
+ ([∗ list] i ↦ a; b ∈ l1; l2, if decide (i + i0 ∈ (ig))%nat then True else fr_core_rel R E L (i + i0)%nat a b).
+ Proof.
+ intros Hlt.
+ iInduction l1 as [ | a l1] "IH" forall (j i0 l2 Hlt); simpl; first by eauto.
+ destruct l2 as [ | b l2]; simpl; first by eauto.
+ case_decide as Hel.
+ - apply elem_of_cons in Hel as [ ? | ?]; first lia.
+ rewrite decide_True; last done. rewrite !left_id.
+ iIntros "Ha". iApply (big_sepL2_mono); first last.
+ { iApply ("IH" $! _ (S i0)); first last.
+ { iApply big_sepL2_mono; last done. iIntros. rewrite Nat.add_succ_r//. }
+ iPureIntro. lia. }
+ iIntros. rewrite Nat.add_succ_r//.
+ - apply not_elem_of_cons in Hel as [_ Hel].
+ rewrite decide_False; last done.
+ iIntros "($ & Ha)". iApply (big_sepL2_mono); first last.
+ { iApply ("IH" $! _ (S i0)); first last.
+ { iApply big_sepL2_mono; last done. iIntros. rewrite Nat.add_succ_r//. }
+ iPureIntro. lia. }
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+
+ Lemma relate_list_replicate_elim_full {A B} E L ig n (a : A) (b : B) i0 (R : FoldableRelation) T :
+ R.(fr_elim_mode) = true →
+ (rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ ⌜R.(fr_inv)⌠-∗
+ □ ∀ i, ⌜(i0 ≤ i < R.(fr_cap))%nat⌠-∗ ⌜i ∉ ig⌠-∗ R.(fr_core_rel) E L i a b) -∗
+ T -∗ relate_list E L ig (replicate n a) (replicate n b) i0 R T.
+ Proof.
+ intros Ha. rewrite /relate_list Ha.
+ iIntros "HR HT" (F ?) "#CTX #HE HL".
+ iPoseProof ("HR" with "CTX HE HL") as "#HR".
+ iFrame "HT HL".
+ iInduction n as [ | n] "IH" forall (i0) "HR"; simpl.
+ { by iFrame. }
+ iMod ("IH" $! (S i0) with "[]") as "Ha".
+ { iModIntro. iIntros (Hinv i Hi Hnel). iModIntro. iApply "HR"; iPureIntro; first [done | lia]. }
+ iModIntro. iIntros "%Hinv %Hi".
+ case_decide.
+ - iR.
+ iApply (big_sepL2_wand with "(Ha [] [//])").
+ { iPureIntro. lia. }
+ iApply big_sepL2_intro; first (by rewrite !replicate_length).
+ iModIntro. iIntros (?????). rewrite Nat.add_succ_r. eauto.
+ - iSplitR. { iApply "HR"; simpl in Hinv; iPureIntro; first [lia | done]. }
+ iApply (big_sepL2_mono with "(Ha [] [//])"); last by (iPureIntro; lia).
+ iIntros (?????). rewrite Nat.add_succ_r. done.
+ Qed.
+ Lemma relate_list_replicate_elim_weak {A B} E L ig n (a : A) (b : B) i0 (R : FoldableRelation) T :
+ R.(fr_elim_mode) = false →
+ (⌜R.(fr_inv)⌠-∗ □ ∀ i, ⌜(i0 ≤ i < R.(fr_cap))%nat⌠-∗ ⌜i ∉ ig⌠-∗ R.(fr_core_rel) E L i a b) -∗
+ T -∗ relate_list E L ig (replicate n a) (replicate n b) i0 R T.
+ Proof.
+ intros Ha. rewrite /relate_list Ha.
+ iIntros "HR $". iIntros "%Hinv %Hi". iPoseProof ("HR" with "[//]") as "#HR".
+ iInduction n as [ | n] "IH" forall (i0 Hinv Hi) "HR"; simpl.
+ { by iFrame. }
+ iPoseProof ("IH" $! (S i0) with "[] [//] []") as "Ha".
+ { iPureIntro. simpl in Hinv. lia. }
+ { iModIntro. iIntros (i ? Hnel). iApply "HR"; iPureIntro; first [done | lia]. }
+ case_decide.
+ - iR.
+ iApply (big_sepL2_wand with "Ha").
+ iApply big_sepL2_intro; first (by rewrite !replicate_length).
+ iModIntro. iIntros (?????). rewrite Nat.add_succ_r. eauto.
+ - iSplitR. { iApply "HR"; simpl in Hinv; iPureIntro; first [lia | done]. }
+ iApply (big_sepL2_mono with "Ha"). iIntros (?????). rewrite Nat.add_succ_r. done.
+ Qed.
+
+ Local Lemma relate_list_insert_in_ig' {A B} E L (ig : list nat) (l1 : list A) (l2 : list B) (i0 : nat) i x R :
+ (i0 + i ∈ ig)%nat →
+ (⌜i0 + length l1 ≤ fr_cap R⌠-∗ ⌜fr_inv R⌠-∗ [∗ list] i↦a;b ∈ l1;l2, if decide ((i + i0)%nat ∈ ig) then True else fr_core_rel R E L (i + i0) a b) -∗
+ (⌜i0 + length (<[ i:= x]> l1) ≤ fr_cap R⌠-∗ ⌜fr_inv R⌠-∗ [∗ list] i↦a;b ∈ <[i:=x]>l1;l2, if decide ((i + i0)%nat ∈ ig) then True else fr_core_rel R E L (i + i0) a b).
+ Proof.
+ iIntros (Hel) "Ha %Hinv %".
+ iSpecialize ("Ha" with "[] [//]").
+ { rewrite insert_length in Hinv. done. }
+ iInduction l1 as [ | a l1] "IH" forall (l2 i i0 Hel Hinv); simpl; first done.
+ destruct l2 as [ | b l2]. { destruct i; done. }
+ destruct i as [ | i].
+ - simpl.
+ case_decide; first done.
+ rewrite Nat.add_0_r in Hel. done.
+ - simpl.
+ case_decide.
+ + iDestruct "Ha" as "(_ & Ha)". iR.
+ iPoseProof ("IH" $! _ _ (S i0) with "[] [] [Ha]") as "Hi"; first last.
+ { iApply (big_sepL2_mono); last iApply "Hi". iIntros. rewrite -Nat.add_succ_r//. }
+ { iApply (big_sepL2_mono with "Ha"). iIntros. rewrite -Nat.add_succ_r//. }
+ { simpl in Hinv. iPureIntro. lia. }
+ { iPureIntro. move: Hel. rewrite Nat.add_succ_r//. }
+ + iDestruct "Ha" as "($ & Ha)".
+ iPoseProof ("IH" $! _ _ (S i0) with "[] [] [Ha]") as "Hi"; first last.
+ { iApply (big_sepL2_mono); last iApply "Hi". iIntros. rewrite -Nat.add_succ_r//. }
+ { iApply (big_sepL2_mono with "Ha"). iIntros. rewrite -Nat.add_succ_r//. }
+ { simpl in Hinv. iPureIntro. lia. }
+ { iPureIntro. move: Hel. rewrite Nat.add_succ_r//. }
+ Qed.
+ Lemma relate_list_insert_in_ig {A B} E L ig (l1 : list A) (l2 : list B) (i0 : nat) i x R T `{CanSolve (i0 + i ∈ ig)%nat} :
+ relate_list E L ig l1 l2 i0 R T
+ ⊢ relate_list E L ig (<[i := x]> l1) l2 i0 R T.
+ Proof.
+ match goal with H : CanSolve _ |- _ => unfold CanSolve in H; rename H into Hel end.
+ iIntros "Ha".
+ rewrite /relate_list; destruct fr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Ha" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. by iApply relate_list_insert_in_ig'.
+ - iDestruct "Ha" as "(Ha & $)". by iApply relate_list_insert_in_ig'.
+ Qed.
+ Global Instance relate_list_insert_in_ig_inst {A B} E L ig (l1 : list A) (l2 : list B) (i0 : nat) i x R `{!CanSolve (i0 + i ∈ ig)%nat} :
+ RelateList E L ig (<[i := x]> l1) l2 i0 R :=
+ λ T, i2p (relate_list_insert_in_ig E L ig l1 l2 i0 i x R T).
+
+ Lemma relate_list_cons_l {A B} E L ig (l1 : list A) (l2 : list B) i0 R a T :
+ ⌜i0 ∉ ig⌠∗ (∃ b l2', ⌜l2 = b :: l2'⌠∗
+ R.(fr_rel) E L i0 a b (relate_list E L ig l1 l2' (S i0) R T))
+ ⊢ relate_list E L ig (a :: l1) l2 i0 R T.
+ Proof.
+ iIntros "(%Hnel & %b & %l2' & -> & HR)".
+ rewrite /relate_list. iPoseProof (fr_elim R) as "Hx". destruct fr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Hx" with "[//] CTX HE HL HR") as "(HR & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ rewrite big_sepL2_cons. simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL2_mono with "Ha").
+ iIntros. rewrite Nat.add_succ_r//.
+ - iPoseProof ("Hx" with "HR") as "(Ha & Hb & $)".
+ iIntros "%Hinv %". iSpecialize ("Hb" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ rewrite big_sepL2_cons. simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL2_mono with "Hb").
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+ Global Instance relate_list_cons_l_inst {A B} E L ig (l1 : list A) (l2 : list B) i0 a R :
+ RelateList E L ig (a :: l1) l2 i0 R :=
+ λ T, i2p (relate_list_cons_l E L ig l1 l2 i0 R a T).
+
+ Local Lemma relate_list_insert_not_in_ig' {A B} E L ig (l1 : list A) (l2 : list B) (R : FoldableRelation) i0 i a b :
+ (i0 + i ∉ ig)%nat →
+ i < length l1 →
+ l2 !! i = Some b →
+ fr_core_rel R E L (i0 + i) a b -∗
+ (⌜i0 + length l1 ≤ fr_cap R⌠-∗ ⌜fr_inv R⌠-∗ [∗ list] i1↦a0;b0 ∈ l1;l2, if decide ((i1 + i0)%nat ∈ (i0 + i)%nat :: ig) then True else fr_core_rel R E L (i1 + i0) a0 b0) -∗
+ (⌜i0 + length (<[i:=a]> l1) ≤ fr_cap R⌠-∗ ⌜fr_inv R⌠-∗ [∗ list] i1↦a0;b0 ∈ <[i:=a]> l1;l2, if decide ((i1 + i0)%nat ∈ ig) then True else fr_core_rel R E L (i1 + i0) a0 b0).
+ Proof.
+ iIntros (Hnel Hi Hlook) "HR Ha %Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { iPureIntro. rewrite insert_length in Hinv. lia. }
+ iInduction l1 as [ | a' l1] "IH" forall (l2 i i0 Hnel Hi Hlook Hinv).
+ { simpl in *. lia. }
+ destruct i as [ | i]; simpl.
+ - destruct l2 as [ | b' l2]; first done.
+ injection Hlook as ->.
+ rewrite !big_sepL2_cons.
+ simpl. iDestruct "Ha" as "(_ & Ha)".
+ rewrite decide_False; first last. { move: Hnel. rewrite Nat.add_0_r//. }
+ rewrite Nat.add_0_r. iFrame.
+ iApply big_sepL2_mono; first last.
+ { iApply (relate_list_ig_cons_le); first last.
+ { iApply big_sepL2_mono; last done. iIntros. rewrite -Nat.add_succ_r//. }
+ lia.
+ }
+ iIntros. rewrite Nat.add_succ_r//.
+ - destruct l2 as [ | b' l2]; first done.
+ simpl in Hlook.
+ rewrite !big_sepL2_cons/=.
+ destruct (decide (i0 ∈ ig)).
+ + iR. iDestruct "Ha" as "(_ & Ha)".
+ iApply big_sepL2_mono; first last.
+ { iApply ("IH" with "[] [] [] [] [HR]"); first last.
+ - iApply big_sepL2_mono; last done. iIntros. rewrite -(Nat.add_succ_r _ i0) (Nat.add_succ_r _ i) //.
+ - rewrite Nat.add_succ_r. done.
+ - iPureIntro. simpl in Hinv. lia.
+ - done.
+ - simpl in *; iPureIntro. lia.
+ - iPureIntro. move: Hnel. rewrite Nat.add_succ_r. done.
+ }
+ iIntros. rewrite Nat.add_succ_r//.
+ + rewrite decide_False; first last. { apply not_elem_of_cons. split; last done. lia. }
+ iDestruct "Ha" as "($ & Ha)".
+ iApply big_sepL2_mono; first last.
+ { iApply ("IH" with "[] [] [] [] [HR]"); first last.
+ - iApply big_sepL2_mono; last done. iIntros. rewrite -(Nat.add_succ_r _ i0) (Nat.add_succ_r _ i) //.
+ - rewrite Nat.add_succ_r. done.
+ - iPureIntro. simpl in Hinv. lia.
+ - done.
+ - simpl in *; iPureIntro. lia.
+ - iPureIntro. move: Hnel. rewrite Nat.add_succ_r. done.
+ }
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+
+ Lemma relate_list_insert_not_in_ig {A B} E L ig (l1 : list A) (l2 : list B) (R : FoldableRelation) i0 i a T `{CanSolve (i0 + i ∉ ig)%nat} :
+ ⌜i < length l1⌠∗
+ (∃ b, ⌜l2 !! i = Some b⌠∗ R.(fr_rel) E L (i0 + i) a b (relate_list E L ((i0 + i) :: ig)%nat l1 l2 i0 R T))
+ ⊢ relate_list E L ig (<[i := a]> l1) l2 i0 R T.
+ Proof.
+ match goal with H : CanSolve _ |- _ => rewrite /CanSolve in H; rename H into Hnel end.
+ iIntros "(%Hi & %b & %Hlook & HR)".
+ iPoseProof (fr_elim R) as "Hx".
+ rewrite /relate_list. destruct fr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Hx" with "[//] CTX HE HL HR") as "(HR & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. iApply (relate_list_insert_not_in_ig' with "HR Ha"); done.
+ - iPoseProof ("Hx" with "HR") as "(HR & Ha & $)".
+ iApply (relate_list_insert_not_in_ig' with "HR Ha"); done.
+ Qed.
+ Global Instance relate_list_insert_not_in_ig_inst {A B} E L ig (l1 : list A) (l2 : list B) R (i0 : nat) i a `{!CanSolve (i0 + i ∉ ig)%nat} :
+ RelateList E L ig (<[i := a]> l1) l2 i0 R :=
+ λ T, i2p (relate_list_insert_not_in_ig E L ig l1 l2 R i0 i a T).
+
+ Lemma relate_list_app_l {A B} E L ig (l1 l1' : list A) (l2 : list B) (R : FoldableRelation) (i0 : nat) T :
+ relate_list E L ig l1 (take (length l1) l2) i0 R (relate_list E L ig l1' (drop (length l1) l2) (length l1 + i0)%nat R T)
+ ⊢ relate_list E L ig (l1 ++ l1') l2 i0 R T.
+ Proof.
+ iIntros "Ha".
+ rewrite /relate_list; destruct fr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Ha" with "[//] CTX HE HL") as "(Ha & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hb & $ & $)".
+ iModIntro. iIntros "%Hinv %".
+ rewrite app_length in Hinv.
+ iSpecialize ("Ha" with "[] [//]").
+ { iPureIntro. lia. }
+ iSpecialize ("Hb" with "[] [//]").
+ { iPureIntro. lia. }
+ rewrite -{3}(take_drop (length l1) l2).
+ iApply (big_sepL2_app with "Ha").
+ iApply (big_sepL2_mono with "Hb").
+ iIntros. rewrite Nat.add_assoc [(k + _)%nat]Nat.add_comm//.
+ - iDestruct "Ha" as "(Ha & Hb & $)". iIntros "%Hinv %".
+ rewrite app_length in Hinv.
+ iSpecialize ("Ha" with "[] [//]").
+ { iPureIntro. lia. }
+ iSpecialize ("Hb" with "[] [//]").
+ { iPureIntro. lia. }
+ rewrite -{3}(take_drop (length l1) l2).
+ iApply (big_sepL2_app with "Ha").
+ iApply (big_sepL2_mono with "Hb").
+ iIntros. rewrite Nat.add_assoc [(k + _)%nat]Nat.add_comm//.
+ Qed.
+ Global Instance relate_list_app_l_inst {A B} E L ig (l1 l1' : list A) (l2 : list B) R i0 :
+ RelateList E L ig (l1 ++ l1') l2 i0 R :=
+ λ T, i2p (relate_list_app_l E L ig l1 l1' l2 R i0 T).
+End relate_list.
+
+Section relate_hlist.
+ Context `{!typeGS Σ}.
+ (** A generalization of subsume_list. *)
+ Record HetFoldableRelation {A} {G : A → Type} {H : A → Type} : Type := HFR {
+ hfr_rel : elctx → llctx → nat → ∀ {x : A}, G x → H x → iProp Σ → iProp Σ;
+ hfr_cap : nat;
+ hfr_inv : Prop;
+ hfr_core_rel : elctx → llctx → nat → ∀ {x : A}, G x → H x → iProp Σ;
+ hfr_elim_mode : bool;
+ hfr_elim E L i (x : A) (a : G x) (b : H x) :
+ ⊢ if hfr_elim_mode then
+ ∀ T F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ hfr_rel E L i a b T ={F}=∗ hfr_core_rel E L i a b ∗ llctx_interp L ∗ T
+ else ∀ T, hfr_rel E L i a b T -∗ hfr_core_rel E L i a b ∗ T;
+ }.
+ Arguments hfr_rel {_ _ _}.
+ Arguments hfr_core_rel {_ _ _}.
+ Arguments hfr_elim_mode {_ _ _}.
+
+ Definition relate_hlist {A} {G H : A → Type} (E : elctx) (L : llctx) (ig : list nat) (Xs : list A) (l1 : hlist G Xs) (l2 : hlist H Xs) (i0 : nat) (R : @HetFoldableRelation A G H) (T : iProp Σ) : iProp Σ :=
+ if R.(hfr_elim_mode) then
+ (∀ F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L ={F}=∗
+ (⌜i0 + length Xs ≤ R.(hfr_cap)⌠-∗ ⌜R.(hfr_inv)⌠-∗
+ [∗ list] i ↦ p ∈ hzipl2 _ l1 l2, let '(existT _ (a, b)) := (p : (sigT (λ x : A, G x * H x)%type)) in
+ if decide ((i + i0)%nat ∈ ig) then True else
+ R.(hfr_core_rel) E L (i + i0)%nat _ a b) ∗ llctx_interp L ∗ T)%I
+ else ((⌜i0 + length Xs ≤ R.(hfr_cap)⌠-∗ ⌜R.(hfr_inv)⌠-∗
+ [∗ list] i ↦ p ∈ hzipl2 _ l1 l2, let '(existT _ (a, b)) := p in
+ if decide ((i + i0)%nat ∈ ig) then True else R.(hfr_core_rel) E L (i + i0)%nat _ a b) ∗ T)%I
+ .
+ Class RelateHList {A} {G H : A → Type} (E : elctx) (L : llctx) (ig : list nat) (Xs : list A) (l1 : hlist G Xs) (l2 : hlist H Xs) (i0 : nat) (R : @HetFoldableRelation A G H) : Type :=
+ relate_hlist_proof T : iProp_to_Prop (relate_hlist E L ig Xs l1 l2 i0 R T).
+ Global Hint Mode RelateHList + + + + + + + + ! + + : typeclass_instances.
+
+ Lemma relate_hlist_nil {A} {G H : A → Type} E L ig (l1 : hlist G []) (l2 : hlist H []) i0 R T :
+ T ⊢ relate_hlist E L ig [] l1 l2 i0 R T.
+ Proof.
+ iIntros "HT". rewrite /relate_hlist. destruct hfr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iFrame. iIntros "!> _ _". inv_hlist l1; inv_hlist l2. done.
+ - iFrame. iIntros (??). inv_hlist l1; inv_hlist l2; done.
+ Qed.
+ Global Instance relate_hlist_nil_inst {A} {G H : A → Type} E L ig (l1 : hlist G []) (l2 : hlist H []) i0 R :
+ RelateHList E L ig [] (l1) l2 i0 R :=
+ λ T, i2p (relate_hlist_nil E L ig l1 l2 i0 R T).
+
+ Lemma relate_hlist_cons {A} {G H : A → Type} E L ig (X : A) (Xs : list A) (l1 : hlist G (X :: Xs)) (l2 : hlist H (X :: Xs)) i0 R T :
+ ⌜i0 ∉ ig⌠∗ (∃ a l1' b l2', ⌜l1 = a +:: l1'⌠∗ ⌜l2 = b +:: l2'⌠∗
+ R.(hfr_rel) E L i0 _ a b (relate_hlist E L ig Xs l1' l2' (S i0) R T))
+ ⊢ relate_hlist E L ig (X :: Xs) l1 l2 i0 R T.
+ Proof.
+ iIntros "(%Hnel & %a & %l1' & %b & %l2' & -> & -> & HR)".
+ rewrite /relate_hlist. iPoseProof (hfr_elim R) as "Hx". destruct hfr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Hx" with "[//] CTX HE HL HR") as "(HR & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL_mono with "Ha").
+ iIntros. rewrite Nat.add_succ_r//.
+ - iPoseProof ("Hx" with "HR") as "(Ha & Hb & $)".
+ iIntros "%Hinv %". iSpecialize ("Hb" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL_mono with "Hb").
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+ Global Instance relate_hlist_cons_l_inst {A} {G H} E L ig (X : A) (Xs : list A) (l1 : hlist G (X::Xs)) (l2 : hlist H (X :: Xs)) i0 R :
+ RelateHList E L ig (X :: Xs) (l1) l2 i0 R :=
+ λ T, i2p (relate_hlist_cons E L ig X Xs l1 l2 i0 R T).
+
+ (* TODO more instances similar to the ones for relate_list *)
+End relate_hlist.
+
+(*
+Section relate_hplist.
+ Context `{!typeGS Σ}.
+
+ Definition relate_hplist {A} {G : A → Type} (E : elctx) (L : llctx) (ig : list nat) (Xs : list A) (l1 : hlist G Xs) (l2 : plist G Xs) (i0 : nat) (R : @HetFoldableRelation A G) (T : iProp Σ) : iProp Σ :=
+ if R.(hfr_elim_mode) then
+ (∀ F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L ={F}=∗
+ (⌜i0 + length Xs ≤ R.(hfr_cap)⌠-∗ ⌜R.(hfr_inv)⌠-∗
+ [∗ list] i ↦ p ∈ hzipl2 _ l1 l2, let '(existT _ (a, b)) := (p : (sigT (λ x : A, G x * G x)%type)) in
+ if decide ((i + i0)%nat ∈ ig) then True else
+ R.(hfr_core_rel) E L (i + i0)%nat _ a b) ∗ llctx_interp L ∗ T)%I
+ else ((⌜i0 + length Xs ≤ R.(hfr_cap)⌠-∗ ⌜R.(hfr_inv)⌠-∗
+ [∗ list] i ↦ p ∈ hzipl2 _ l1 l2, let '(existT _ (a, b)) := p in
+ if decide ((i + i0)%nat ∈ ig) then True else R.(hfr_core_rel) E L (i + i0)%nat _ a b) ∗ T)%I
+ .
+ Class RelateHList {A} {G : A → Type} (E : elctx) (L : llctx) (ig : list nat) (Xs : list A) (l1 : hlist G Xs) (l2 : hlist G Xs) (i0 : nat) (R : @HetFoldableRelation A G) : Type :=
+ relate_hlist_proof T : iProp_to_Prop (relate_hlist E L ig Xs l1 l2 i0 R T).
+
+ Lemma relate_hlist_nil {A} {G : A → Type} E L ig (l1 : hlist G []) (l2 : hlist G []) i0 R T :
+ T -∗
+ relate_hlist E L ig [] l1 l2 i0 R T.
+ Proof.
+ iIntros "HT". rewrite /relate_hlist. destruct hfr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iFrame. iIntros "!> _ _". inv_hlist l1; inv_hlist l2. done.
+ - iFrame. iIntros (??). inv_hlist l1; inv_hlist l2; done.
+ Qed.
+ Global Instance relate_hlist_nil_inst {A} {G : A → Type} E L ig (l1 : hlist G []) (l2 : hlist G []) i0 R :
+ RelateHList E L ig [] (l1) l2 i0 R :=
+ λ T, i2p (relate_hlist_nil E L ig l1 l2 i0 R T).
+
+ Lemma relate_hlist_cons {A} {G : A → Type} E L ig (X : A) (Xs : list A) (l1 : hlist G (X :: Xs)) (l2 : hlist G (X :: Xs)) i0 R T :
+ ⌜i0 ∉ ig⌠∗ (∃ a l1' b l2', ⌜l1 = a +:: l1'⌠∗ ⌜l2 = b +:: l2'⌠∗
+ R.(hfr_rel) E L i0 _ a b (relate_hlist E L ig Xs l1' l2' (S i0) R T)) -∗
+ relate_hlist E L ig (X :: Xs) l1 l2 i0 R T.
+ Proof.
+ iIntros "(%Hnel & %a & %l1' & %b & %l2' & -> & -> & HR)".
+ rewrite /relate_hlist. iPoseProof (hfr_elim R) as "Hx". destruct hfr_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Hx" with "[//] CTX HE HL HR") as "(HR & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL_mono with "Ha").
+ iIntros. rewrite Nat.add_succ_r//.
+ - iPoseProof ("Hx" with "HR") as "(Ha & Hb & $)".
+ iIntros "%Hinv %". iSpecialize ("Hb" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL_mono with "Hb").
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+ Global Instance relate_hlist_cons_l_inst {A} {G} E L ig (X : A) (Xs : list A) (l1 : hlist G (X::Xs)) (l2 : hlist G (X :: Xs)) i0 R :
+ RelateHList E L ig (X :: Xs) (l1) l2 i0 R :=
+ λ T, i2p (relate_hlist_cons E L ig X Xs l1 l2 i0 R T).
+
+ (* TODO more instances similar to the ones for relate_list *)
+End relate_hlist.
+*)
+
+Section fold_list.
+ Context `{!typeGS Σ}.
+ (** A generalization of subsume_list. *)
+ Record FoldablePredicate {A} : Type := FP {
+ fp_pred : elctx → llctx → nat → A → iProp Σ → iProp Σ;
+ fp_cap : nat;
+ fp_inv : Prop;
+ fp_elim_mode : bool;
+ fp_core_pred : elctx → llctx → nat → A → iProp Σ;
+ fp_elim E L i a :
+ ⊢ if fp_elim_mode then (∀ T F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ fp_pred E L i a T ={F}=∗ fp_core_pred E L i a ∗ llctx_interp L ∗ T) else ∀ T, fp_pred E L i a T -∗ fp_core_pred E L i a ∗ T;
+ }.
+ Arguments fp_pred {_}.
+ Arguments fp_core_pred {_}.
+ Arguments fp_elim_mode {_}.
+
+ Definition fold_list {A} (E : elctx) (L : llctx) (ig : list nat) (l : list A) (i0 : nat) (R : FoldablePredicate) (T : iProp Σ) : iProp Σ :=
+ if R.(fp_elim_mode) then
+ (∀ F, ⌜lftE ⊆ F⌠-∗ rrust_ctx -∗ elctx_interp E -∗ llctx_interp L ={F}=∗
+ (⌜i0 + length l ≤ R.(fp_cap)⌠-∗ ⌜R.(fp_inv)⌠-∗ [∗ list] i ↦ a ∈ l, if decide ((i + i0)%nat ∈ ig) then True else R.(fp_core_pred) E L (i + i0)%nat a) ∗ llctx_interp L ∗ T)%I
+ else ((⌜i0 + length l ≤ R.(fp_cap)⌠-∗ ⌜R.(fp_inv)⌠-∗ [∗ list] i ↦ a ∈ l, if decide ((i + i0)%nat ∈ ig) then True else R.(fp_core_pred) E L (i + i0)%nat a) ∗ T)%I.
+ Class FoldList {A} (E : elctx) (L : llctx) (ig : list nat) (l : list A) (i0 : nat) (R : FoldablePredicate) : Type :=
+ fold_list_proof T : iProp_to_Prop (fold_list E L ig l i0 R T).
+ Global Hint Mode FoldList + + + + + + + : typeclass_instances.
+
+ Lemma fold_list_ig_cons_le {A} E L ig (j i0 : nat) (l1 : list A) (R : FoldablePredicate) :
+ (j < i0)%nat →
+ ([∗ list] i ↦ a ∈ l1, if decide (i + i0 ∈ (j :: ig))%nat then True else fp_core_pred R E L (i + i0)%nat a) -∗
+ ([∗ list] i ↦ a ∈ l1, if decide (i + i0 ∈ (ig))%nat then True else fp_core_pred R E L (i + i0)%nat a).
+ Proof.
+ intros Hlt.
+ iInduction l1 as [ | a l1] "IH" forall (j i0 Hlt); simpl; first by eauto.
+ case_decide as Hel.
+ - apply elem_of_cons in Hel as [ ? | ?]; first lia.
+ rewrite decide_True; last done. rewrite !left_id.
+ iIntros "Ha". iApply (big_sepL_mono); first last.
+ { iApply ("IH" $! _ (S i0)); first last.
+ { iApply big_sepL_mono; last done. iIntros. rewrite Nat.add_succ_r//. }
+ iPureIntro. lia. }
+ iIntros. rewrite Nat.add_succ_r//.
+ - apply not_elem_of_cons in Hel as [_ Hel].
+ rewrite decide_False; last done.
+ iIntros "($ & Ha)". iApply (big_sepL_mono); first last.
+ { iApply ("IH" $! _ (S i0)); first last.
+ { iApply big_sepL_mono; last done. iIntros. rewrite Nat.add_succ_r//. }
+ iPureIntro. lia. }
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+
+ Lemma fold_list_replicate_elim_full {A} E L ig n (a : A) i0 (R : FoldablePredicate) T :
+ R.(fp_elim_mode) = true →
+ (rrust_ctx -∗ elctx_interp E -∗ llctx_interp L -∗ ⌜R.(fp_inv)⌠-∗ □ ∀ i, ⌜(i < R.(fp_cap))%nat⌠-∗ R.(fp_core_pred) E L i a) -∗
+ T -∗ fold_list E L ig (replicate n a) i0 R T.
+ Proof.
+ rewrite /fold_list. iIntros (->) "HR HT". iIntros (F ?) "#CTX #HE HL".
+ iPoseProof ("HR" with "CTX HE HL") as "#HR".
+ iFrame "HT HL".
+ iModIntro. iIntros "%Hinv %Hinv'". iSpecialize ("HR" with "[//]").
+ iInduction n as [ | n] "IH" forall (i0 Hinv); simpl.
+ { by iFrame. }
+ iPoseProof ("IH" $! (S i0) with "[]") as "Ha".
+ { simpl in Hinv. iPureIntro. lia. }
+ case_decide.
+ - iR.
+ iApply (big_sepL_wand with "Ha").
+ iApply big_sepL_intro.
+ iModIntro. iIntros (???). rewrite Nat.add_succ_r. eauto.
+ - iFrame. iSplitR. { iApply "HR". simpl in Hinv. iPureIntro. lia. }
+ iApply (big_sepL_mono with "Ha").
+ iIntros (???). rewrite Nat.add_succ_r. done.
+ Qed.
+
+ Lemma fold_list_replicate_elim_weak {A} E L ig n (a : A) i0 (R : FoldablePredicate) T :
+ R.(fp_elim_mode) = false →
+ (⌜R.(fp_inv)⌠-∗ □ ∀ i, ⌜(i < R.(fp_cap))%nat⌠-∗ R.(fp_core_pred) E L i a) -∗
+ T -∗ fold_list E L ig (replicate n a) i0 R T.
+ Proof.
+ rewrite /fold_list. iIntros (->) "HR $".
+ iIntros "%Hinv %Hinv'". iSpecialize ("HR" with "[//]").
+ iDestruct "HR" as "#HR".
+ iInduction n as [ | n] "IH" forall (i0 Hinv); simpl.
+ { by iFrame. }
+ iPoseProof ("IH" $! (S i0) with "[]") as "Ha".
+ { simpl in Hinv. iPureIntro. lia. }
+ case_decide.
+ - iR.
+ iApply (big_sepL_wand with "Ha").
+ iApply big_sepL_intro.
+ iModIntro. iIntros (???). rewrite Nat.add_succ_r. eauto.
+ - iFrame. iSplitR. { iApply "HR". simpl in Hinv. iPureIntro. lia. }
+ iApply (big_sepL_mono with "Ha").
+ iIntros (???). rewrite Nat.add_succ_r. done.
+ Qed.
+
+ Local Lemma fold_list_insert_in_ig' {A} E L (ig : list nat) (l1 : list A) (i0 : nat) i x R :
+ (i0 + i ∈ ig)%nat →
+ (⌜i0 + length l1 ≤ fp_cap R⌠-∗ ⌜fp_inv R⌠-∗ [∗ list] i1↦a ∈ l1, if decide ((i1 + i0)%nat ∈ ig) then True else fp_core_pred R E L (i1 + i0) a) -∗
+ (⌜i0 + length (<[i:=x]> l1) ≤ fp_cap R⌠-∗ ⌜fp_inv R⌠-∗ [∗ list] i1↦a ∈ <[i:=x]> l1, if decide ((i1 + i0)%nat ∈ ig) then True else fp_core_pred R E L (i1 + i0) a).
+ Proof.
+ iIntros (Hel) "Ha". iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { rewrite insert_length in Hinv. done. }
+ iInduction l1 as [ | a l1] "IH" forall (i i0 Hel Hinv); simpl; first done.
+ destruct i as [ | i].
+ - simpl.
+ case_decide; first done.
+ rewrite Nat.add_0_r in Hel. done.
+ - simpl.
+ case_decide.
+ + iDestruct "Ha" as "(_ & Ha)". iR.
+ iPoseProof ("IH" $! _ (S i0) with "[] [] [Ha]") as "Hi"; first last.
+ { iApply (big_sepL_mono); last iApply "Hi". iIntros. rewrite -Nat.add_succ_r//. }
+ { iApply (big_sepL_mono with "Ha"). iIntros. rewrite -Nat.add_succ_r//. }
+ { simpl in Hinv. iPureIntro. lia. }
+ { iPureIntro. move: Hel. rewrite Nat.add_succ_r//. }
+ + iDestruct "Ha" as "($ & Ha)".
+ iPoseProof ("IH" $! _ (S i0) with "[] [] [Ha]") as "Hi"; first last.
+ { iApply (big_sepL_mono); last iApply "Hi". iIntros. rewrite -Nat.add_succ_r//. }
+ { iApply (big_sepL_mono with "Ha"). iIntros. rewrite -Nat.add_succ_r//. }
+ { simpl in Hinv. iPureIntro. lia. }
+ { iPureIntro. move: Hel. rewrite Nat.add_succ_r//. }
+ Qed.
+
+ Lemma fold_list_insert_in_ig {A} E L ig (l1 : list A) (i0 : nat) i x R T `{CanSolve (i0 + i ∈ ig)%nat} :
+ fold_list E L ig l1 i0 R T
+ ⊢ fold_list E L ig (<[i := x]> l1) i0 R T.
+ Proof.
+ match goal with H : CanSolve _ |- _ => unfold CanSolve in H; rename H into Hel end.
+ rewrite /fold_list. destruct fp_elim_mode.
+ - iIntros "HP" (??) "#CTX #HE HL".
+ iMod ("HP" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. by iApply fold_list_insert_in_ig'.
+ - iIntros "(HP & $)". by iApply fold_list_insert_in_ig'.
+ Qed.
+ Global Instance fold_list_insert_in_ig_inst {A} E L ig (l1 : list A) (i0 : nat) i x R `{!CanSolve (i0 + i ∈ ig)%nat} :
+ FoldList E L ig (<[i := x]> l1) i0 R :=
+ λ T, i2p (fold_list_insert_in_ig E L ig l1 i0 i x R T).
+
+ Lemma fold_list_cons {A} E L ig (l1 : list A) i0 R a T :
+ ⌜i0 ∉ ig⌠∗ (R.(fp_pred) E L i0 a (fold_list E L ig l1 (S i0) R T))
+ ⊢ fold_list E L ig (a :: l1) i0 R T.
+ Proof.
+ iIntros "(%Hnel & HR)". rewrite /fold_list.
+ iPoseProof (fp_elim R) as "Hx". destruct fp_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Hx" with "[//] CTX HE HL HR") as "(HR & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Ha & $ & $)".
+ iModIntro. iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ rewrite big_sepL_cons. simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL_mono with "Ha").
+ iIntros. rewrite Nat.add_succ_r//.
+ - iPoseProof ("Hx" with "HR") as "(HR & HT)".
+ iPoseProof ("HT") as "(Ha & $)".
+ iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { simpl in Hinv. iPureIntro. lia. }
+ rewrite big_sepL_cons. simpl.
+ rewrite decide_False; last done. iFrame.
+ iApply (big_sepL_mono with "Ha").
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+ Global Instance fold_list_cons_inst {A} E L ig (l1 : list A) i0 a R :
+ FoldList E L ig (a :: l1) i0 R := λ T, i2p (fold_list_cons E L ig l1 i0 R a T).
+
+ Lemma fold_list_nil {A} E L ig i0 R T :
+ T ⊢ fold_list E L ig ([] : list A) i0 R T.
+ Proof.
+ iIntros "HT". rewrite /fold_list.
+ destruct fp_elim_mode.
+ - iIntros (??) "#CTX #HE $". iModIntro. iFrame.
+ iIntros "_ _". by iApply big_sepL_nil.
+ - iFrame. iIntros "_ _". by iApply big_sepL_nil.
+ Qed.
+ Global Instance fold_list_nil_inst {A} E L ig i0 R :
+ FoldList E L ig ([] : list A) i0 R := λ T, i2p (fold_list_nil E L ig i0 R T).
+
+ Local Lemma fold_list_insert_not_in_ig' {A} E L ig (l1 : list A) (R : FoldablePredicate) i0 i a :
+ (i0 + i ∉ ig)%nat →
+ i < length l1 →
+ fp_core_pred R E L (i0 + i) a -∗
+ (⌜i0 + length l1 ≤ fp_cap R⌠-∗ ⌜fp_inv R⌠-∗ [∗ list] i1↦a0 ∈ l1, if decide ((i1 + i0)%nat ∈ (i0 + i)%nat :: ig) then True else fp_core_pred R E L (i1 + i0) a0) -∗
+ (⌜i0 + length (<[i:=a]> l1) ≤ fp_cap R⌠-∗ ⌜fp_inv R⌠-∗ [∗ list] i1↦a0 ∈ <[i:=a]> l1, if decide ((i1 + i0)%nat ∈ ig) then True else fp_core_pred R E L (i1 + i0) a0).
+ Proof.
+ iIntros (Hnel Hi) "HR Ha".
+ iIntros "%Hinv %". iSpecialize ("Ha" with "[] [//]").
+ { iPureIntro. rewrite insert_length in Hinv. lia. }
+ iInduction l1 as [ | a' l1] "IH" forall (i i0 Hnel Hi Hinv).
+ { simpl in *. lia. }
+ destruct i as [ | i]; simpl.
+ - iDestruct "Ha" as "(_ & Ha)".
+ rewrite decide_False; first last. { move: Hnel. rewrite Nat.add_0_r//. }
+ rewrite Nat.add_0_r. iFrame.
+ iApply big_sepL_mono; first last.
+ { iApply (fold_list_ig_cons_le); first last.
+ { iApply big_sepL_mono; last done. iIntros. rewrite -Nat.add_succ_r//. }
+ lia.
+ }
+ iIntros. rewrite Nat.add_succ_r//.
+ - destruct (decide (i0 ∈ ig)).
+ + iR. iDestruct "Ha" as "(_ & Ha)".
+ iApply big_sepL_mono; first last.
+ { iApply ("IH" with "[] [] [] [HR] [Ha]"); first last.
+ - iApply big_sepL_mono; last done. iIntros. rewrite -(Nat.add_succ_r _ i0) (Nat.add_succ_r _ i) //.
+ - rewrite Nat.add_succ_r. done.
+ - iPureIntro. simpl in Hinv. lia.
+ - simpl in *; iPureIntro. lia.
+ - iPureIntro. move: Hnel. rewrite Nat.add_succ_r. done.
+ }
+ iIntros. rewrite Nat.add_succ_r//.
+ + rewrite decide_False; first last. { apply not_elem_of_cons. split; last done. lia. }
+ iDestruct "Ha" as "($ & Ha)".
+ iApply big_sepL_mono; first last.
+ { iApply ("IH" with "[] [] [] [HR]"); first last.
+ - iApply big_sepL_mono; last done. iIntros. rewrite -(Nat.add_succ_r _ i0) (Nat.add_succ_r _ i) //.
+ - rewrite Nat.add_succ_r. done.
+ - iPureIntro. simpl in Hinv. lia.
+ - simpl in *; iPureIntro. lia.
+ - iPureIntro. move: Hnel. rewrite Nat.add_succ_r. done.
+ }
+ iIntros. rewrite Nat.add_succ_r//.
+ Qed.
+ Lemma fold_list_insert_not_in_ig {A} E L ig (l1 : list A) (R : FoldablePredicate) i0 i a T `{CanSolve (i0 + i ∉ ig)%nat} :
+ ⌜i < length l1⌠∗
+ (R.(fp_pred) E L (i0 + i) a (fold_list E L ((i0 + i) :: ig)%nat l1 i0 R T))
+ ⊢ fold_list E L ig (<[i := a]> l1) i0 R T.
+ Proof.
+ match goal with H : CanSolve _ |- _ => rewrite /CanSolve in H; rename H into Hnel end.
+ iIntros "(%Hi & HR)". rewrite /fold_list.
+ iPoseProof (fp_elim R) as "Hx". destruct fp_elim_mode.
+ - iIntros (??) "#CTX #HE HL".
+ iMod ("Hx" with "[//] CTX HE HL HR") as "(HR & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL ") as "(Ha & $ & $)".
+ iModIntro. by iApply (fold_list_insert_not_in_ig' with "HR Ha").
+ - iPoseProof ("Hx" with "HR") as "(HR & Ha & $)".
+ by iApply (fold_list_insert_not_in_ig' with "HR Ha").
+ Qed.
+ Global Instance fold_list_insert_not_in_ig_inst {A} E L ig (l1 : list A) R (i0 : nat) i a `{!CanSolve (i0 + i ∉ ig)%nat} :
+ FoldList E L ig (<[i := a]> l1) i0 R :=
+ λ T, i2p (fold_list_insert_not_in_ig E L ig l1 R i0 i a T).
+
+ Lemma fold_list_app {A} E L ig (l1 l1' : list A) (R : FoldablePredicate) (i0 : nat) T :
+ fold_list E L ig l1 i0 R (fold_list E L ig l1' (length l1 + i0)%nat R T)
+ ⊢ fold_list E L ig (l1 ++ l1') i0 R T.
+ Proof.
+ rewrite /fold_list. destruct fp_elim_mode.
+ - iIntros "Ha" (??) "#CTX #HE HL".
+ iMod ("Ha" with "[//] CTX HE HL") as "(Ha & HL & HT)".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hb & $ & $)".
+ iModIntro. iIntros "%Hinv %". rewrite app_length in Hinv.
+ iSpecialize ("Ha" with "[] [//]"). { iPureIntro. lia. }
+ iSpecialize ("Hb" with "[] [//]"). { iPureIntro. lia. }
+ rewrite big_sepL_app. iFrame.
+ iApply (big_sepL_mono with "Hb").
+ iIntros. rewrite Nat.add_assoc [(k + _)%nat]Nat.add_comm//.
+ - iIntros "(Ha & Hb & $)".
+ iIntros "%Hinv %". rewrite app_length in Hinv.
+ iSpecialize ("Ha" with "[] [//]"). { iPureIntro. lia. }
+ iSpecialize ("Hb" with "[] [//]"). { iPureIntro. lia. }
+ rewrite big_sepL_app. iFrame.
+ iApply (big_sepL_mono with "Hb").
+ iIntros. rewrite Nat.add_assoc [(k + _)%nat]Nat.add_comm//.
+ Qed.
+ Global Instance fold_list_app_inst {A} E L ig (l1 l1' : list A) R i0 :
+ FoldList E L ig (l1 ++ l1') i0 R :=
+ λ T, i2p (fold_list_app E L ig l1 l1' R i0 T).
+End fold_list.
+
+(** ** OnEndlft triggers *)
+Section endlft_triggers.
+ Context `{!typeGS Σ}.
+ (* no typeclass for this one, as rules are directly applied by Ltac automation *)
+ Definition typed_on_endlft_pre (π : thread_id) (E : elctx) (L : llctx) (κ : lft) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ elctx_interp E -∗ llctx_interp L -∗ [†κ] ={F}=∗ ∃ L', llctx_interp L' ∗ T L'.
+
+ Definition typed_on_endlft (π : thread_id) (E : elctx) (L : llctx) (κ : lft) (worklist: list (sigT (@id Type) * iProp Σ)) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ elctx_interp E -∗ llctx_interp L -∗ [†κ] ={F}=∗ ∃ L', llctx_interp L' ∗ T L'.
+ Class TypedOnEndlft (π : thread_id) (E : elctx) (L : llctx) (κ : lft) (worklist : list (sigT (@id Type) * iProp Σ)) :=
+ typed_on_endlft_proof T : iProp_to_Prop (typed_on_endlft π E L κ worklist T).
+ Global Hint Mode TypedOnEndlft + + + + + : typeclass_instances.
+
+ Definition typed_on_endlft_trigger {K} (E : elctx) (L : llctx) (key : K) (P : iProp Σ) (T : llctx → iProp Σ) : iProp Σ :=
+ ∀ F, ⌜lftE ⊆ F⌠-∗ elctx_interp E -∗ llctx_interp L -∗ P ={F}=∗ ∃ L', llctx_interp L' ∗ T L'.
+ Class TypedOnEndlftTrigger {K} (E : elctx) (L : llctx) (key : K) (P : iProp Σ) :=
+ typed_on_endlft_trigger_proof T : iProp_to_Prop (typed_on_endlft_trigger E L key P T).
+ Global Hint Mode TypedOnEndlftTrigger + + + + + : typeclass_instances.
+
+ (* no instance, automation needs to manually instantiate the worklist *)
+ Lemma typed_on_endlft_pre_init worklist π E L κ T :
+ typed_on_endlft π E L κ worklist T
+ ⊢ typed_on_endlft_pre π E L κ T.
+ Proof. done. Qed.
+
+ Lemma typed_on_endlft_nil π E L κ T :
+ T L ⊢ typed_on_endlft π E L κ [] T.
+ Proof.
+ iIntros "Hs" (F ?) "HE HL ?". iModIntro. iExists L. iFrame.
+ Qed.
+ Global Instance typed_on_endlft_nil_inst π E L κ : TypedOnEndlft π E L κ [] :=
+ λ T, i2p (typed_on_endlft_nil π E L κ T).
+
+ Lemma typed_on_endlft_cons {K} π E L κ key P worklist T :
+ find_in_context (FindInherit κ key P) (λ _,
+ typed_on_endlft_trigger E L key P (λ L', typed_on_endlft π E L' κ worklist T))
+ ⊢ typed_on_endlft π E L κ ((existT K key, P) :: worklist) T.
+ Proof.
+ iIntros "Hs" (F ?) "#HE HL #Hdead".
+ iDestruct "Hs" as ([]) "(Hinh & Hc)". simpl.
+ rewrite /Inherit.
+ iMod ("Hinh" with "[//] Hdead") as "HP".
+ iMod ("Hc" with "[//] HE HL HP") as "(%L' & HL & HT)".
+ iApply ("HT" with "[//] HE HL Hdead").
+ Qed.
+ Global Instance typed_on_endlft_cons_inst {K} π E L κ (key : K) P worklist : TypedOnEndlft π E L κ ((existT K key, P) :: worklist) :=
+ λ T, i2p (typed_on_endlft_cons π E L κ key P worklist T).
+End endlft_triggers.
+
+(** For implementation of [GetLftNamesAnnot].
+ Get the symbolic lifetimes associated for a type [ty], according to the structure given by [tree],
+ and map the names given in [tree] to the symbolic lifetimes in [ty].
+ Outputs an updated map [lfts'] with those names. *)
+Class GetLftNames `{!typeGS Σ} {rt} (ty : type rt) (lfts : gmap string lft) (tree : LftNameTree) (lfts' : gmap string lft) := GLN {}.
+Global Hint Mode GetLftNames ! ! + + - + - : typeclass_instances.
+Global Arguments GLN {_ _ _ _ _ _ _}.
+Global Instance get_lft_names_leaf `{!typeGS Σ} {rt} (ty : type rt) lfts : GetLftNames ty lfts LftNameTreeLeaf lfts := GLN.
+
+
+
+From lithium Require Import hooks.
+Ltac generate_i2p_instance_to_tc_hook arg c ::=
+ lazymatch c with
+ | typed_value ?x ?π => constr:(TypedValue x π)
+ | typed_bin_op ?π ?E ?L ?v1 ?P1 ?v2 ?P2 ?o ?ot1 ?ot2 => constr:(TypedBinOp π E L v1 P1 v2 P2 o ot1 ot2)
+ | typed_un_op ?π ?E ?L ?v ?P ?o ?ot => constr:(TypedUnOp π E L v P o ot)
+ | typed_call ?π ?E ?L ?κs ?v ?P ?vs ?tys => constr:(TypedCall π E L κs v P vs tys)
+ | typed_place ?π ?E ?L ?l ?lto ?ro ?b1 ?b2 ?K => constr:(TypedPlace E L π l lto ro b1 b2 K)
+ | typed_read_end ?π ?E ?L ?l ?lt ?r ?b1 ?b2 ?al ?ot => constr:(TypedReadEnd π E L l lt r b1 b2 al ot)
+ | typed_write_end ?π ?E ?L ?ot ?v ?ty1 ?r1 ?b1 ?b2 ?al ?l ?lt2 ?r2 => constr:(TypedWriteEnd π E L ot v ty1 r1 b1 b2 al l lt2 r2)
+ | typed_addr_of_mut_end ?π ?E ?L ?l ?lt ?r ?b1 ?b2 => constr:(TypedAddrOfMutEnd π E L l lt r b1 b2)
+ | typed_annot_expr ?π ?E ?L ?n ?a ?v ?P => constr:(TypedAnnotExpr π E L n a v P)
+ | typed_if ?E ?L ?v ?P => constr:(TypedIf E L v P)
+ | typed_assert ?π ?E ?L ?v ?ty ?r => constr:(TypedAssert π E L v ty r)
+ | typed_switch ?π ?E ?L ?v ?ty ?r ?it => constr:(TypedSwitch π E L v ty r it)
+ | typed_annot_stmt ?a => constr:(TypedAnnotStmt a)
+ | subsume_full ?E ?L ?wl ?P1 ?P2 => constr:(SubsumeFull E L wl P1 P2)
+ | prove_with_subtype ?E ?L ?wl ?pm ?P => constr:(ProveWithSubtype E L wl pm P)
+ | typed_on_endlft ?π ?E ?L ?κ ?worklist => constr:(TypedOnEndlft π E L κ worklist)
+ | weak_subtype ?E ?L ?r1 ?r2 ?ty1 ?ty2 => constr:(Subtype E L r1 r2 ty1 ty2)
+ | mut_subtype ?E ?L ?ty1 ?ty2 => constr:(MutSubtype E L ty1 ty2)
+ | owned_subtype ?π ?E ?L ?wl ?r1 ?r2 ?ty1 ?ty2 => constr:(OwnedSubtype π E L wl r1 r2 ty1 ty2)
+ | weak_subltype ?E ?L ?k ?r1 ?r2 ?lt1 ?lt2 => constr:(SubLtype E L k r1 r2 lt1 lt2)
+ | mut_subltype ?E ?L ?lt1 ?lt2 => constr:(MutSubLtype E L lt1 lt2)
+ | owned_subltype_step ?π ?E ?L ?r1 ?r2 ?lt1 ?lt2 => constr:(OwnedSubltypeStep π E L r1 r2 lt1 lt2)
+ | _ => fail "unknown judgement" c
+ end.
diff --git a/theories/rust_typing/references.v b/theories/rust_typing/references.v
new file mode 100644
index 0000000000000000000000000000000000000000..3945d0e8145f3b72bf9a65b79a4713bd34360269
--- /dev/null
+++ b/theories/rust_typing/references.v
@@ -0,0 +1,2633 @@
+From refinedrust Require Export base type ltypes.
+From caesium Require Import derived.
+From refinedrust Require Import programs ltype_rules.
+
+Local Definition ref_layout := void_ptr.
+
+Global Hint Extern 4 (Inhabited _) => refine (populate _); assumption : typeclass_instances.
+
+Section mut_ref.
+ Context `{typeGS Σ} {rt} (inner : type rt).
+ Implicit Types (κ : lft) (γ : gname).
+
+ (* Mutable references only really make sense when the inner type is a refinement type,
+ because we cannot make strong updates to the inner type -- thus the inner refinement needs to be
+ exposed through the mutable reference's refinement *)
+ Program Definition mut_ref (κ : lft) : type (place_rfn rt * gname) := {|
+ ty_sidecond := True;
+ ty_own_val π '(r, γ) v :=
+ (∃ (l : loc) (ly : layout), ⌜v = l⌠∗
+ ⌜use_layout_alg inner.(ty_syn_type) = Some ly⌠∗
+ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ inner.(ty_sidecond) ∗
+ place_rfn_interp_mut r γ ∗
+ £ num_cred ∗ atime 1 ∗
+ |={lftE}=> &pin{κ} (∃ r' : rt, gvar_auth γ r' ∗ |={lftE}=> l ↦: inner.(ty_own_val) π r'))%I;
+
+ ty_has_op_type ot mt := is_ptr_ot ot;
+ ty_syn_type := PtrSynType;
+
+ ty_shr κ' tid '(r, γ) l :=
+ (∃ (li : loc) (ly : layout) (r' : rt),
+ ⌜l `has_layout_loc` void*⌠∗
+ place_rfn_interp_shared r r' ∗
+ &frac{κ'}(λ q', l ↦{q'} li) ∗
+ (* needed explicity because there is a later + fupd over the sharing predicate *)
+ ⌜use_layout_alg inner.(ty_syn_type) = Some ly⌠∗
+ ⌜li `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 void*.(ly_size) ∗
+ loc_in_bounds li 0 ly.(ly_size) ∗
+ inner.(ty_sidecond) ∗
+ (* TODO add loc_in_bounds and ty_sidecond *)
+ (* no delayed sharing, we can strip the laters right away due to flexilaters *)
+ (* we still need a later for contractiveness *)
+ ▷ □ (|={lftE}=> inner.(ty_shr) (κ⊓κ') tid r' li))%I;
+ (* NOTE: we cannot descend below the borrow here to get more information recursively.
+ But this is fine, since the observation about γ here already contains all the information we need. *)
+ ty_ghost_drop _ '(r, γ) :=
+ (*place_rfn_interp_mut r γ;*)
+ match r with
+ | #r' => gvar_pobs γ r'
+ | PlaceGhost γ' => Rel2 γ' γ (@eq rt)
+ end;
+ ty_lfts := [κ] ++ inner.(ty_lfts);
+ ty_wf_E := ty_outlives_E inner κ;
+ |}.
+ Next Obligation.
+ iIntros (κ π [r γ] v) "(%l & %ly & -> & _)". eauto.
+ Qed.
+ Next Obligation.
+ iIntros (? ot Hot) => /=. destruct ot => /=// -> //.
+ Qed.
+ Next Obligation.
+ iIntros (κ π r v) "_". done.
+ Qed.
+ Next Obligation.
+ iIntros (κ κ' π l [r γ]). apply _.
+ Qed.
+ Next Obligation.
+ iIntros (????[r γ]) "(%li & %ly & %r' & ? & ? & _)". eauto.
+ Qed.
+ Next Obligation.
+ (* initiate sharing *)
+ (* we will need to change some things for this to work:
+ - the interpretation of place_rfn for shared should accept the Ghost case, and just state True
+
+ possible alternative solutions:
+ - maybe allow types to restrict when they are shareable? (not when they are in an inconsistent state)
+ => this is not great, since sharing of nested types will have nasty requirements.
+ - alternatively allow the sharing operation to update the refinement
+ => not cool. we'd have to update the outer refinement too, and that does not really work.
+ *)
+
+ (*
+ Plan:
+ - get the borrow containing the credit + atime.
+ - open the borrows to obtain the receipts.
+ - use the credit (will need more than one) to bring the nested borrow in the right shape.
+ will need:
+ + 1 credit/later for the fupd_later
+ + 1 credit for folding the pinned borrow
+ + 1 credit for unfoldign the pinned borrow
+ + 1 credit/later for getting rid of the second fupd after unnesting
+ + 1 credit/later for unnesting
+ - then do recursive sharing and eliminate the logical_step for that.
+ - introduce the logical step, using the time receipt.
+ - after getting the credits and the receipt back, can close the two borrows
+ - can now prove the conclusion.
+
+ *)
+
+ (* TODO: use the new pinned_bor unnesting law *)
+
+ iIntros (κ E κ' l ly π [r γ] q ?) "#[LFT TIME] Htok %Hst %Hly _ Hb".
+ iApply fupd_logical_step.
+ iMod (bor_exists with "LFT Hb") as (v) "Hb"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hl & Hb)"; first solve_ndisj.
+ simpl. rewrite -{1}lft_tok_sep -{1}lft_tok_sep. iDestruct "Htok" as "[Htok_κ' [Htok_κ Htok]]".
+
+ iMod (bor_exists with "LFT Hb") as (l0) "Hb"; first solve_ndisj.
+ iMod (bor_exists with "LFT Hb") as (ly0) "Hb"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Ha & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Ha Htok_κ'") as "(>-> & Htok_κ')"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Ha & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Ha Htok_κ'") as "(>%Halg & Htok_κ')"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Ha & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Ha Htok_κ'") as "(>%Hly0 & Htok_κ')"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Ha & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Ha Htok_κ'") as "(>#Hlb & Htok_κ')"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Ha & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Ha Htok_κ'") as "(>#Hsc & Htok_κ')"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hobs & Hb)"; first solve_ndisj.
+ rewrite bi.sep_assoc.
+ iMod (bor_sep with "LFT Hb") as "(Hcred & Hb)"; first solve_ndisj.
+ iDestruct "Htok_κ'" as "(Htok_κ' & Htokc)".
+ iMod (bor_acc with "LFT Hcred Htokc") as "(>(Hcred & Hat) & Hclos_c)"; first solve_ndisj.
+
+ (* unnest the pinned borrow *)
+ rewrite /num_cred. assert (5 = 2 + 3) as Heq by lia.
+ rewrite {1}Heq. iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ iMod (pinned_bor_unnest_full with "LFT Hcred1 Htok_κ' Hb") as "Hb"; first done.
+ iDestruct "Hcred" as "(Hcred1 & Hcred2 & Hcred)".
+ iApply (lc_fupd_add_later with "Hcred1"). iNext.
+ iMod "Hb". iMod "Hb".
+ iApply (lc_fupd_add_later with "Hcred2"). iNext.
+ iMod "Hb" as "(Hb & Htok_κ')".
+ rewrite lft_intersect_comm.
+
+ iDestruct "Htok_κ" as "(Htok_κ & Htok_κ2)".
+ iCombine "Htok_κ Htok_κ'" as "Htoka". rewrite lft_tok_sep.
+ iMod (bor_exists_tok with "LFT Hb Htoka") as "(%r' & Hb & Htoka)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Hauth & Hb)"; first solve_ndisj.
+ iMod (bor_fupd_later with "LFT Hb Htoka") as "Hu"; [done.. | ].
+ iApply (lc_fupd_add_later with "Hcred"). iNext. iMod "Hu" as "(Hb & Htoka)".
+
+ (* gain knowledge about the refinement *)
+ iDestruct "Htoka" as "(Htoka & Htoka2)".
+ rewrite -{1}lft_tok_sep. iDestruct "Htoka" as "(Htok_κ & Htok_κ')".
+ iMod (bor_acc with "LFT Hobs Htok_κ'") as "(Hobs & Hcl_obs)"; first solve_ndisj.
+ iMod (bor_acc with "LFT Hauth Htoka2") as "(>Hauth & Hcl_auth)"; first solve_ndisj.
+ iAssert (|={E}=> ⌜match r with PlaceIn r'' => r' = r'' | _ => True end⌠∗ gvar_auth γ r' ∗ ▷ place_rfn_interp_mut r γ)%I with "[Hauth Hobs]" as ">(%Hrfn & Hauth & Hobs)".
+ { destruct r; last by eauto with iFrame.
+ iDestruct "Hobs" as ">Hobs". iPoseProof (gvar_agree with "Hauth Hobs") as "#->".
+ eauto with iFrame. }
+ iMod ("Hcl_obs" with "[$Hobs]") as "(_ & Htok_κ')".
+ iMod ("Hcl_auth" with "[$Hauth]") as "(_ & Htoka2)".
+
+ (* get a loc_in_bounds fact from the pointsto *)
+ iMod (bor_acc with "LFT Hl Htok_κ'") as "(>Hl & Hcl_l)"; first solve_ndisj.
+ iPoseProof (heap_mapsto_loc_in_bounds with "Hl") as "#Hlb'".
+ iMod ("Hcl_l" with "Hl") as "(Hl & Htok_κ')".
+ iCombine "Htok_κ Htok_κ'" as "Htoka1". rewrite lft_tok_sep.
+ iCombine "Htoka1 Htoka2" as "Htoka".
+
+ (* fracture *)
+ iMod (bor_fracture (λ q, l ↦{q} l0)%I with "LFT Hl") as "Hl"; first solve_ndisj.
+
+ (* recursively share *)
+ iDestruct "Htok" as "(Htok1 & Htok2)".
+ iPoseProof (ty_share _ E with "[$LFT $TIME] [Htok2 Htoka] [//] [//] Hlb Hb") as "Hu"; first solve_ndisj.
+ { rewrite -!lft_tok_sep. iFrame. }
+ iModIntro. iApply (logical_step_compose with "Hu").
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "Hcred Hat".
+ iMod ("Hclos_c" with "[Hcred Hat]") as "(_ & Htok_κ'2)".
+ { iNext. iFrame. }
+
+ iModIntro. iIntros "(#Hshr & Htok)".
+ iCombine "Htok_κ2 Htok_κ'2 Htok1" as "Htok2".
+ rewrite !lft_tok_sep.
+ rewrite lft_intersect_assoc.
+ iCombine "Htok Htok2" as "Htok". rewrite {2}lft_intersect_comm lft_intersect_assoc. iFrame "Htok".
+ iExists l0, ly0, r'. iFrame "Hl".
+ inversion Hst; subst ly.
+ iSplitR; first done. iSplitR. { destruct r; simpl; eauto. }
+ iSplitR; first done. iSplitR; first done.
+ iSplitR; first done.
+ iSplitR; first done. iSplitR; first done.
+ iNext. iModIntro. iModIntro. done.
+ Qed.
+ Next Obligation.
+ iIntros (κ κ0 κ' π [r γ] l) "#Hincl".
+ iIntros "(%li & %ly & %r' & Hly & Hrfn & Hf & ? & ? & ? & ? & ? & #Hb)".
+ iExists li, ly, r'. iFrame.
+ iSplitL "Hf". { iApply frac_bor_shorten; done. }
+ iNext. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro.
+ iApply ty_shr_mono; last done.
+ iApply lft_intersect_mono; last done. iApply lft_incl_refl.
+ Qed.
+ Next Obligation.
+ iIntros (??[r γ]???) "(%l & %ly & -> & _ & _ & _ & _ & Hrfn & Hcred & Hat & _)".
+ iApply fupd_logical_step. destruct r as [ r | γ'].
+ - iMod (gvar_obs_persist with "Hrfn") as "?".
+ iApply logical_step_intro. by iFrame.
+ - iDestruct "Hrfn" as "(? & ?)". by iApply logical_step_intro.
+ Qed.
+ Next Obligation.
+ iIntros (? ot mt st ? [r γ] ? Hot).
+ destruct mt.
+ - eauto.
+ - iIntros "(%l & %ly & -> & ?)". iExists l, ly. iFrame.
+ iPureIntro. move: ot Hot => [] /=// _.
+ rewrite /mem_cast val_to_of_loc //.
+ - iApply (mem_cast_compat_loc (λ v, _)); first done.
+ iIntros "(%l & %ly & -> & _)". eauto.
+ Qed.
+End mut_ref.
+
+Section subtype.
+ Context `{!typeGS Σ}.
+
+ Lemma mut_ref_own_val_mono {rt} `{!Inhabited rt} (ty1 ty2 : type rt) v π r κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ (∀ r, type_incl r r ty1 ty2) -∗
+ (∀ r, type_incl r r ty2 ty1) -∗
+ v â—áµ¥{Ï€} r @ mut_ref ty1 κ2 -∗
+ v â—áµ¥{Ï€} r @ mut_ref ty2 κ1.
+ Proof.
+ destruct r as [r γ].
+ iIntros "#Hincl #Ht12 #Ht21 (%l & %ly & -> & ? & Hly & Hlb & Hsc & Hobs & ? & ? & Hb)".
+ iDestruct ("Ht12" $! inhabitant) as "(%Hst & #Hsceq & _)".
+ (*iDestruct "Ht21" as "(_ & _ & #Hv21 & #Hs21)".*)
+ iExists l, ly. iFrame. iSplitR; first done.
+ rewrite -Hst. iFrame. iSplitL "Hsc". { by iApply "Hsceq". }
+ iMod "Hb". iModIntro.
+ iApply (pinned_bor_shorten with "Hincl").
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ + iIntros "(%r' & Hauth & Hv)". iExists r'. iFrame.
+ iMod "Hv" as "(%v & Hl & Hv)". iModIntro. iExists v. iFrame.
+ iDestruct ("Ht12" $! r') as "(_ & _ & Hv12 & _)". by iApply "Hv12".
+ + iIntros "(%r' & Hauth & Hv)". iExists r'. iFrame.
+ iMod "Hv" as "(%v & Hl & Hv)". iModIntro. iExists v. iFrame.
+ iDestruct ("Ht21" $! r') as "(_ & _ & Hv21 & _)". by iApply "Hv21".
+ Qed.
+
+ Lemma mut_ref_shr_mono_in {rt} (ty1 ty2 : type rt) l π r1 r2 γ κ κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ type_incl r1 r2 ty1 ty2 -∗
+ l â—â‚—{Ï€, κ} (#r1, γ) @ mut_ref ty1 κ2 -∗
+ l â—â‚—{Ï€, κ} (#r2, γ) @ mut_ref ty2 κ1.
+ Proof.
+ iIntros "#Hincl #Ht12 (%li & %ly & %r' & ? & <- & Hs & ? & ? & ? & ? & Hsc & Hb)".
+ iDestruct "Ht12" as "(%Hst & #Hsceq & #Hv12 & #Hs12)".
+ iExists li, ly, r2. iFrame. iR. rewrite Hst. iFrame.
+ iSplitL "Hsc". { by iApply "Hsceq". }
+ iNext. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro.
+ iApply ty_shr_mono.
+ { iApply lft_incl_glb.
+ + iApply lft_incl_trans; first iApply lft_intersect_incl_l. iApply "Hincl".
+ + iApply lft_intersect_incl_r. }
+ by iApply "Hs12".
+ Qed.
+ Lemma mut_ref_shr_mono {rt} `{!Inhabited rt} (ty1 ty2 : type rt) l π r κ κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ (∀ r, type_incl r r ty1 ty2) -∗
+ l â—â‚—{Ï€, κ} r @ mut_ref ty1 κ2 -∗
+ l â—â‚—{Ï€, κ} r @ mut_ref ty2 κ1.
+ Proof.
+ destruct r as [r γ].
+ iIntros "#Hincl #Ht12 (%li & %ly & %r' & ? & ? & Hs & ? & ? & ? & ? & Hsc & Hb)".
+ iDestruct ("Ht12" $! inhabitant) as "(%Hst & #Hsceq & _)".
+ iExists li, ly, r'. iFrame. rewrite Hst. iFrame.
+ iSplitL "Hsc". { by iApply "Hsceq". }
+ iNext. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro.
+ iApply ty_shr_mono.
+ { iApply lft_incl_glb.
+ + iApply lft_incl_trans; first iApply lft_intersect_incl_l. iApply "Hincl".
+ + iApply lft_intersect_incl_r. }
+ iDestruct ("Ht12" $! r') as "(_ & _ & _ & #Hs12)". by iApply "Hs12".
+ Qed.
+
+ Lemma mut_ref_type_incl {rt} `{!Inhabited rt} (ty1 ty2 : type rt) r κ2 κ1 :
+ κ1 ⊑ κ2 -∗
+ (∀ r, type_incl r r ty1 ty2) -∗
+ (∀ r, type_incl r r ty2 ty1) -∗
+ type_incl r r (mut_ref ty1 κ2) (mut_ref ty2 κ1).
+ Proof.
+ iIntros "#Hincl #Ht12 #Ht21". iSplitR; first done. iSplitR; first done.
+ iSplit; iIntros "!#".
+ - iIntros (??). by unshelve iApply mut_ref_own_val_mono.
+ - iIntros (???). by unshelve iApply mut_ref_shr_mono.
+ Qed.
+
+ Lemma mut_ref_full_subtype {rt} `{!Inhabited rt} E L (ty1 ty2 : type rt) κ1 κ2 :
+ full_eqtype E L ty1 ty2 →
+ lctx_lft_incl E L κ2 κ1 →
+ full_subtype E L (mut_ref ty1 κ1) (mut_ref ty2 κ2).
+ Proof.
+ iIntros (Hsub1 Hincl r qL) "HL #HE".
+ iPoseProof (full_eqtype_acc_noend with "HE HL") as "#Heq"; first done.
+ iPoseProof (Hincl with "HL HE") as "#Hincl".
+ unshelve iApply mut_ref_type_incl; [done | done | ..].
+ - iIntros (r'). iDestruct ("Heq" $! r') as "($ & _)".
+ - iIntros (r'). iDestruct ("Heq" $! r') as "(_ & $)".
+ Qed.
+End subtype.
+
+Section subltype.
+ Context `{!typeGS Σ}.
+ (** Mutable references *)
+
+
+ Local Lemma mut_ltype_incl'_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ' r1 r2 γ κ1 κ2 :
+ ltype_incl (Shared (κ1 ⊓ κ')) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Shared κ') #(r1, γ) #(r2, γ) (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_mut_ref_unfold /mut_ltype_own /=.
+ iIntros "(%ly & ? & ? & ? & (%r' & %γ' & %Hrfn & #Hb))".
+ iExists ly. iFrame. iExists _, _. iFrame. iSplitR; first done.
+ iModIntro. iMod "Hb" as "(%li & Hs & Hb)". iModIntro.
+ iDestruct ("Heq") as "(%Hly_eq & #Hi1 & #Hc1)".
+ injection Hrfn as -> ->.
+ iExists li. iFrame. iApply ltype_own_shr_mono; last by iApply "Hi1".
+ iApply lft_intersect_mono; first done.
+ iApply lft_incl_refl.
+ Qed.
+ Lemma mut_ltype_incl_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ' γ r1 r2 κ1 κ2 :
+ ltype_incl (Shared (κ1 ⊓ κ')) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Shared κ') #(r1, γ) #(r2, γ) (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply mut_ltype_incl'_shared_in; [ | done ]).
+ - done.
+ - iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma mut_ltype_incl'_shared {rt} (lt1 lt2 : ltype rt) κ' r κ1 κ2 :
+ (∀ r, ltype_incl (Shared (κ1 ⊓ κ')) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Shared κ') r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_mut_ref_unfold /mut_ltype_own /=.
+ iIntros "(%ly & ? & ? & ? & (%r' & %γ & Hrfn & #Hb))".
+ iExists ly. iFrame. iExists _, _. iFrame.
+ iModIntro. iMod "Hb" as "(%li & Hs & Hb)". iModIntro.
+ iDestruct ("Heq" $! r') as "(%Hly_eq & #Hi1 & #Hc1)".
+ iExists li. iFrame. iApply ltype_own_shr_mono; last by iApply "Hi1".
+ iApply lft_intersect_mono; first done.
+ iApply lft_incl_refl.
+ Qed.
+ Lemma mut_ltype_incl_shared {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ' r κ1 κ2 :
+ (∀ r, ltype_incl (Shared (κ1 ⊓ κ')) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Shared κ') r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type _ inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply mut_ltype_incl'_shared; [ | done ]).
+ - done.
+ - iIntros (?). iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma mut_ltype_incl'_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 wl r1 r2 γ :
+ ltype_incl (Uniq κ1 γ) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Owned wl) #(r1, γ) #(r2, γ) (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_mut_ref_unfold /mut_ltype_own /=.
+ iIntros "(%ly & ? & ? & ? & ? & (%γ' & %r' & %Hrfn & Hl))".
+ injection Hrfn as <- <-.
+ iModIntro.
+ iExists ly. iFrame. iExists γ, r2. iSplitR; first done.
+ iNext. iMod "Hl" as "(%l' & Hl & Hb)".
+ iExists l'. iFrame. iDestruct "Heq" as "(_ & Heq & _)".
+ iApply ltype_own_uniq_mono; last by iApply "Heq". done.
+ Qed.
+ Lemma mut_ltype_incl_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 wl r1 r2 γ :
+ ltype_incl (Uniq κ1 γ) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Owned wl) #(r1, γ) #(r2, γ) (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply mut_ltype_incl'_owned_in; [ | done ]).
+ - done.
+ - iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma mut_ltype_incl'_owned {rt} (lt1 lt2 : ltype rt) κ1 κ2 wl r :
+ (∀ γ r, ltype_incl (Uniq κ1 γ) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Owned wl) r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_mut_ref_unfold /mut_ltype_own /=.
+ iIntros "(%ly & ? & ? & ? & ? & (%γ' & %r' & Hrfn & Hl))".
+ iModIntro.
+ iExists ly. iFrame. iExists γ', r'. iFrame "Hrfn".
+ iNext. iMod "Hl" as "(%l' & Hl & Hb)".
+ iExists l'. iFrame. iModIntro.
+ iApply ltype_own_uniq_mono; first done.
+ iDestruct ("Heq" $! _ _) as "(_ & #Heq' & _)". by iApply "Heq'".
+ Qed.
+ Lemma mut_ltype_incl_owned {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ1 κ2 wl r :
+ (∀ γ r, ltype_incl (Uniq κ1 γ) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Owned wl) r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type (Uniq _ inhabitant) inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply mut_ltype_incl'_owned; [ | done ]).
+ - done.
+ - iIntros (??). iApply ltype_incl_core. done.
+ Qed.
+
+ (* Refinement subtyping under mutable references is restricted: we need to make sure that, no matter the future updates,
+ we can always get back to what the lender expects. Thus we loose all refinement information when descending below mutable references. *)
+ Local Lemma mut_ltype_incl'_uniq {rt} (lt1 lt2 : ltype rt) κ1 κ2 κ r γ :
+ (∀ γ r, ltype_eq (Uniq (κ1) γ) r r lt1 lt2) -∗
+ (* Note: requires mutual inclusion, because we may be below a mutable reference *)
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_incl' (Uniq κ γ) r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_mut_ref_unfold /mut_ltype_own /=.
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & Hb)".
+ iExists ly. iFrame.
+ iMod "Hb". iModIntro. iApply (pinned_bor_iff with "[] [] Hb").
+ + iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)"; iExists _; iFrame.
+ iMod "Hb" as "(%l' & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! _ r'.1) as "((%Hly_eq & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2))".
+ iApply ltype_own_uniq_mono; last by iApply "Hi1". done.
+ * iIntros "(%r' & Hauth & Hb)"; iExists _; iFrame.
+ iMod "Hb" as "(%l' & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! _ r'.1) as "((%Hly_eq & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2))".
+ iApply "Hi2". iApply ltype_own_uniq_mono; done.
+ + iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)"; iExists _; iFrame.
+ iMod "Hb" as "(%l' & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! _ r'.1) as "((%Hly_eq & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2))".
+ rewrite !ltype_own_core_equiv.
+ iApply ltype_own_uniq_mono; last by iApply "Hc1". done.
+ * iIntros "(%r' & Hauth & Hb)"; iExists _; iFrame.
+ iMod "Hb" as "(%l' & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! _ r'.1) as "((%Hly_eq & #Hi1 & #Hc1) & (_ & #Hi2 & #Hc2))".
+ rewrite !ltype_own_core_equiv.
+ iApply "Hc2". iApply ltype_own_uniq_mono; done.
+ Qed.
+ Lemma mut_ltype_incl_uniq {rt} (lt1 lt2 : ltype rt) κ1 κ2 κ r γ :
+ (∀ γ r, ltype_eq (Uniq (κ1) γ) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_incl (Uniq κ γ) r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2".
+ iPoseProof (ltype_eq_syn_type (Uniq _ inhabitant) inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply mut_ltype_incl'_uniq; [ | done | done]).
+ - done.
+ - iIntros (??). iApply ltype_eq_core. done.
+ Qed.
+
+ Lemma mut_ltype_incl {rt} (lt1 lt2 : ltype rt) b r κ1 κ2 :
+ (∀ b r, ltype_eq b r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_incl b r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2".
+ destruct b.
+ - iApply mut_ltype_incl_owned; last done. iIntros (??). iDestruct ("Heq" $! _ _) as "[$ _]".
+ - iApply mut_ltype_incl_shared; last done. iIntros (?). iDestruct ("Heq" $! _ _) as "[$ _]".
+ - iApply mut_ltype_incl_uniq; [ | done..]. iIntros (??). done.
+ Qed.
+
+ Lemma mut_ltype_eq {rt} (lt1 lt2 : ltype rt) b r κ1 κ2 :
+ (∀ b r, ltype_eq b r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_eq b r r (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2".
+ iSplit.
+ - iApply mut_ltype_incl; done.
+ - iApply mut_ltype_incl; [ | done..]. iIntros (??). iApply ltype_eq_sym. done.
+ Qed.
+
+ Lemma mut_full_subltype E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ full_eqltype E L lt1 lt2 →
+ lctx_lft_incl E L κ1 κ2 →
+ lctx_lft_incl E L κ2 κ1 →
+ full_subltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ intros Heq Hincl1 Hincl2.
+ iIntros (qL) "HL #CTX #HE". iIntros (b r).
+ iPoseProof (Heq with "HL CTX HE") as "#Heq".
+ iPoseProof (lctx_lft_incl_incl_noend with "HL HE") as "#Hincl1"; first apply Hincl1.
+ iPoseProof (lctx_lft_incl_incl_noend with "HL HE") as "#Hincl2"; first apply Hincl2.
+ iApply mut_ltype_incl; done.
+ Qed.
+ Lemma mut_full_eqltype E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ full_eqltype E L lt1 lt2 →
+ lctx_lft_incl E L κ1 κ2 →
+ lctx_lft_incl E L κ2 κ1 →
+ full_eqltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2).
+ Proof.
+ intros Heq Hincl1 Hincl2.
+ apply full_subltype_eqltype; eapply mut_full_subltype; naive_solver.
+ Qed.
+End subltype.
+
+Section ltype_agree.
+ Context `{typeGS Σ}
+ {rt}
+ (ty: type rt).
+ Context `{Inhabited rt}.
+
+ Lemma mut_ref_unfold_1_owned κ wl r :
+ ⊢ ltype_incl' (Owned wl) r r (MutLtype (◠ty) κ) (◠(mut_ref ty κ)).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_mut_ref_unfold /mut_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & Hlb & ? & %γ & %r' & Hrfn & Hb)".
+ iModIntro.
+ iExists ly. iFrame "∗". iExists _. iFrame. iNext.
+ iMod "Hb" as "(%l' & Hl & Hb)".
+ iExists l'. iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & ? & ? & Hsc & Hlb' & ? & ? & Hrfn' & Hb)".
+ iExists l'. iFrame. iExists ly'. iSplitR; first done. iFrame "∗". done.
+ Qed.
+ Lemma mut_ref_unfold_1_uniq κ κ' γ r :
+ ⊢ ltype_incl' (Uniq κ' γ) r r (MutLtype (◠ty) κ) (◠(mut_ref ty κ)).
+ Proof.
+ iModIntro.
+ iIntros (Ï€ l). rewrite ltype_own_mut_ref_unfold /mut_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & %Hly & ? & ? & ? & ? & Hb)". iExists ly. iFrame "∗". iSplitR; first done.
+ iMod "Hb". iModIntro.
+ setoid_rewrite ltype_own_core_equiv. simp_ltypes.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iMod "Hb" as "(%l' & Hl & Hb)".
+ iExists l'. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own. destruct r' as [r' γ'].
+ iDestruct "Hb" as "(%ly' & Hst' & Hly' & Hsc & Hlb & ? & ? & Hrfn & >Hb)".
+ iModIntro. iExists l', ly'. iFrame "∗". iSplitR; first done. by iFrame.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iMod "Hb" as "(%v & Hl & Hb)". destruct r' as [r' γ'].
+ iDestruct "Hb" as "(%l' & %ly' & -> & ? & ? & Hlb & Hsc & Hrfn & ? & ? & >Hb)".
+ iExists _. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iModIntro. iExists ly'. iFrame. done.
+ Qed.
+ Lemma mut_ref_unfold_1_shared κ κ' r :
+ ⊢ ltype_incl' (Shared κ') r r (MutLtype (◠ty) κ) (◠(mut_ref ty κ)).
+ Proof.
+ iModIntro.
+ iIntros (Ï€ l). rewrite ltype_own_mut_ref_unfold /mut_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & %Hst & % & #Hlb & %ri & %γ & Hrfn & #Hb)".
+ injection Hst as <-. iExists _. iFrame "# ∗". iSplitR; first done. iSplitR; first done.
+ iExists _. iFrame "∗". iModIntro. iMod "Hb" as "(%li & Hs & Hb)".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & >? & >? & >Hsc & >Hlb' & %r' & >Hrfn & #Hb)".
+ (* TODO proof uses timelessness of Hrfn, can we do it without? *)
+ iModIntro. iExists _, _, _. iFrame "∗ #". done.
+ Qed.
+
+ Local Lemma mut_ref_unfold_1' κ k r :
+ ⊢ ltype_incl' k r r (MutLtype (◠ty) κ) (◠(mut_ref ty κ)).
+ Proof.
+ destruct k.
+ - iApply mut_ref_unfold_1_owned.
+ - iApply mut_ref_unfold_1_shared.
+ - iApply mut_ref_unfold_1_uniq.
+ Qed.
+ Lemma mut_ref_unfold_1 κ k r :
+ ⊢ ltype_incl k r r (MutLtype (◠ty) κ) (◠(mut_ref ty κ)).
+ Proof.
+ iSplitR; first done. iModIntro. iSplit.
+ - iApply mut_ref_unfold_1'.
+ - simp_ltypes. iApply mut_ref_unfold_1'.
+ Qed.
+
+ Lemma mut_ref_unfold_2_owned κ wl r :
+ ⊢ ltype_incl' (Owned wl) r r (◠(mut_ref ty κ)) (MutLtype (◠ty) κ).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_mut_ref_unfold /mut_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & _ & #Hlb & ? & %r' & Hrfn & Hb)". destruct r' as [r' γ'].
+ (*iApply except_0_if_intro.*)
+ iModIntro. iExists ly. iFrame "∗ #". iExists γ', r'. iFrame. iNext.
+ iMod "Hb" as "(%v & Hl & %l' & %ly' & -> & ? & ? & #Hlb' & Hsc & ? & ? & Hrfn' & >Hb)".
+ iExists _. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own. iExists ly'. iFrame "∗ #". done.
+ Qed.
+ Lemma mut_ref_unfold_2_uniq κ κ' γ r :
+ ⊢ ltype_incl' (Uniq κ' γ) r r (◠(mut_ref ty κ)) (MutLtype (◠ty) κ).
+ Proof.
+ iModIntro.
+ iIntros (Ï€ l). rewrite ltype_own_mut_ref_unfold /mut_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & _ & Hlb & ? & ? & Hrfn & Hb)". iExists ly. iFrame "∗". iMod "Hb".
+ iModIntro.
+ setoid_rewrite ltype_own_core_equiv. simp_ltypes.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iMod "Hb" as "(%v & Hl & Hb)". destruct r' as [r' γ'].
+ iDestruct "Hb" as "(%l' & %ly' & -> & ? & ? & Hlb & Hsc & Hrfn & ? & ? & >Hb)".
+ iExists _. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iModIntro. iExists ly'. iFrame. done.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame. iMod "Hb" as "(%l' & Hl & Hb)".
+ iExists l'. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own. destruct r' as [r' γ'].
+ iDestruct "Hb" as "(%ly' & Hst' & Hly' & Hsc & Hlb & ? & ? & Hrfn & >Hb)".
+ iModIntro. iExists l', ly'. iFrame "∗". iSplitR; first done. by iFrame.
+ Qed.
+ Lemma mut_ref_unfold_2_shared κ κ' r :
+ ⊢ ltype_incl' (Shared κ') r r (◠(mut_ref ty κ)) (MutLtype (◠ty) κ).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_mut_ref_unfold /mut_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & Hsc & Hlb & %r' & Hrfn & #Hb)". destruct r' as [r' γ'].
+ iExists ly. iFrame "∗ #". iExists _, _. iFrame.
+ iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & %ly' & %ri & ? & Hrfn' & Hs & ? & ? & Hlb & Hlb' & Hsc & #Hb)".
+ iModIntro. iExists li. iFrame.
+ iNext. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly'. iFrame.
+ iExists _. iFrame. done.
+ Qed.
+
+ Local Lemma mut_ref_unfold_2' κ k r :
+ ⊢ ltype_incl' k r r (◠(mut_ref ty κ)) (MutLtype (◠ty) κ).
+ Proof.
+ destruct k.
+ - iApply mut_ref_unfold_2_owned.
+ - iApply mut_ref_unfold_2_shared.
+ - iApply mut_ref_unfold_2_uniq.
+ Qed.
+ Local Lemma mut_ref_unfold_2 κ k r :
+ ⊢ ltype_incl k r r (◠(mut_ref ty κ)) (MutLtype (◠ty) κ).
+ Proof.
+ iSplitR; first done. iModIntro. iSplit.
+ - iApply mut_ref_unfold_2'.
+ - simp_ltypes. iApply mut_ref_unfold_2'.
+ Qed.
+
+ Lemma mut_ref_unfold κ k r :
+ ⊢ ltype_eq k r r (MutLtype (◠ty) κ) (◠(mut_ref ty κ)).
+ Proof.
+ iSplit; iModIntro.
+ - iApply mut_ref_unfold_1.
+ - iApply mut_ref_unfold_2.
+ Qed.
+
+ Lemma mut_ref_unfold_full_eqltype E L κ (lt : ltype rt) :
+ full_eqltype E L lt (◠ty)%I →
+ full_eqltype E L (MutLtype lt κ) (◠(mut_ref ty κ))%I.
+ Proof.
+ iIntros (Heql ?) "HL #CTX #HE". iIntros (b r).
+ iPoseProof (Heql with "HL CTX HE") as "#Heql".
+ iApply ltype_eq_trans; last iApply mut_ref_unfold.
+ iApply mut_ltype_eq; [ | iApply lft_incl_refl.. ].
+ by iApply "Heql".
+ Qed.
+End ltype_agree.
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ Global Instance get_lft_names_mut_ref {rt} (ty : type rt) κ lfts lfts' name tree :
+ GetLftNames ty lfts tree lfts' →
+ GetLftNames (mut_ref ty κ) lfts (LftNameTreeRef name tree) (named_lft_update name κ lfts') := λ _, GLN.
+
+ (* extraction *)
+ Lemma stratify_ltype_extract_ofty_mut π E L {rt} (ty : type rt) r κ γ l (wl : bool) (T : stratify_ltype_post_hook_cont_t) :
+ T L (place_rfn_interp_mut r γ) _ (◠uninit PtrSynType)%I (#())
+ ⊢ stratify_ltype_post_hook π E L (StratifyExtractOp κ) l (◠(mut_ref ty κ)) (#(r, γ)) (Owned wl) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL Hl".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists _, _, _, _, _. iFrame.
+ iDestruct "Hl" as "(%ly & %Hst & %Hly & Hsc & Hlb & Hcreds & %r' & <- & Hb)".
+ iMod (maybe_use_credit with "Hcreds Hb") as "(Hcreds & Hat & Hb)"; first done.
+ iDestruct "Hb" as "(%v & Hl & Hb)".
+ rewrite /ty_own_val/=.
+ iDestruct "Hb" as "(% & % & -> & ? & ? & ? & ? & Hb & Hcred' & Hat' & ?)".
+ iFrame.
+ iSplitR. { simp_ltypes. done. }
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists _. simpl. iFrame. iR. iR.
+ iSplitL "Hcred' Hat'". { destruct wl; last done. by iFrame. }
+ iExists _. iR. iModIntro. iModIntro. iModIntro.
+ iExists _. iFrame. rewrite uninit_own_spec. iExists _. iR.
+ iPureIntro. eapply syn_type_has_layout_ptr_inv in Hst. subst.
+ done.
+ Qed.
+ Global Instance stratify_ltype_extract_ofty_mut_inst π E L {rt} (ty : type rt) r κ γ l (wl : bool) :
+ StratifyLtypePostHook π E L (StratifyExtractOp κ) l (◠(mut_ref ty κ))%I (#(r, γ)) (Owned wl) | 20 :=
+ λ T, i2p (stratify_ltype_extract_ofty_mut π E L ty r κ γ l wl T).
+
+ Import EqNotations.
+ Lemma mut_ltype_place_cond_ty b κ {rt rt2} (lt1 : ltype rt) (lt2 : ltype rt2) :
+ typed_place_cond_ty (b) lt1 lt2
+ ⊢ typed_place_cond_ty b (MutLtype lt1 κ) (MutLtype lt2 κ).
+ Proof.
+ destruct b; simpl.
+ - iIntros "_". done.
+ - iIntros "(%Heq & Heq & Hub)". subst rt2.
+ cbn. iExists eq_refl. cbn. iSplitR "Hub".
+ + iIntros (??). iApply (mut_ltype_eq with "Heq"); iApply lft_incl_refl.
+ + by iApply mut_ltype_imp_unblockable.
+ - iIntros "(%Hrefl & Heq & Hub)".
+ subst rt2. cbn.
+ iExists eq_refl. cbn. iSplitR "Hub".
+ + simp_ltypes. iIntros (??). iApply (mut_ltype_eq with "Heq"); iApply lft_incl_refl.
+ + by iApply mut_ltype_imp_unblockable.
+ Qed.
+
+ Lemma mut_ltype_acc_owned {rt} F π (lt : ltype rt) (r : place_rfn rt) l κ' γ' wl :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ l â—â‚—[Ï€, Owned wl] PlaceIn (r, γ') @ MutLtype lt κ' -∗
+ ⌜l `has_layout_loc` void*⌠∗ loc_in_bounds l 0 (ly_size void*) ∗ |={F}=>
+ ∃ l' : loc, l ↦ l' ∗ l' â—â‚—[Ï€, Uniq κ' γ'] r @ lt ∗
+ logical_step F
+ (∀ bmin rt' (lt2 : ltype rt') r2,
+ l ↦ l' -∗
+ l' â—â‚—[Ï€, Uniq κ' γ'] r2 @ lt2 ={F}=∗
+ l â—â‚—[Ï€, Owned wl] PlaceIn (r2, γ') @ MutLtype lt2 κ' ∗
+ (typed_place_cond bmin lt lt2 r r2 -∗
+ ⌜place_access_rt_rel bmin rt rt'⌠-∗
+ typed_place_cond bmin (MutLtype lt κ') (MutLtype lt2 κ') (PlaceIn (r, γ')) (PlaceIn (r2, γ')))).
+ Proof.
+ iIntros (?) "#[LFT TIME] HP".
+ rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "HP" as "(%ly & %Halg & %Hly & #Hlb & Hcred & %γ & %r' & %Heq & Hb)".
+ injection Halg as <-. injection Heq as <- <-.
+ iFrame "Hlb %".
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iDestruct "Hb" as "(%l' & Hl & Hb)".
+ iModIntro. iExists l'. iFrame.
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred' !>". iIntros (bmin rt2 lt2 r2) "Hl Hb".
+ iModIntro. iSplitL.
+ - rewrite ltype_own_mut_ref_unfold /mut_ltype_own. iExists void*.
+ iSplitR; first done. iFrame "Hlb % ∗".
+ iExists _, _. iSplitR; first done. iNext. eauto with iFrame.
+ - iIntros "Hcond %Hrt". iDestruct "Hcond" as "[Hty Hrfn]".
+ subst. iSplit.
+ + by iApply (mut_ltype_place_cond_ty).
+ + destruct bmin; cbn in Hrt; [ done | subst rt2..].
+ all: by iApply (typed_place_cond_rfn_lift _ _ _ (λ r, PlaceIn (r, γ'))).
+ Qed.
+
+ Lemma mut_ltype_acc_uniq {rt} F π (lt : ltype rt) (r : place_rfn rt) l κ' γ' κ γ q R :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ q.[κ] -∗
+ (q.[κ] ={lftE}=∗ R) -∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn (r, γ') @ MutLtype lt κ' -∗
+ ⌜l `has_layout_loc` void*⌠∗ loc_in_bounds l 0 (ly_size void*) ∗ |={F}=>
+ ∃ l' : loc, l ↦ l' ∗ (l' â—â‚—[Ï€, Uniq κ' γ'] r @ lt) ∗
+ logical_step F
+ ( (* weak update *)
+ (∀ bmin (lt2 : ltype rt) r2,
+ l ↦ l' -∗
+ l' â—â‚—[Ï€, Uniq κ' γ'] r2 @ lt2 -∗
+ bmin ⊑ₖ Uniq κ γ -∗
+ typed_place_cond bmin lt lt2 r r2 ={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn (r2, γ') @ MutLtype lt2 κ' ∗
+ R ∗
+ typed_place_cond bmin (MutLtype lt κ') (MutLtype lt2 κ') (PlaceIn (r, γ')) (PlaceIn (r2, γ'))) ∧
+ (* strong update, go to Opened *)
+ (∀ rt2 (lt2 : ltype rt2) r2,
+ l ↦ l' -∗
+ ⌜ltype_st lt2 = ltype_st lt⌠-∗
+ l' â—â‚—[Ï€, Uniq κ' γ'] r2 @ lt2 ={F}=∗
+ l â—â‚—[Ï€, Uniq κ γ] PlaceIn (r2, γ') @ OpenedLtype (MutLtype lt2 κ') (MutLtype lt κ') (MutLtype lt κ')
+ (λ r1 r1', ⌜r1 = r1'âŒ) (λ _ _, R))).
+ Proof.
+ iIntros (?) "#[LFT TIME] Hκ HR HP".
+ rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "HP" as "(%ly & %Halg & %Hly & #Hlb & ? & ? & Hrfn & Hb)".
+ injection Halg as <-. iFrame "Hlb". iSplitR; first done.
+ iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ (* NOTE: we are currently throwing away the existing "coring" viewshift *)
+ iMod (pinned_bor_acc_strong with "LFT Hb Hκ") as (κ'') "(#Hincl0 & Hb & _ & Hcl)"; first done.
+ Admitted.
+ (* TODO : shared *)
+
+
+
+ (** Place *)
+ (* This needs to have a lower priority than the id instances, because we do not want to unfold when P = []. *)
+ Lemma place_ofty_mut {rt} `{Inhabited rt} π E L l (ty : type rt) κ (r : place_rfn (place_rfn rt * gname)) bmin0 b P T :
+ typed_place π E L l (MutLtype (◠ty) κ) r bmin0 b P T
+ ⊢ typed_place π E L l (◠(mut_ref ty κ)) r bmin0 b P T.
+ Proof.
+ iIntros "Hp". iApply typed_place_eqltype; last done.
+ iIntros (?) "HL CTX HE". iIntros (??).
+ iApply ltype_eq_sym. iApply mut_ref_unfold.
+ Qed.
+ Global Instance typed_place_ofty_mut_inst {rt} `{Inhabited rt} π E L l (ty : type rt) κ (r : place_rfn (place_rfn rt * gname)) bmin0 b P :
+ TypedPlace E L π l (◠(mut_ref ty κ))%I r bmin0 b P | 30 := λ T, i2p (place_ofty_mut π E L l ty κ r bmin0 b P T).
+
+ Lemma typed_place_mut_owned {rto} π κ (lt2 : ltype rto) P E L γ l r wl bmin0
+ (T : place_cont_t ((place_rfn rto) * gname)) :
+ (∀ l', typed_place π E L l' lt2 r (Uniq κ γ ⊓ₖ bmin0) (Uniq κ γ) P
+ (λ L' κs l2 b2 bmin rti tyli ri strong weak,
+ T L' (κs) l2 b2 bmin rti tyli ri
+ (option_map (λ strong, mk_strong
+ (λ rti2, (place_rfn (strong.(strong_rt) rti2)) * gname)%type
+ (λ rti2 lti2 ri, MutLtype (strong.(strong_lt) _ lti2 ri) κ)
+ (λ rti2 (r : place_rfn rti2), PlaceIn (strong.(strong_rfn) _ r, γ))
+ strong.(strong_R)) strong)
+ (fmap (λ weak, mk_weak
+ (λ ltyi2 ri2, MutLtype (weak.(weak_lt) ltyi2 ri2) κ)
+ (λ (r : place_rfn rti), PlaceIn (weak.(weak_rfn) r, γ))
+ weak.(weak_R)) weak)))
+ ⊢ typed_place π E L l (MutLtype lt2 κ) (PlaceIn (r, γ)) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iIntros "HR" (Φ F ??).
+ rewrite /li_tactic /lctx_lft_alive_count_goal.
+ iIntros "#(LFT & TIME & LLCTX) #HE HL Hincl0 HP HΦ/=".
+ iPoseProof (mut_ltype_acc_owned F with "[$LFT $TIME $LLCTX] HP") as "(%Hly & Hlb & Hb)"; [done.. | ].
+ iApply fupd_wp. iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iMod "Hb" as "(%l' & Hl & Hb & Hcl)". iMod "HclF" as "_". iModIntro.
+ iApply (wp_logical_step with "TIME Hcl"); [solve_ndisj.. | ].
+ iApply (wp_deref with "Hl") => //; [solve_ndisj | by apply val_to_of_loc | ].
+ iNext. iIntros (st) "Hl Hcred Hc". iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iMod "HclF" as "_". iExists l'.
+ iSplitR. { iPureIntro. unfold mem_cast. rewrite val_to_of_loc. done. }
+ iApply ("HR" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hb"). { iApply bor_kind_min_incl_l. }
+ iModIntro. iIntros (L' κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hb Hs".
+ iApply ("HΦ" $! _ _ _ _ bmin _ _ _ _ _ with "Hincl1 Hb").
+ simpl. iSplit.
+ - (* strong *) iDestruct "Hs" as "[Hs _]".
+ destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 Hcond".
+ iMod ("Hs" with "Hl2 Hcond") as "(Hb & Hcond & HR)".
+ iMod ("Hc" $! (Owned false) with "Hl Hb") as "(Hb & _)".
+ iFrame. iPureIntro. simp_ltypes. done.
+ - (* weak *)
+ destruct weak as [ weak | ]; last done.
+ iDestruct "Hs" as "[_ Hs]".
+ iIntros (ltyi2 ri2 bmin').
+ iIntros "Hincl2 Hl2 Hcond".
+ iMod ("Hs" with "Hincl2 Hl2 Hcond") as "(Hb & Hcond & $ & HR)".
+ iMod ("Hc" with "Hl Hb") as "(Hb & Hcond')".
+ iPoseProof ("Hcond'" with "Hcond") as "Hcond".
+ iModIntro. iFrame "HR Hb".
+ iApply typed_place_cond_incl; last iApply "Hcond".
+ + iApply bor_kind_min_incl_r.
+ + iPureIntro. apply place_access_rt_rel_refl.
+ Qed.
+ Global Instance typed_place_mut_owned_inst {rto} E L π κ γ (lt2 : ltype rto) bmin0 r l wl P :
+ TypedPlace E L π l (MutLtype lt2 κ) (PlaceIn (r, γ)) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) | 30 := λ T, i2p (typed_place_mut_owned π κ lt2 P E L γ l r wl bmin0 T).
+
+ Lemma typed_place_mut_uniq {rto} π E L (lt2 : ltype rto) P l r κ γ κ' γ' bmin0 (T : place_cont_t (place_rfn rto * gname)) :
+ li_tactic (lctx_lft_alive_count_goal E L κ') (λ '(κs, L'),
+ (∀ l', typed_place π E L' l' lt2 r (Uniq κ γ ⊓ₖ bmin0) (Uniq κ γ) P
+ (λ L'' κs' l2 b2 bmin rti tyli ri strong weak,
+ T L'' (κs ++ κs') l2 b2 (Uniq κ' γ' ⊓ₖ bmin) rti tyli ri
+ (* strong branch: fold to OpenedLtype *)
+ (fmap (λ strong, mk_strong (λ rti, (place_rfn (strong.(strong_rt) rti) * gname)%type)
+ (λ rti2 ltyi2 ri2,
+ OpenedLtype (MutLtype (strong.(strong_lt) _ ltyi2 ri2) κ) (MutLtype lt2 κ) (MutLtype lt2 κ) (λ r1 r1', ⌜r1 = r1'âŒ) (λ _ _, llft_elt_toks κs))
+ (λ rti2 ri2, #((strong.(strong_rfn) _ ri2), γ))
+ strong.(strong_R)) strong)
+ (* weak branch: just keep the MutLtype *)
+ (fmap (λ weak, mk_weak (λ lti' ri', MutLtype (weak.(weak_lt) lti' ri') κ) (λ (r : place_rfn rti), #(weak.(weak_rfn) r, γ)) weak.(weak_R)) weak))))
+ ⊢ typed_place π E L l (MutLtype lt2 κ) #(r, γ) bmin0 (Uniq κ' γ') (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ rewrite /lctx_lft_alive_count_goal.
+ iIntros "(%κs & %L2 & %Hal & HT)".
+ iIntros (Φ F ??). iIntros "#(LFT & TIME & LLCTX) #HE HL #Hincl0 HP HΦ/=".
+ (* get a token *)
+ iApply fupd_wp. iMod (fupd_mask_subseteq lftE) as "HclF"; first done.
+ iMod (lctx_lft_alive_count_tok lftE with "HE HL") as (q) "(Hκ' & Hclκ' & HL)"; [done.. | ].
+ iMod "HclF" as "_". iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iPoseProof (mut_ltype_acc_uniq F with "[$LFT $TIME $LLCTX] Hκ' Hclκ' HP") as "(%Hly & Hlb & Hb)"; [done.. | ].
+ iMod "Hb" as "(%l' & Hl & Hb & Hcl)". iMod "HclF" as "_".
+ iModIntro. iApply (wp_logical_step with "TIME Hcl"); [solve_ndisj.. | ].
+ iApply (wp_deref with "Hl") => //; [solve_ndisj | by apply val_to_of_loc | ].
+ iNext.
+ iIntros (st) "Hl Hcred Hcl".
+ iExists l'.
+ iSplitR. { iPureIntro. unfold mem_cast. rewrite val_to_of_loc. done. }
+ iApply ("HT" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hb"). { iApply bor_kind_min_incl_l. }
+ iModIntro. iIntros (L'' κs' l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hb Hs".
+ iApply ("HΦ" $! _ _ _ _ (Uniq κ' γ' ⊓ₖ bmin) _ _ _ _ _ with "[Hincl1] Hb").
+ { iApply bor_kind_incl_trans; last iApply "Hincl1". iApply bor_kind_min_incl_r. }
+ simpl. iSplit.
+ - (* strong update *)
+ iDestruct "Hs" as "(Hs & _)". iDestruct "Hcl" as "(_ & Hcl)".
+ destruct strong as [ strong | ]; last done.
+ iIntros (tyli2 ri2 bmin').
+ iIntros "Hl2 %Hst".
+ iMod ("Hs" with "Hl2 [//]") as "(Hb & %Hst' & HR)".
+ iMod ("Hcl" with "Hl [] Hb") as "Hb".
+ { iPureIntro. done. }
+ iModIntro. simp_ltypes.
+ iFrame. done.
+ - (* weak update *)
+ destruct weak as [ weak | ]; last done.
+ iDestruct "Hs" as "(_ & Hs)". iDestruct "Hcl" as "(Hcl & _)".
+ iIntros (ltyi2 ri2 bmin') "#Hincl2 Hl2 Hcond".
+ iMod ("Hs" with "[Hincl2] Hl2 Hcond") as "(Hb & Hcond & ? & HR)".
+ { iApply bor_kind_incl_trans; first iApply "Hincl2". iApply bor_kind_min_incl_r. }
+ simpl.
+ iMod ("Hcl" with "Hl Hb [] Hcond") as "(Hb & Hκ' & Hcond)".
+ { iApply bor_kind_incl_trans; first iApply bor_kind_min_incl_r. done. }
+ iModIntro. iFrame. rewrite llft_elt_toks_app. iFrame.
+ iApply typed_place_cond_incl; last done.
+ iApply bor_kind_min_incl_r.
+ Qed.
+ Global Instance typed_place_mut_uniq_inst {rto} E L π κ κ' γ γ' (lt2 : ltype rto) bmin0 r l P :
+ TypedPlace E L π l (MutLtype lt2 κ) (#(r, γ)) bmin0 (Uniq κ' γ') (DerefPCtx Na1Ord PtrOp true :: P) | 30 := λ T, i2p (typed_place_mut_uniq π E L lt2 P l r κ γ κ' γ' bmin0 T).
+
+ (* TODO: shared. can also do strong updates due to ShadowedLtype
+ Lemma place_mut_shared {rto} π E L κ κ' (lt2 : ltype rto) P γ l bmin0 r
+ (T : llctx → list lft → loc → bor_kind → bor_kind → ∀ rti, ltype rti → place_rfn rti → (ltype rti → ltype (place_rfn rto * gname)) → (place_rfn rti → place_rfn ((place_rfn rto) * gname)) → (ltype rti → place_rfn rti → iProp Σ) → iProp Σ) :
+ (* get lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L κ') (λ '(κs, L'),
+ (* recursively check the place *)
+ (∀ l', typed_place π E L' l' lt2 r (Uniq κ γ ⊓ₖ bmin0) (Uniq κ γ) P
+ (λ L'' κs' l2 b2 bmin rti tyli ri (tylp : ltype rti → ltype rto) (rctx : place_rfn rti → place_rfn rto) R,
+ T L'' (κs ++ κs') l2 b2 (Shared κ' ⊓ₖ bmin) rti tyli ri ((λ lt, MutLtype lt κ) ∘ tylp) (λ (r : place_rfn rti), PlaceIn (rctx r, γ)) R))) -∗
+ typed_place π E L l (MutLtype lt2 κ) (#(r, γ)) bmin0 (Shared κ') (DerefPCtx Na1Ord PtrOp :: P) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance typed_place_mut_shared_inst {rto} E L π κ κ' γ (lt2 : ltype rto) bmin0 r l P :
+ TypedPlace E L π l (MutLtype lt2 κ) (PlaceIn (r, γ)) bmin0 (Shared κ') (DerefPCtx Na1Ord PtrOp :: P) | 30 := λ T, i2p (place_mut_shared π E L κ κ' lt2 P γ l bmin0 r T).
+ *)
+
+
+ (** Stratification *)
+ Lemma stratify_ltype_mut_owned {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) wl γ
+ (T : llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ) :
+ (∀ l', stratify_ltype π E L mu mdu ma ml l' lt r (Uniq κ γ) (λ L' R rt' lt' r',
+ match ma with
+ | StratRefoldFull =>
+ ∃ (_ : Inhabited rt'), cast_ltype_to_type E L' lt' (λ ty', T L' R _ (◠(mut_ref ty' κ))%I (PlaceIn (r', γ)))
+ | _ =>
+ T L' R _ (MutLtype lt' κ) (PlaceIn (r', γ))
+ end))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (MutLtype lt κ) (PlaceIn (r, γ)) (Owned wl) T.
+ Proof.
+ iIntros "Hs". iIntros (?? ?) "#(LFT & TIME & LLCTX) #HE HL Hb".
+ iPoseProof (mut_ltype_acc_owned F with "[$LFT $TIME $LLCTX] Hb") as "Hb"; [done.. | ].
+ iDestruct "Hb" as "(%Hly & #Hlb & >(%l' & Hl & Hb & Hcl))".
+ iPoseProof ("Hs" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hb") as "Hb".
+ iMod "Hb" as "(%L' & %R & %rt' & %lt' & %r' & HL & %Hcond & Hstep & Hc)".
+ destruct (decide (ma = StratRefoldFull)) as [Heq | ].
+ - subst ma.
+ iDestruct "Hc" as "(% & %ty' & %Heq' & HT)".
+ iPoseProof (eqltype_use F with "[$LFT $TIME $LLCTX] HE HL") as "(Hvs & HL)"; [done | .. ].
+ { apply full_eqltype_alt. apply Heq'. }
+ (*iPoseProof (eqltype_acc with "[$LFT $TIME $LLCTX] HE HL") as "#Heq"; first done.*)
+ iModIntro. iExists L', R, _, _, _. iFrame.
+ iSplitR. { simp_ltypes. done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro. iIntros "(Hb & $) Hcl".
+ iMod ("Hvs" with "Hb") as "Hb".
+ iMod ("Hcl" $! (Uniq κ γ) with "Hl Hb") as "(Hb & _)".
+ iDestruct (mut_ref_unfold_1 ty' κ (Owned wl)) as "(_ & #Hi & _)".
+ iMod (fupd_mask_mono with "(Hi Hb)") as "$"; first done.
+ done.
+ - iAssert (T L' R _ (MutLtype lt' κ) (PlaceIn (r', γ)))%I with "[Hc]" as "Hc".
+ { destruct ma; done. }
+ iModIntro. iExists L', R, _, _, _. iFrame.
+ iSplitR. { simp_ltypes; done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro. iIntros "(Hb & $) Hcl".
+ by iMod ("Hcl" $! (Uniq κ γ) with "Hl Hb") as "($ & _)".
+ Qed.
+ Global Instance stratify_ltype_mut_owned_weak_inst {rt} π E L mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) wl γ :
+ StratifyLtype π E L StratMutWeak mdu ma ml l (MutLtype lt κ) (PlaceIn (r, γ)) (Owned wl) :=
+ λ T, i2p (stratify_ltype_mut_owned π E L StratMutWeak mdu ma ml l lt κ r wl γ T).
+ Global Instance stratify_ltype_mut_owned_none_inst {rt} π E L mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) wl γ :
+ StratifyLtype π E L StratMutNone mdu ma ml l (MutLtype lt κ) (PlaceIn (r, γ)) (Owned wl) := λ T, i2p (stratify_ltype_mut_owned π E L StratMutNone mdu ma ml l lt κ r wl γ T).
+
+ Lemma stratify_ltype_mut_uniq {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) κ' γ' γ
+ (T : llctx → iProp Σ → ∀ rt', ltype rt' → place_rfn rt' → iProp Σ) :
+ (* get a lifetime token *)
+ li_tactic (lctx_lft_alive_count_goal E L κ') (λ '(κs, L1),
+ (∀ l', stratify_ltype π E L1 mu mdu ma ml l' lt r (Uniq κ γ) (λ L2 R rt' lt' r',
+ (* validate the update *)
+ prove_place_cond E L2 (Uniq κ' γ') lt lt' (λ upd,
+ match upd with
+ | ResultWeak Heq =>
+ (* update obeys the contract, get a mutable reference *)
+ match ma with
+ | StratRefoldFull => ∃ (_ : Inhabited rt'), cast_ltype_to_type E L2 lt' (λ ty',
+ T L2 (llft_elt_toks κs ∗ R) _ (◠(mut_ref ty' κ))%I (PlaceIn (r', γ)))
+ | _ =>
+ T L2 (llft_elt_toks κs ∗ R) _ (MutLtype lt' κ) (PlaceIn (r', γ))
+ end
+ | ResultStrong =>
+ (* unfold to an OpenedLtype *)
+ ⌜ma = StratNoRefold⌠∗
+ T L2 R _ (OpenedLtype (MutLtype lt' κ) (MutLtype lt κ) (MutLtype lt κ) (λ r1 r2, ⌜r1 = r2âŒ) (λ _ _, llft_elt_toks κs)) (PlaceIn (r', γ))
+ end))))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (MutLtype lt κ) (PlaceIn (r, γ)) (Uniq κ' γ') T.
+ Proof.
+ Admitted.
+ Global Instance stratify_ltype_mut_uniq_weak_inst {rt} π E L mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) κ' γ' γ :
+ StratifyLtype π E L StratMutWeak mdu ma ml l (MutLtype lt κ) (PlaceIn (r, γ)) (Uniq κ' γ') :=
+ λ T, i2p (stratify_ltype_mut_uniq π E L StratMutWeak mdu ma ml l lt κ r κ' γ' γ T).
+ Global Instance stratify_ltype_mut_uniq_none_inst {rt} π E L mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) κ' γ' γ :
+ StratifyLtype π E L StratMutNone mdu ma ml l (MutLtype lt κ) (PlaceIn (r, γ)) (Uniq κ' γ') :=
+ λ T, i2p (stratify_ltype_mut_uniq π E L StratMutNone mdu ma ml l lt κ r κ' γ' γ T).
+
+ (** Unfolding instances *)
+ Lemma stratify_ltype_ofty_mut {rt} `{Inhabited rt} π E L mu ma {M} (ml : M) l (ty : type rt) κ (r : place_rfn (place_rfn rt * gname)) b T :
+ stratify_ltype π E L mu StratDoUnfold ma ml l (MutLtype (◠ty) κ) r b T
+ ⊢ stratify_ltype π E L mu StratDoUnfold ma ml l (◠(mut_ref ty κ)) r b T.
+ Proof.
+ iIntros "Hp". iApply stratify_ltype_eqltype; iFrame.
+ iPureIntro. iIntros (?) "HL CTX HE".
+ iApply ltype_eq_sym. iApply mut_ref_unfold.
+ Qed.
+ Global Instance stratify_ltype_ofty_mut_inst {rt} `{Inhabited rt} π E L mu ma {M} (ml : M) l (ty : type rt) κ (r : place_rfn (place_rfn rt * gname)) b :
+ StratifyLtype π E L mu StratDoUnfold ma ml l (◠(mut_ref ty κ))%I r b | 30 :=
+ λ T, i2p (stratify_ltype_ofty_mut π E L mu ma ml l ty κ r b T).
+
+
+ (** prove_place_cond instances *)
+ (* These need to have a lower priority than the ofty_refl instance (level 2) and the unblocking instances (level 5), but higher than the trivial "no" instance *)
+ Lemma prove_place_cond_unfold_mut_l E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k T :
+ prove_place_cond E L k (MutLtype (◠ty) κ) lt T
+ ⊢ prove_place_cond E L k (◠(mut_ref ty κ)) lt T.
+ Proof.
+ iApply prove_place_cond_eqltype_l. apply symmetry. apply mut_ref_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_mut_l_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k :
+ ProvePlaceCond E L k (◠(mut_ref ty κ))%I lt | 10 := λ T, i2p (prove_place_cond_unfold_mut_l E L ty lt κ k T).
+ Lemma prove_place_cond_unfold_mut_r E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k T :
+ prove_place_cond E L k lt (MutLtype (◠ty) κ) T
+ ⊢ prove_place_cond E L k lt (◠(mut_ref ty κ)) T.
+ Proof.
+ iApply prove_place_cond_eqltype_r. apply symmetry. apply mut_ref_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_mut_r_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k :
+ ProvePlaceCond E L k lt (◠(mut_ref ty κ))%I | 10 := λ T, i2p (prove_place_cond_unfold_mut_r E L ty lt κ k T).
+
+ Lemma prove_place_cond_mut_ltype E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 k T :
+ ⌜lctx_lft_incl E L κ1 κ2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ prove_place_cond E L k lt1 lt2 (λ upd, T $ access_result_lift (λ rt, (place_rfn rt * gname)%type) upd)
+ ⊢ prove_place_cond E L k (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Hincl1 & %Hincl2 & HT)". iIntros (F ?) "#CTX #HE HL".
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hincl1"; first apply Hincl1.
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hincl2"; first apply Hincl2.
+ iMod ("HT" with "[//] CTX HE HL") as "($ & (%upd & Hcond & HT))".
+ iExists _. iFrame.
+ destruct upd.
+ - subst rt2. cbn.
+ iApply ltype_eq_place_cond_ty_trans; first last.
+ { by iApply mut_ltype_place_cond_ty. }
+ iIntros (??). iApply mut_ltype_eq; [ | done..]. iIntros (??). iApply ltype_eq_refl.
+ - cbn. done.
+ Qed.
+ Global Instance prove_place_cond_mut_ltype_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 k :
+ ProvePlaceCond E L k (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 5 := λ T, i2p (prove_place_cond_mut_ltype E L lt1 lt2 κ1 κ2 k T).
+
+ (** Typing rule for mutable borrows, manually applied by the tactics *)
+ Lemma type_mut_bor E L T e π κ_name (ty_annot : option rust_type) :
+ (∃ M, named_lfts M ∗ li_tactic (compute_map_lookup_nofail_goal M κ_name) (λ κ,
+ (named_lfts M -∗ typed_borrow_mut π E L e κ ty_annot (λ L' v γ rt ty r,
+ T L' v (place_rfn rt * gname)%type (mut_ref ty κ) (PlaceIn r, γ)))))
+ ⊢ typed_val_expr π E L (&ref{Mut, ty_annot, κ_name} e) T.
+ Proof.
+ rewrite /compute_map_lookup_nofail_goal.
+ iIntros "HT".
+ iDestruct "HT" as "(%M & Hnamed & %κ & _ & HT)". iIntros (Φ) "#(LFT & TIME & LLCTX) #HE HL HΦ".
+ wp_bind. iSpecialize ("HT" with "Hnamed").
+ iApply ("HT" $! _ ⊤ with "[//] [//] [//] [$LFT $TIME $LLCTX] HE HL").
+ iIntros (l) "Hat HT".
+ unfold Ref.
+ wp_bind.
+ iApply (wp_logical_step with "TIME [HT Hat]"); [solve_ndisj.. | | ].
+ { iApply (logical_step_compose with "HT").
+ iApply (logical_step_intro_atime with "Hat").
+ iIntros "H1 H2 !> H3". iApply ("H3" with "H1 H2"). }
+ (* also need to generate a new cumulative receipt for the created reference *)
+ iMod (additive_time_receipt_0) as "Hc".
+ iMod (persistent_time_receipt_0) as "Hp".
+ iApply (wp_skip_credits with "TIME Hc Hp"); first done.
+ iIntros "!> Hcred1 Hc HT" => /=.
+ iMod ("HT") as "(%L' & %rt' & %ty & %r & %γ & %ly & Hobs & Hbor & %Hst & %Hly & #Hlb & #Hsc & HL & HT)".
+ iModIntro.
+ (* generate the credits for the new reference *)
+ iMod (persistent_time_receipt_0) as "Hp".
+ iApply (wp_skip_credits with "TIME Hc Hp"); first done.
+ rewrite (additive_time_receipt_sep 1). iNext. iIntros "[Hcred2 Hcred] [Hat1 Hat]".
+ (* We use [Hcred1] for folding the pinned borrow, and [Hcred] as a deposit in the reference *)
+ iApply ("HΦ" with "HL [Hcred Hcred1 Hat Hat1 Hbor Hobs] HT").
+ iExists l, ly. iSplitR; first done. iFrame "# ∗".
+ iSplitR; first done. iSplitR; first done.
+ by iApply (pinned_bor_unfold with "LFT Hcred1 Hbor").
+ Qed.
+
+ (** resolve_ghost *)
+ Lemma resolve_ghost_mut_Owned {rt} π E L l (lt : ltype rt) γ rm lb κ wl T :
+ find_observation (place_rfn rt * gname) γ FindObsModeDirect (λ or,
+ match or with
+ | None => ⌜rm = ResolveTry⌠∗ T L (PlaceGhost γ) True false
+ | Some r => T L (PlaceIn $ r) True true
+ end)
+ ⊢ resolve_ghost π E L rm lb l (MutLtype lt κ) (Owned wl) (PlaceGhost γ) T.
+ Proof.
+ rewrite /FindOptGvarPobs /=.
+ iIntros "HT". iIntros (F ??) "#CTX #HE HL Hb".
+ iMod ("HT" with "[//]") as "HT". iDestruct "HT" as "[(%r & Hobs & HT) | (-> & HT)]".
+ - rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hb" as "(%ly & %Hst & %Hly & ? & ? & %γ0 & %r'& Hrfn & ?)".
+ simpl. iDestruct "Hrfn" as "(Hrfn & Hcred)".
+ iPoseProof (gvar_pobs_agree with "Hrfn Hobs") as "%Heq". subst r.
+ iModIntro. iExists _, _, _, _. iFrame. iApply maybe_logical_step_intro.
+ iL. rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iExists _. iFrame. do 2 iR. iExists _, _. iR. iFrame.
+ - iExists _, _, _, _. iFrame. iApply maybe_logical_step_intro. by iFrame.
+ Qed.
+ Global Instance resolve_ghost_mut_owned_inst {rt} π E L l (lt : ltype rt) κ γ wl rm lb :
+ ResolveGhost π E L rm lb l (MutLtype lt κ) (Owned wl) (PlaceGhost γ) | 7 := λ T, i2p (resolve_ghost_mut_Owned π E L l lt γ rm lb κ wl T).
+
+ Lemma resolve_ghost_mut_Uniq {rt} π E L l (lt : ltype rt) γ rm lb κ κ' γ' T :
+ find_observation (place_rfn rt * gname) γ FindObsModeDirect (λ or,
+ match or with
+ | None => ⌜rm = ResolveTry⌠∗ T L (PlaceGhost γ) True false
+ | Some r => T L (PlaceIn $ r) True true
+ end)
+ ⊢ resolve_ghost π E L rm lb l (MutLtype lt κ) (Uniq κ' γ') (PlaceGhost γ) T.
+ Proof.
+ rewrite /FindOptGvarPobs /=.
+ iIntros "HT". iIntros (F ??) "#CTX #HE HL Hb".
+ iMod ("HT" with "[//]") as "HT". iDestruct "HT" as "[(%r & Hobs & HT) | (-> & HT)]".
+ - rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iDestruct "Hb" as "(%ly & %Hst & %Hly & ? & ? & ? & Hrfn & ?)".
+ simpl. iDestruct "Hrfn" as "(Hcred & Hrfn)".
+ iDestruct "Hrfn" as "(%r0 & %r1 & Ha1 & Ha2 & %Heq)".
+ iPoseProof (gvar_pobs_agree with "Ha1 Hobs") as "%". subst.
+ iModIntro. iExists _, _, _,_. iFrame. iApply maybe_logical_step_intro.
+ iL. rewrite ltype_own_mut_ref_unfold /mut_ltype_own.
+ iExists _. iFrame. done.
+ - iExists _, _, _, _. iFrame. iApply maybe_logical_step_intro. by iFrame.
+ Qed.
+ Global Instance resolve_ghost_mut_uniq_inst {rt} π E L l (lt : ltype rt) κ γ κ' γ' rm lb :
+ ResolveGhost π E L rm lb l (MutLtype lt κ) (Uniq κ' γ') (PlaceGhost γ) | 7 := λ T, i2p (resolve_ghost_mut_Uniq π E L l lt γ rm lb κ κ' γ' T).
+
+ (** cast_ltype *)
+ Lemma cast_ltype_to_type_mut E L {rt} `{Inhabited rt} (lt : ltype rt) κ T :
+ cast_ltype_to_type E L lt (λ ty, T (mut_ref ty κ))
+ ⊢ cast_ltype_to_type E L (MutLtype lt κ) T.
+ Proof.
+ iIntros "Hs". iDestruct "Hs" as "(%ty & %Heq & HT)".
+ iExists (mut_ref ty κ). iFrame "HT". iPureIntro.
+ by apply mut_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance cast_ltype_to_type_mut_inst E L {rt} `{Inhabited rt} (lt : ltype rt) κ :
+ CastLtypeToType E L (MutLtype lt κ) :=
+ λ T, i2p (cast_ltype_to_type_mut E L lt κ T).
+
+ (** Subtyping instances *)
+ Lemma weak_subtype_mut E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) r1 r2 κ1 κ2 T :
+ ⌜r1 = r2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_eqtype E L ty1 ty2 T
+ ⊢ weak_subtype E L r1 r2 (mut_ref ty1 κ1) (mut_ref ty2 κ2) T.
+ Proof.
+ iIntros "(-> & %Hincl & %Heq & HT)".
+ iIntros (??) "#CTX #HE HL".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE").
+ iPoseProof (full_eqtype_acc with "HE HL") as "#Heq"; first done.
+ iFrame. unshelve iApply mut_ref_type_incl; [done | done | ..].
+ - iIntros (r). iDestruct ("Heq" $! r) as "($ & _)".
+ - iModIntro. iIntros (r). iDestruct ("Heq" $! r) as "(_ & $)".
+ Qed.
+ Global Instance weak_subtype_mut_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) r1 r2 κ1 κ2 :
+ Subtype E L r1 r2 (mut_ref ty1 κ1) (mut_ref ty2 κ2) :=
+ λ T, i2p (weak_subtype_mut E L ty1 ty2 r1 r2 κ1 κ2 T).
+
+ Lemma mut_subtype_mut E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ1 κ2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_eqtype E L ty1 ty2 T
+ ⊢ mut_subtype E L (mut_ref ty1 κ1) (mut_ref ty2 κ2) T.
+ Proof.
+ iIntros "(%Hincl1 & %Hincl2 & %Hsub & HT)". iFrame "HT".
+ iPureIntro. apply mut_ref_full_subtype; done.
+ Qed.
+ Global Instance mut_subtype_mut_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 :
+ MutSubtype E L (mut_ref ty1 κ1) (mut_ref ty2 κ2) :=
+ λ T, i2p (mut_subtype_mut E L ty1 ty2 κ1 κ2 T).
+
+ Lemma mut_eqtype_mut E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ1 κ2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_eqtype E L ty1 ty2 T
+ ⊢ mut_eqtype E L (mut_ref ty1 κ1) (mut_ref ty2 κ2) T.
+ Proof.
+ iIntros "(%Hincl1 & %Hincl2 & %Heq & HT)". iFrame "HT".
+ iPureIntro. apply full_subtype_eqtype; apply mut_ref_full_subtype; done.
+ Qed.
+ Global Instance mut_eqtype_mut_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 :
+ MutEqtype E L (mut_ref ty1 κ1) (mut_ref ty2 κ2) :=
+ λ T, i2p (mut_eqtype_mut E L ty1 ty2 κ1 κ2 T).
+
+ (** Subltyping instances *)
+ (* generic in [r2] to handle the case that it is an evar *)
+ Lemma weak_subltype_mut_owned_in E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl κ1 κ2 γ r1 r2 T :
+ (∃ r2', ⌜r2 = #(r2', γ)⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ weak_subltype E L (Uniq κ1 γ) r1 r2' lt1 lt2 T)
+ ⊢ weak_subltype E L (Owned wl) #(r1, γ) r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%r2' & -> & %Hincl & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl' & HL & $)".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE"). iFrame.
+ iApply (mut_ltype_incl_owned_in with "Hincl'").
+ done.
+ Qed.
+ Global Instance weak_subltype_mut_owned_in_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl κ1 κ2 γ r1 r2 :
+ SubLtype E L (Owned wl) #(r1, γ) r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 10 := λ T, i2p (weak_subltype_mut_owned_in E L lt1 lt2 wl κ1 κ2 γ r1 r2 T).
+
+ (* instance to destruct the pair if necessary *)
+ Lemma weak_subltype_mut_owned_in' E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl κ1 κ2 r1 r2 T :
+ (∀ r1' γ, ⌜r1 = (r1', γ)⌠-∗ weak_subltype E L (Owned wl) #(r1', γ) r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) T)
+ ⊢ weak_subltype E L (Owned wl) #r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "Ha". destruct r1. by iApply "Ha".
+ Qed.
+ Global Instance weak_subltype_mut_owned_in'_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl κ1 κ2 r1 r2 :
+ SubLtype E L (Owned wl) #r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 12 := λ T, i2p (weak_subltype_mut_owned_in' E L lt1 lt2 wl κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_mut_shared_in E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ κ1 κ2 γ r1 r2 T :
+ (∃ r2', ⌜r2 = #(r2', γ)⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ weak_subltype E L (Shared (κ1 ⊓ κ)) r1 r2' lt1 lt2 T)
+ ⊢ weak_subltype E L (Shared κ) #(r1, γ) r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%r2' & -> & %Hincl & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl' & HL & $)".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE"). iFrame.
+ iApply (mut_ltype_incl_shared_in with "[Hincl']"); last done.
+ done.
+ Qed.
+ Global Instance weak_subltype_mut_shared_in_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ κ1 κ2 γ r1 r2 :
+ SubLtype E L (Shared κ) #(r1, γ) r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 10 := λ T, i2p (weak_subltype_mut_shared_in E L lt1 lt2 κ κ1 κ2 γ r1 r2 T).
+
+ (* Base instance that will trigger, e.g., for Uniq or PlaceGhost refinements *)
+ (* TODO can have more specific instances for PlaceGhost for Shared and Owned *)
+ Lemma weak_subltype_mut_base E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 T :
+ ⌜r1 = r2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ ⌜lctx_lft_incl E L κ1 κ2⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(<- & %Hincl1 & %Hincl2 & %Hsubt & T)" (??) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hincl"; first done.
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl1"; first apply Hincl1.
+ iSpecialize ("Hincl1" with "HE").
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl2"; first apply Hincl2.
+ iSpecialize ("Hincl2" with "HE").
+ iFrame. iApply mut_ltype_incl; done.
+ Qed.
+ Global Instance weak_subltype_mut_base_inst E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 :
+ SubLtype E L k r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 20 := λ T, i2p (weak_subltype_mut_base E L lt1 lt2 k κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_mut_evar_lft E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ1) T
+ ⊢ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subltype_mut_evar_lft_inst E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 `{!IsProtected κ2} :
+ SubLtype E L k r1 r2 (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 9 := λ T, i2p (weak_subltype_mut_evar_lft E L lt1 lt2 k κ1 κ2 r1 r2 T).
+
+ Lemma mut_subltype_mut E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ2 κ1⌠∗ ⌜lctx_lft_incl E L κ1 κ2⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ mut_subltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Hincl1 & %Hincl2 & %Heq & $)".
+ iPureIntro. apply mut_full_subltype; done.
+ Qed.
+ Global Instance mut_subltype_mut_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ MutSubLtype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 10 := λ T, i2p (mut_subltype_mut E L lt1 lt2 κ1 κ2 T).
+
+ Lemma mut_subltype_mut_evar_lft E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ mut_subltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ1) T
+ ⊢ mut_subltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_subltype_mut_evar_lft_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 `{!IsProtected κ2} :
+ MutSubLtype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) | 9 := λ T, i2p (mut_subltype_mut_evar_lft E L lt1 lt2 κ1 κ2 T).
+
+ Lemma mut_eqltype_mut E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ2 κ1⌠∗ ⌜lctx_lft_incl E L κ1 κ2⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ mut_eqltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Hincl1 & %Hincl2 & %Heq & $)".
+ iPureIntro. apply mut_full_eqltype; done.
+ Qed.
+ Global Instance mut_eqltype_mut_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ MutEqLtype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) := λ T, i2p (mut_eqltype_mut E L lt1 lt2 κ1 κ2 T).
+
+ Lemma mut_eqltype_mut_evar_lft E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ mut_eqltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ1) T
+ ⊢ mut_eqltype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_eqltype_mut_evar_lft_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 `{!IsProtected κ2} :
+ MutEqLtype E L (MutLtype lt1 κ1) (MutLtype lt2 κ2) := λ T, i2p (mut_eqltype_mut_evar_lft E L lt1 lt2 κ1 κ2 T).
+
+ (* Ofty unfolding if necessary *)
+ Lemma weak_subltype_mut_ofty_1_evar E L {rt1 rt2} (lt1 : ltype rt1) (ty2 : type (place_rfn rt2 * gname)) k κ1 r1 r2 T :
+ (∃ ty2', ⌜ty2 = mut_ref ty2' κ1⌠∗ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (◠(mut_ref ty2' κ1)) T)
+ ⊢ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)". done.
+ Qed.
+ Global Instance weak_subltype_mut_ofty_1_evar_inst E L {rt1 rt2} (lt1 : ltype rt1) (ty2 : type (place_rfn rt2 * gname)) k κ1 r1 r2 `{!IsProtected ty2} :
+ SubLtype E L k r1 r2 (MutLtype lt1 κ1) (◠ty2)%I | 10 := λ T, i2p (weak_subltype_mut_ofty_1_evar E L lt1 ty2 k κ1 r1 r2 T).
+
+ Lemma weak_subltype_mut_ofty_1 E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type rt2) k κ1 κ2 r1 r2 T :
+ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (MutLtype (◠ty2) κ2) T
+ ⊢ weak_subltype E L k r1 r2 (MutLtype lt1 κ1) (◠(mut_ref ty2 κ2)) T.
+ Proof.
+ iIntros "HT". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "Hincl").
+ iApply mut_ref_unfold_1.
+ Qed.
+ Global Instance weak_subltype_mut_ofty_1_inst E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type rt2) k κ1 κ2 r1 r2 :
+ SubLtype E L k r1 r2 (MutLtype lt1 κ1) (◠(mut_ref ty2 κ2))%I | 11 := λ T, i2p (weak_subltype_mut_ofty_1 E L lt1 ty2 k κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_mut_ofty_2 E L {rt1 rt2} `{!Inhabited rt1} (ty1 : type (rt1)) (lt2 : ltype rt2) k r1 r2 κ1 κ2 T :
+ (weak_subltype E L k r1 r2 (MutLtype (◠ty1) κ1) (MutLtype lt2 κ2) T)
+ ⊢ weak_subltype E L k r1 r2 (◠(mut_ref ty1 κ1)) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "HT" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "[] Hincl").
+ iApply mut_ref_unfold_2.
+ Qed.
+ Global Instance weak_subltype_mut_ofty_2_inst E L {rt1 rt2} `{!Inhabited rt1} (ty1 : type (rt1)) (lt2 : ltype rt2) k r1 r2 κ1 κ2 :
+ SubLtype E L k r1 r2 (◠(mut_ref ty1 κ1))%I (MutLtype lt2 κ2) | 10 := λ T, i2p (weak_subltype_mut_ofty_2 E L ty1 lt2 k r1 r2 κ1 κ2 T).
+
+ (* Same for mut_subltype *)
+ Lemma mut_subltype_mut_ofty_1_evar E L {rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt * gname)) κ1 T :
+ (∃ ty2', ⌜ty2 = mut_ref ty2' κ1⌠∗ mut_subltype E L (MutLtype lt1 κ1) (◠(mut_ref ty2' κ1)) T)
+ ⊢ mut_subltype E L (MutLtype lt1 κ1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)". done.
+ Qed.
+ Global Instance mut_subltype_mut_ofty_1_evar_inst E L {rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt * gname)) κ1 `{!IsProtected ty2} :
+ MutSubLtype E L (MutLtype lt1 κ1) (◠ty2)%I | 10 := λ T, i2p (mut_subltype_mut_ofty_1_evar E L lt1 ty2 κ1 T).
+
+ Lemma mut_subltype_mut_ofty_1 E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type rt) κ1 κ2 T :
+ mut_subltype E L (MutLtype lt1 κ1) (MutLtype (◠ty2) κ2) T
+ ⊢ mut_subltype E L (MutLtype lt1 κ1) (◠(mut_ref ty2 κ2)) T.
+ Proof.
+ iIntros "(%Hsub & $)". iPureIntro.
+ etrans; first done.
+ eapply full_eqltype_subltype_l. by apply mut_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_mut_ofty_1_inst E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type rt) κ1 κ2 :
+ MutSubLtype E L (MutLtype lt1 κ1) (◠(mut_ref ty2 κ2))%I | 10 := λ T, i2p (mut_subltype_mut_ofty_1 E L lt1 ty2 κ1 κ2 T).
+
+ Lemma mut_subltype_mut_ofty_2 E L {rt} `{!Inhabited rt} (ty1 : type (rt)) (lt2 : ltype rt) κ1 κ2 T :
+ (mut_subltype E L (MutLtype (◠ty1) κ1) (MutLtype lt2 κ2) T)
+ ⊢ mut_subltype E L (◠(mut_ref ty1 κ1)) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Hsub & $)". iPureIntro.
+ etrans; last done.
+ eapply full_eqltype_subltype_r. by apply mut_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_mut_ofty_2_inst E L {rt} `{!Inhabited rt} (ty1 : type (rt)) (lt2 : ltype rt) κ1 κ2 :
+ MutSubLtype E L (◠(mut_ref ty1 κ1))%I (MutLtype lt2 κ2) | 10 := λ T, i2p (mut_subltype_mut_ofty_2 E L ty1 lt2 κ1 κ2 T).
+
+ (* Same for mut_eqltype *)
+ Lemma mut_eqltype_mut_ofty_1_evar E L {rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt * gname)) κ1 T :
+ (∃ ty2', ⌜ty2 = mut_ref ty2' κ1⌠∗ mut_eqltype E L (MutLtype lt1 κ1) (◠(mut_ref ty2' κ1)) T)
+ ⊢ mut_eqltype E L (MutLtype lt1 κ1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)". done.
+ Qed.
+ Global Instance mut_eqltype_mut_ofty_1_evar_inst E L {rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt * gname)) κ1 `{!IsProtected ty2} :
+ MutEqLtype E L (MutLtype lt1 κ1) (◠ty2)%I | 10 := λ T, i2p (mut_eqltype_mut_ofty_1_evar E L lt1 ty2 κ1 T).
+
+ Lemma mut_eqltype_mut_ofty_1 E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type rt) κ1 κ2 T :
+ mut_eqltype E L (MutLtype lt1 κ1) (MutLtype (◠ty2) κ2) T
+ ⊢ mut_eqltype E L (MutLtype lt1 κ1) (◠(mut_ref ty2 κ2)) T.
+ Proof.
+ iIntros "(%Heq & $)". iPureIntro.
+ etrans; first done. by apply mut_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_mut_ofty_1_inst E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type rt) κ1 κ2 :
+ MutEqLtype E L (MutLtype lt1 κ1) (◠(mut_ref ty2 κ2))%I | 10 := λ T, i2p (mut_eqltype_mut_ofty_1 E L lt1 ty2 κ1 κ2 T).
+
+ Lemma mut_eqltype_mut_ofty_2 E L {rt} `{!Inhabited rt} (ty1 : type (rt)) (lt2 : ltype rt) κ1 κ2 T :
+ (mut_eqltype E L (MutLtype (◠ty1) κ1) (MutLtype lt2 κ2) T)
+ ⊢ mut_eqltype E L (◠(mut_ref ty1 κ1)) (MutLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Heq & $)". iPureIntro.
+ etrans; last done. symmetry. by apply mut_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_mut_ofty_2_inst E L {rt} `{!Inhabited rt} (ty1 : type (rt)) (lt2 : ltype rt) κ1 κ2 :
+ MutEqLtype E L (◠(mut_ref ty1 κ1))%I (MutLtype lt2 κ2) | 10 := λ T, i2p (mut_eqltype_mut_ofty_2 E L ty1 lt2 κ1 κ2 T).
+
+ (** Annotations for shortening the lifetime of a reference *)
+ (* TODO: generalize this to nametrees and nested stuff *)
+ (* TODO think about how this should deal with structs and descending below them *)
+ (*
+ Lemma type_shortenlft_mut E L sup_lfts {rt} `{!Inhabited rt} (ty : type rt) r κ π v T :
+ (∃ M κs, named_lfts M ∗ ⌜lookup_named_lfts M sup_lfts = Some κs⌠∗
+ ⌜lctx_lft_incl E L (lft_intersect_list' κs) κ⌠∗
+ (named_lfts M -∗ v â—áµ¥{Ï€} r @ mut_ref ty (lft_intersect_list' κs) -∗ T L)) -∗
+ typed_annot_expr E L 0 (ShortenLftAnnot sup_lfts) v (v â—áµ¥{Ï€} r @ mut_ref ty κ) T.
+ Proof.
+ iIntros "(%M & %κs & Hnamed & % & %Hincl & HT)".
+ iIntros "#CTX #HE HL Hv /=".
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hincl"; first done.
+ iModIntro. iExists L. iFrame "HL". iApply ("HT" with "Hnamed").
+ unshelve iApply (mut_ref_own_val_mono with "[//] [] [] Hv"); first done.
+ all: iIntros (?); iApply type_incl_refl.
+ Qed.
+ Global Instance type_shortenlft_mut_inst E L sup_lfts {rt} `{!Inhabited rt} (ty : type rt) r κ π v :
+ TypedAnnotExpr E L 0 (ShortenLftAnnot sup_lfts) v (v â—áµ¥{Ï€} r @ mut_ref ty κ) :=
+ λ T, i2p (type_shortenlft_mut E L sup_lfts ty r κ π v T).
+ *)
+End rules.
+
+Global Typeclasses Opaque mut_ref.
+Notation "&mut< κ , τ >" := (mut_ref τ κ) (only printing, format "'&mut<' κ , τ '>'") : stdpp_scope.
+
+(** ** Shared references *)
+Section shr_ref.
+ Context `{typeGS Σ} {rt} (inner : type rt).
+ Implicit Types (κ : lft).
+
+ (* TODO might be able to eliminate this by placing the existential quantifier over the inner refinement differently. *)
+ Context `{Inhabited rt}.
+
+ (* this is almost a simple type, but we have to be careful with
+ the sharing predicate: we want to obtain the knowledge that l points to
+ a location not under a later (to prove the agreement with the ltype unfolding),
+ so the simple_type interface doesn't suffice *)
+ Program Definition shr_ref κ : type (place_rfn rt) := {|
+ ty_sidecond := True;
+ ty_own_val π r v :=
+ (∃ (l : loc) (ly : layout) (r' : rt),
+ ⌜v = val_of_loc l⌠∗
+ ⌜use_layout_alg inner.(ty_syn_type) = Some ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ loc_in_bounds l 0 ly.(ly_size) ∗
+ inner.(ty_sidecond) ∗
+ place_rfn_interp_shared r r' ∗
+ □ |={lftE}=> inner.(ty_shr) κ π r' l)%I;
+
+ ty_has_op_type ot mt := is_ptr_ot ot;
+ ty_syn_type := PtrSynType;
+
+ ty_shr κ' π r l :=
+ (∃ (li : loc) (ly : layout) (ri : rt),
+ ⌜l `has_layout_loc` void*⌠∗
+ (*loc_in_bounds l void*.(ly_size) ∗*)
+ ⌜use_layout_alg inner.(ty_syn_type) = Some ly⌠∗
+ ⌜li `has_layout_loc` ly⌠∗
+ loc_in_bounds li 0 ly.(ly_size) ∗
+ inner.(ty_sidecond) ∗
+ place_rfn_interp_shared r ri ∗
+ &frac{κ'} (λ q, l ↦{q} li) ∗ ▷ □ |={lftE}=> inner.(ty_shr) (κ) π ri li)%I;
+ ty_ghost_drop _ _ := True%I;
+ ty_lfts := κ :: inner.(ty_lfts);
+ ty_wf_E := ty_outlives_E inner κ;
+ |}.
+ Next Obligation. iIntros (????) "(%l & %ly & %r' & -> & ? & ? & ?)". eauto. Qed.
+ Next Obligation.
+ iIntros (? ot Hot) => /=. destruct ot => /=// -> //.
+ Qed.
+ Next Obligation. iIntros (????) "_". done. Qed.
+ Next Obligation.
+ iIntros (?????). simpl. iIntros "(%l' & %ly & %r' & ? & ? & ? & _)". eauto.
+ Qed.
+ Next Obligation.
+ iIntros (κ E κ' l ly π r q ?) "#[LFT TIME] Htok %Halg %Hly _ Hb".
+ simpl. rewrite -{1}lft_tok_sep -{1}lft_tok_sep.
+ iDestruct "Htok" as "(Htok_κ' & Htok_κ & Htok)".
+ iApply fupd_logical_step.
+ iMod (bor_exists with "LFT Hb") as "(%v & Hb)"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "[Hl Hb]"; first solve_ndisj.
+ iMod (bor_exists with "LFT Hb") as "(%l' & Hb)"; first solve_ndisj.
+ iMod (bor_exists with "LFT Hb") as "(%ly' & Hb)"; first solve_ndisj.
+ iMod (bor_exists_tok with "LFT Hb Htok_κ'") as "(%r' & Hb & Htok_κ')"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hb") as "(Heq & Hb)"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Heq Htok_κ'") as "(>-> & Htok_κ')"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hb Htok_κ'") as "(Ha & Htok_κ')"; first solve_ndisj.
+ iDestruct "Ha" as "(>%Halg' & >%Hly' & >#Hlb & >#Hsc & >Hrfn & Hshr)".
+ iMod (bor_fracture (λ q, l ↦{q} l')%I with "LFT Hl") as "Hl"; first solve_ndisj.
+ iModIntro.
+ iApply logical_step_intro.
+ rewrite -!lft_tok_sep. iFrame.
+ iExists l', ly', r'.
+ iSplitR. { inversion Halg; subst; done. }
+ iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done.
+ iFrame.
+ Qed.
+ Next Obligation.
+ iIntros (? κ' κ'' π r l) "#Hord H".
+ iDestruct "H" as (li ly ri) "(? & ? & ? & Hlb & Hsc & Hr & #Hf & #Hown)".
+ iExists li, ly, ri. iFrame. iSplit.
+ - by iApply (frac_bor_shorten with "Hord").
+ - iNext. iDestruct "Hown" as "#Hown". iModIntro. iMod "Hown". iModIntro.
+ done.
+ Qed.
+ Next Obligation.
+ iIntros (??????) "Ha".
+ iApply logical_step_intro. done.
+ Qed.
+ Next Obligation.
+ iIntros (? ot mt st ? r ? Hot).
+ destruct mt.
+ - eauto.
+ - iIntros "(%l & %ly & %ri & -> & ? & ? & ?)".
+ iExists l, ly, ri. iFrame.
+ iPureIntro. move: ot Hot => [] /=// _.
+ rewrite /mem_cast val_to_of_loc //.
+ - iApply (mem_cast_compat_loc (λ v, _)); first done.
+ iIntros "(%l & %ly & %ri & -> & _)". eauto.
+ Qed.
+
+ Global Instance shr_ref_copyable κ : Copyable (shr_ref κ).
+ Proof.
+ constructor; first apply _.
+ iIntros (κ' π E F l ly r ? ? Ha ?) "[LFT TIME] (%li & %ly' & %r' & %Hly' & % & % & #Hlb & #Hsc & #Hr & Hf & #Hown) Htok Hlft".
+ iDestruct (na_own_acc with "Htok") as "[$ Htok]"; first solve_ndisj.
+ iMod (frac_bor_acc with "LFT Hf Hlft") as (q') "[Hmt Hclose]"; first solve_ndisj.
+ iModIntro.
+ assert (ly = void*) as ->. { injection Ha. done. }
+ iSplitR; first done.
+ iExists _. iDestruct "Hmt" as "[Hmt1 Hmt2]".
+ iSplitL "Hmt1". { iNext. iExists li. iFrame "Hmt1". iExists li, ly', r'. iFrame "#". eauto. }
+ iIntros "Htok2 Hmt1". iDestruct "Hmt1" as (vl') "[Hmt1 #Hown']".
+ iDestruct ("Htok" with "Htok2") as "$".
+ iAssert (â–· ⌜length (li : val) = length vl'âŒ)%I as ">%".
+ { iNext. iDestruct (ty_has_layout with "Hown'") as "(% & %Ha' & %Hly)".
+ injection Ha' as <-. rewrite Hly. done. }
+ iApply "Hclose". iModIntro. rewrite -{3}(Qp.div_2 q').
+ iPoseProof (heap_mapsto_agree with "Hmt1 Hmt2") as "%Heq"; first done.
+ subst vl'. rewrite heap_mapsto_fractional. iFrame.
+ Qed.
+
+
+End shr_ref.
+Section subtype.
+ Context `{typeGS Σ}.
+
+ Lemma shr_ref_own_val_mono_in {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) v π r1 r2 κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ type_incl r1 r2 ty1 ty2 -∗
+ v â—áµ¥{Ï€} #r1 @ shr_ref ty1 κ2 -∗
+ v â—áµ¥{Ï€} #r2 @ shr_ref ty2 κ1.
+ Proof.
+ iIntros "#Hincl (%Hst_eq & #Hsc_eq & _ & #Hincl_shr)".
+ iIntros "(%l & %ly & %r' & -> & ? & ? & Hlb & Hsc & -> & #Hl)". iExists l, ly, r2.
+ iSplitR; first done. rewrite -Hst_eq. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iR. iModIntro. iMod "Hl". iModIntro.
+ iApply ty_shr_mono; first iApply "Hincl".
+ by iApply "Hincl_shr".
+ Qed.
+ Lemma shr_ref_own_val_mono {rt} `{!Inhabited rt} (ty1 ty2 : type rt) v π r κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ (∀ r, type_incl r r ty1 ty2) -∗
+ v â—áµ¥{Ï€} r @ shr_ref ty1 κ2 -∗
+ v â—áµ¥{Ï€} r @ shr_ref ty2 κ1.
+ Proof.
+ iIntros "#Hincl #Hsub".
+ iDestruct ("Hsub" $! inhabitant) as "(%Hst_eq & #Hsc_eq & _)".
+ iIntros "(%l & %ly & %r' & -> & ? & ? & Hlb & Hsc & Hr & #Hl)". iExists l, ly, r'.
+ iSplitR; first done. rewrite -Hst_eq. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iModIntro. iMod "Hl". iModIntro.
+ iPoseProof ("Hsub" $! r') as "(_ & _ & _ & #Hincl_shr)".
+ iApply ty_shr_mono; first iApply "Hincl".
+ by iApply "Hincl_shr".
+ Qed.
+
+ Lemma shr_ref_shr_mono_in {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) l π κ r1 r2 κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ type_incl r1 r2 ty1 ty2 -∗
+ l â—â‚—{Ï€, κ} #r1 @ shr_ref ty1 κ2 -∗
+ l â—â‚—{Ï€, κ} #r2 @ shr_ref ty2 κ1.
+ Proof.
+ iIntros "#Hincl (%Hst_eq & #Hsc_eq & _ & #Hincl_shr)".
+ iIntros "(%li & %ly & %r' & ? & ? & ? & Hlb & Hsc & -> & Hli & #Hb)".
+ iExists li, ly, r2. rewrite Hst_eq. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iR. iModIntro. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro.
+ iApply ty_shr_mono; first iApply "Hincl".
+ by iApply "Hincl_shr".
+ Qed.
+ Lemma shr_ref_shr_mono {rt} `{!Inhabited rt} (ty1 ty2 : type rt) l π κ r κ1 κ2 :
+ κ1 ⊑ κ2 -∗
+ (∀ r, type_incl r r ty1 ty2) -∗
+ l â—â‚—{Ï€, κ} r @ shr_ref ty1 κ2 -∗
+ l â—â‚—{Ï€, κ} r @ shr_ref ty2 κ1.
+ Proof.
+ iIntros "#Hincl #Hsub".
+ iPoseProof ("Hsub" $! inhabitant) as "(%Hst_eq & #Hsc_eq & _)".
+ iIntros "(%li & %ly & %r' & ? & ? & ? & Hlb & Hsc & Hr & Hli & #Hb)".
+ iExists li, ly, r'. rewrite Hst_eq. iFrame.
+ iSplitL "Hsc". { by iApply "Hsc_eq". }
+ iModIntro. iDestruct "Hb" as "#Hb". iModIntro. iMod "Hb". iModIntro.
+ iPoseProof ("Hsub" $! r') as "(_ & _ & _ & #Hincl_shr)".
+ iApply ty_shr_mono; first iApply "Hincl".
+ by iApply "Hincl_shr".
+ Qed.
+
+ Lemma shr_ref_type_incl_in {rt1 rt2} κ2 κ1 (ty1 : type rt1) (ty2 : type rt2) r1 r2 :
+ κ1 ⊑ κ2 -∗
+ type_incl r1 r2 ty2 ty1 -∗
+ type_incl #r1 #r2 (shr_ref ty2 κ2) (shr_ref ty1 κ1).
+ Proof.
+ iIntros "#Hincl #Hsub".
+ iSplitR; first done. iSplitR; first done.
+ iSplit; iIntros "!#".
+ - iIntros (??). by iApply shr_ref_own_val_mono_in.
+ - iIntros (???). by iApply shr_ref_shr_mono_in.
+ Qed.
+ Lemma shr_ref_type_incl {rt} `{!Inhabited rt} κ2 κ1 (ty1 ty2 : type rt) r :
+ κ1 ⊑ κ2 -∗
+ (∀ r, type_incl r r ty2 ty1) -∗
+ type_incl r r (shr_ref ty2 κ2) (shr_ref ty1 κ1).
+ Proof.
+ iIntros "#Hincl #Hsub".
+ iSplitR; first done. iSplitR; first done.
+ iSplit; iIntros "!#".
+ - iIntros (??). by unshelve iApply shr_ref_own_val_mono.
+ - iIntros (???). by unshelve iApply shr_ref_shr_mono.
+ Qed.
+
+ Lemma shr_ref_full_subtype {rt} `{!Inhabited rt} E L κ2 κ1 (ty1 ty2 : type rt) :
+ lctx_lft_incl E L κ1 κ2 →
+ full_subtype E L ty2 ty1 →
+ full_subtype E L (shr_ref ty2 κ2) (shr_ref ty1 κ1).
+ Proof.
+ iIntros (Hincl Hsubt r ?) "HL #HE".
+ iPoseProof (Hincl with "HL") as "#Hincl".
+ iSpecialize ("Hincl" with "HE").
+ iPoseProof (full_subtype_acc_noend with "HE HL") as "#Hsubt"; first apply Hsubt.
+ unshelve iApply shr_ref_type_incl; done.
+ Qed.
+End subtype.
+
+
+Section subltype.
+ Context `{!typeGS Σ}.
+
+ (** Shared references *)
+ Local Lemma shr_ltype_incl'_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ' r1 r2 κ1 κ2 :
+ ltype_incl (Shared (κ1)) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Shared κ') #(r1) #(r2) (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & %ri & Hrfn & #Hb)".
+ iExists ly. iFrame. rewrite -?Hd -?Hly_eq. iFrame.
+ iDestruct "Hrfn" as "->".
+ iExists r2. iSplitR; first done. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & Hs & Hb)". iModIntro. iExists li. iFrame. iNext.
+ iDestruct "Heq" as "(_ & Hi1 & _)".
+ iApply ltype_own_shr_mono; last by iApply "Hi1". done.
+ Qed.
+ Lemma shr_ltype_incl_shared_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ' r1 r2 κ1 κ2 :
+ ltype_incl (Shared (κ1)) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Shared κ') #(r1) #(r2) (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply shr_ltype_incl'_shared_in; [ | done ]).
+ - done.
+ - iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma shr_ltype_incl'_shared {rt} (lt1 lt2 : ltype rt) κ' r κ1 κ2 :
+ (∀ r, ltype_incl (Shared (κ1)) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Shared κ') r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & %ri & Hrfn & #Hb)".
+ iExists ly. iFrame. rewrite -?Hd -?Hly_eq. iFrame.
+ iExists ri. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & Hs & Hb)". iModIntro. iExists li. iFrame. iNext.
+ iDestruct ("Heq" $! _) as "(_ & Hi1 & _)".
+ iApply ltype_own_shr_mono; last by iApply "Hi1". done.
+ Qed.
+ Lemma shr_ltype_incl_shared {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ' r κ1 κ2 :
+ (∀ r, ltype_incl (Shared (κ1)) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Shared κ') r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type _ inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply shr_ltype_incl'_shared; [ | done ]).
+ - done.
+ - iIntros (?). iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma shr_ltype_incl'_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 wl r1 r2 :
+ ltype_incl (Shared κ1) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Owned wl) #(r1) #(r2) (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & ? & %ri & Hrfn & Hb)".
+ iModIntro.
+ iExists ly. iFrame. rewrite -?Hd -?Hly_eq.
+ iFrame. iDestruct "Hrfn" as "->". iExists r2. iSplitR; first done. iNext.
+ iMod "Hb" as "(%li & Hli & Hb)". iExists li. iFrame "Hli".
+ iDestruct "Heq" as "(_ & Heq & _)".
+ iApply ltype_own_shr_mono; last by iApply "Heq". done.
+ Qed.
+ Lemma shr_ltype_incl_owned_in {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ1 κ2 wl r1 r2 :
+ ltype_incl (Shared κ1) r1 r2 lt1 lt2 -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Owned wl) #(r1) #(r2) (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply shr_ltype_incl'_owned_in; [ | done ]).
+ - done.
+ - iApply ltype_incl_core. done.
+ Qed.
+
+ Local Lemma shr_ltype_incl'_owned {rt} (lt1 lt2 : ltype rt) κ1 κ2 wl r :
+ (∀ r, ltype_incl (Shared κ1) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl' (Owned wl) r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & ? & %ri & Hrfn & Hb)".
+ iModIntro.
+ iExists ly. iFrame. rewrite -?Hd -?Hly_eq.
+ iFrame. iExists ri. iFrame. iNext.
+ iMod "Hb" as "(%li & Hli & Hb)". iExists li. iFrame "Hli".
+ iDestruct ("Heq" $! _) as "(_ & Heq' & _)".
+ iApply ltype_own_shr_mono; last by iApply "Heq'". done.
+ Qed.
+ Lemma shr_ltype_incl_owned {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ1 κ2 wl r :
+ (∀ r, ltype_incl (Shared κ1) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ ltype_incl (Owned wl) r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1".
+ iPoseProof (ltype_incl_syn_type (Shared _) inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply shr_ltype_incl'_owned; [ | done ]).
+ - done.
+ - iIntros (?). iApply ltype_incl_core. done.
+ Qed.
+
+ (* Refinement subtyping under mutable references is restricted: we need to make sure that, no matter the future updates,
+ we can always get back to what the lender expects. Thus we loose all refinement information when descending below mutable references. *)
+ Local Lemma shr_ltype_incl'_uniq {rt} (lt1 lt2 : ltype rt) κ1 κ2 κ r γ :
+ (∀ r, ltype_eq (Shared (κ1)) r r lt1 lt2) -∗
+ (* Note: requires mutual inclusion, because we may be below a mutable reference *)
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_incl' (Uniq κ γ) r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2". iModIntro.
+ iIntros (Ï€ l). rewrite !ltype_own_shr_ref_unfold /shr_ltype_own.
+ iIntros "(%ly & ? & ? & Hlb & ? & ? & Hrfn & Hb)".
+ iExists ly. iFrame. rewrite -?Hly_eq. iFrame.
+ iMod "Hb". iModIntro. iApply (pinned_bor_iff with "[] [] Hb").
+ + iNext. iModIntro. iSplit.
+ * iIntros "(%ri & Hauth & Hb)". iExists ri. iFrame.
+ iMod "Hb" as "(%li & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! ri) as "((_ & Hi & _) & _)".
+ iApply ltype_own_shr_mono; last by iApply "Hi". done.
+ * iIntros "(%ri & Hauth & Hb)". iExists ri. iFrame.
+ iMod "Hb" as "(%li & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! ri) as "(_ & (_ & Hi & _))".
+ iApply "Hi"; last by iApply ltype_own_shr_mono.
+ + (* the same proof *)
+ iNext. iModIntro. iSplit.
+ * iIntros "(%ri & Hauth & Hb)". iExists ri. iFrame.
+ iMod "Hb" as "(%li & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! ri) as "((_ & Hi & _) & _)".
+ iApply ltype_own_shr_mono; last by iApply "Hi". done.
+ * iIntros "(%ri & Hauth & Hb)". iExists ri. iFrame.
+ iMod "Hb" as "(%li & Hl & Hb)". iModIntro. iExists _. iFrame.
+ iDestruct ("Heq" $! ri) as "(_ & (_ & Hi & _))".
+ iApply "Hi"; last by iApply ltype_own_shr_mono.
+ Qed.
+ Lemma shr_ltype_incl_uniq {rt} (lt1 lt2 : ltype rt) κ1 κ2 κ r γ :
+ (∀ r, ltype_eq (Shared (κ1)) r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_incl (Uniq κ γ) r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2".
+ iPoseProof (ltype_eq_syn_type _ inhabitant with "Heq") as "%Hst".
+ iSplitR; first done. iModIntro.
+ simp_ltypes.
+ iSplit; (iApply shr_ltype_incl'_uniq; [ | done | done]).
+ - done.
+ - iIntros (?). iApply ltype_eq_core. done.
+ Qed.
+
+ Lemma shr_ltype_incl {rt} (lt1 lt2 : ltype rt) b r κ1 κ2 :
+ (∀ b r, ltype_eq b r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_incl b r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2".
+ destruct b.
+ - iApply shr_ltype_incl_owned; last done. iIntros (?). iDestruct ("Heq" $! _ _) as "[$ _]".
+ - iApply shr_ltype_incl_shared; last done. iIntros (?). iDestruct ("Heq" $! _ _) as "[$ _]".
+ - iApply shr_ltype_incl_uniq; [ | done..]. iIntros (?). done.
+ Qed.
+ Lemma shr_ltype_eq {rt} (lt1 lt2 : ltype rt) b r κ1 κ2 :
+ (∀ b r, ltype_eq b r r lt1 lt2) -∗
+ κ2 ⊑ κ1 -∗
+ κ1 ⊑ κ2 -∗
+ ltype_eq b r r (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ iIntros "#Heq #Hincl1 #Hincl2".
+ iSplit.
+ - iApply shr_ltype_incl; done.
+ - iApply shr_ltype_incl; [ | done..]. iIntros (??). iApply ltype_eq_sym. done.
+ Qed.
+
+ Lemma shr_full_subltype E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ full_eqltype E L lt1 lt2 →
+ lctx_lft_incl E L κ1 κ2 →
+ lctx_lft_incl E L κ2 κ1 →
+ full_subltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ intros Hsub Hincl1 Hincl2.
+ iIntros (qL) "HL #CTX #HE". iIntros (??).
+ iPoseProof (lctx_lft_incl_incl_noend with "HL HE") as "#Hincl1"; first apply Hincl1.
+ iPoseProof (lctx_lft_incl_incl_noend with "HL HE") as "#Hincl2"; first apply Hincl2.
+ iPoseProof (Hsub with "HL CTX HE") as "Hsub".
+ iApply (shr_ltype_incl with "Hsub Hincl2 Hincl1").
+ Qed.
+ Lemma shr_full_eqltype E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ full_eqltype E L lt1 lt2 →
+ lctx_lft_incl E L κ1 κ2 →
+ lctx_lft_incl E L κ2 κ1 →
+ full_eqltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2).
+ Proof.
+ intros Hsub Hincl1 Hincl2.
+ apply full_subltype_eqltype; eapply shr_full_subltype; naive_solver.
+ Qed.
+End subltype.
+
+Section ltype_agree.
+ Context `{typeGS Σ}
+ {rt}
+ (ty : type rt).
+
+ Lemma shr_ref_unfold_1_owned κ wl r :
+ ⊢ ltype_incl' (Owned wl) r r (ShrLtype (◠ty) κ) (◠(shr_ref ty κ)).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_shr_ref_unfold /shr_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & #Hlb & ? & %ri & Hrfn & Hb)".
+ iModIntro.
+ iExists ly.
+ iFrame. iFrame "Hlb". iExists _. iFrame. iNext. iMod "Hb" as "(%l' & Hl & Hb)".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & ? & ? & Hsc & Hlb' & %ri' & Hrfn' & Hb)".
+ iExists l'. iFrame. iExists l', _, _. iFrame. done.
+ Qed.
+ Lemma shr_ref_unfold_1_shared `{!Inhabited rt} κ κ' r :
+ ⊢ ltype_incl' (Shared κ') r r (ShrLtype (◠ty) κ) (◠(shr_ref ty κ)).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_shr_ref_unfold /shr_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & %Ha & % & #Hlb & %ri & Hrfn & #Hb)".
+ iExists ly. iFrame. iFrame "Hlb %". iExists _. iFrame.
+ iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & #Hs & Hb)".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & >? & >? & >Hsc & >Hlb' & %r' & >Hrfn & Hb)". iModIntro.
+ iExists _, _, _. iFrame. iSplitR; last done.
+ injection Ha as <-. done.
+ Qed.
+ Lemma shr_ref_unfold_1_uniq κ κ' γ r :
+ ⊢ ltype_incl' (Uniq κ' γ) r r (ShrLtype (◠ty) κ) (◠(shr_ref ty κ)).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_shr_ref_unfold /shr_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & ? & ? & ? & ? & Hb)". iExists ly. iFrame. iMod "Hb". iModIntro.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame.
+ iMod "Hb" as "(%l' & Hl & Hb)". iExists l'. iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & ? & ? & Hsc & Hlb & %ri & Hrfn & Hb)".
+ iExists l', ly', _. iFrame. done.
+ * iIntros "(%r' & Hauth & Hb)". iExists _; iFrame.
+ iMod "Hb" as "(%v & Hl & Hb)".
+ iDestruct "Hb" as "(%li & %ly' & %ri & -> & ? & ? & Hlb & Hsc & Hrfn & Hb)".
+ iExists _. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iFrame. iExists ly'. iFrame.
+ iExists _. by iFrame.
+ Qed.
+
+ Local Lemma shr_ref_unfold_1' `{!Inhabited rt} κ k r :
+ ⊢ ltype_incl' k r r (ShrLtype (◠ty) κ) (◠(shr_ref ty κ)).
+ Proof.
+ iModIntro. destruct k.
+ - iApply shr_ref_unfold_1_owned.
+ - iApply shr_ref_unfold_1_shared.
+ - iApply shr_ref_unfold_1_uniq.
+ Qed.
+ Lemma shr_ref_unfold_1 `{!Inhabited rt} κ k r :
+ ⊢ ltype_incl k r r (ShrLtype (◠ty) κ) (◠(shr_ref ty κ)).
+ Proof.
+ iSplitR; first done. iModIntro. iSplit.
+ - iApply shr_ref_unfold_1'.
+ - simp_ltypes. iApply shr_ref_unfold_1'.
+ Qed.
+
+ Lemma shr_ref_unfold_2_owned κ wl r :
+ ⊢ ltype_incl' (Owned wl) r r (◠(shr_ref ty κ)) (ShrLtype (◠ty) κ).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_shr_ref_unfold /shr_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & Hsc & Hlb & ? & %r' & Hrfn & Hb)".
+ iModIntro. iExists ly. iFrame. iExists _. iFrame.
+ iNext. iMod "Hb" as "(%v & Hl & %li & %ly' & %ri & -> & ? & ? & Hlb' & Hsc' & Hrfn' & Hb)".
+ iExists _. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly'. iFrame.
+ iExists _. by iFrame.
+ Qed.
+ Lemma shr_ref_unfold_2_shared κ κ' r :
+ ⊢ ltype_incl' (Shared κ') r r (◠(shr_ref ty κ)) (ShrLtype (◠ty) κ).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_shr_ref_unfold /shr_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ iIntros "(%ly & ? & ? & Hsc & Hlb & %r' & Hrfn & #Hb)". iExists ly. iFrame.
+ iExists r'. iFrame. iModIntro. iMod "Hb".
+ iDestruct "Hb" as "(%li & %ly' & %ri & ? & ? & ? & Hlb' & Hsc & Hrfn & Hs & Hb)".
+ iModIntro. iExists _. iFrame. iNext. iDestruct "Hb" as "#Hb".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly'. iFrame.
+ iExists _. iFrame. done.
+ Qed.
+ Lemma shr_ref_unfold_2_uniq κ κ' γ r :
+ ⊢ ltype_incl' (Uniq κ' γ) r r (◠(shr_ref ty κ)) (ShrLtype (◠ty) κ).
+ Proof.
+ iModIntro. iIntros (Ï€ l). rewrite ltype_own_shr_ref_unfold /shr_ltype_own ltype_own_ofty_unfold /lty_of_ty_own.
+ (* same proof as above essentially *)
+ iIntros "(%ly & ? & ? & Hsc & ? & ? & ? & ? & Hb)". iExists ly. iFrame. iMod "Hb". iModIntro.
+ iApply (pinned_bor_iff' with "[] Hb").
+ iNext. iModIntro. iSplit.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame.
+ iMod "Hb" as "(%v & Hl & Hb)".
+ iDestruct "Hb" as "(%li & %ly' & %ri & -> & ? & ? & Hlb & Hsc & Hrfn & Hb)".
+ iExists _. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly'. iFrame.
+ iExists _. by iFrame.
+ * iIntros "(%r' & Hauth & Hb)". iExists _. iFrame.
+ iMod "Hb" as "(%l' & Hl & Hb)".
+ iExists l'. iFrame. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hb" as "(%ly' & ? & ? & Hsc & Hlb & %ri & Hrfn & Hb)".
+ iExists l', _, _. iFrame. done.
+ Qed.
+
+
+ Local Lemma shr_ref_unfold_2' κ k r :
+ ⊢ ltype_incl' k r r (◠(shr_ref ty κ)) (ShrLtype (◠ty) κ).
+ Proof.
+ destruct k.
+ - iApply shr_ref_unfold_2_owned.
+ - iApply shr_ref_unfold_2_shared.
+ - iApply shr_ref_unfold_2_uniq.
+ Qed.
+ Lemma shr_ref_unfold_2 κ k r :
+ ⊢ ltype_incl k r r (◠(shr_ref ty κ)) (ShrLtype (◠ty) κ).
+ Proof.
+ iSplitR; first done. iModIntro; iSplit.
+ - iApply shr_ref_unfold_2'.
+ - simp_ltypes. iApply shr_ref_unfold_2'.
+ Qed.
+
+ Lemma shr_ref_unfold `{!Inhabited rt} κ k r :
+ ⊢ ltype_eq k r r (ShrLtype (◠(ty)) κ) (◠(shr_ref ty κ)).
+ Proof.
+ iSplit.
+ - iApply shr_ref_unfold_1.
+ - iApply shr_ref_unfold_2.
+ Qed.
+
+ Lemma shr_ref_unfold_full_eqltype `{!Inhabited rt} E L κ (lt : ltype rt) :
+ full_eqltype E L lt (◠ty)%I →
+ full_eqltype E L (ShrLtype lt κ) (◠(shr_ref ty κ))%I.
+ Proof.
+ iIntros (Heql ?) "HL #CTX #HE". iIntros (??).
+ iPoseProof (Heql with "HL CTX HE") as "#Heql".
+ iApply ltype_eq_trans; last iApply shr_ref_unfold.
+ iApply shr_ltype_eq; [ | iApply lft_incl_refl.. ].
+ by iApply "Heql".
+ Qed.
+End ltype_agree.
+
+Global Typeclasses Opaque shr_ref.
+Notation "&shr< κ , τ >" := (shr_ref τ κ) (only printing, format "'&shr<' κ , τ '>'") : stdpp_scope.
+
+Section acc.
+ Context `{!typeGS Σ}.
+
+ Lemma shr_ltype_place_cond_ty b κ {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) :
+ typed_place_cond_ty b lt1 lt2 -∗
+ typed_place_cond_ty b (ShrLtype lt1 κ) (ShrLtype lt2 κ).
+ Proof.
+ destruct b; simpl.
+ - iIntros "_". done.
+ - iIntros "(%Heq & Heq & Hub)". subst rt2.
+ cbn. iExists eq_refl. cbn. iSplitR "Hub".
+ + iIntros (??). iApply (shr_ltype_eq with "Heq"); iApply lft_incl_refl.
+ + by iApply shr_ltype_imp_unblockable.
+ - iIntros "(%Hrefl & Heq & Hub)".
+ subst rt2. cbn.
+ iExists eq_refl. cbn. iSplitR "Hub".
+ + simp_ltypes. iIntros (??). iApply (shr_ltype_eq with "Heq"); iApply lft_incl_refl.
+ + by iApply shr_ltype_imp_unblockable.
+ Qed.
+
+ Lemma shr_ltype_acc_owned {rt} F π (lt : ltype rt) (r : place_rfn rt) l κ' wl :
+ lftE ⊆ F →
+ rrust_ctx -∗
+ l â—â‚—[Ï€, Owned wl] PlaceIn (r) @ ShrLtype lt κ' -∗
+ ⌜l `has_layout_loc` void*⌠∗ loc_in_bounds l 0 (ly_size void*) ∗ |={F}=>
+ ∃ (l' : loc), l ↦ l' ∗ l' â—â‚—[Ï€, Shared κ'] r @ lt ∗
+ logical_step F
+ (∀ bmin rt' (lt2 : ltype rt') r2,
+ l ↦ l' -∗
+ l' â—â‚—[Ï€, Shared κ'] r2 @ lt2 ={F}=∗
+ l â—â‚—[Ï€, Owned wl] PlaceIn (r2) @ ShrLtype lt2 κ' ∗
+ (typed_place_cond bmin lt lt2 r r2 -∗
+ ⌜place_access_rt_rel bmin rt rt'⌠-∗
+ typed_place_cond bmin (ShrLtype lt κ') (ShrLtype lt2 κ') (PlaceIn (r)) (PlaceIn (r2)))).
+ Proof.
+ iIntros (?) "#[LFT TIME] HP".
+ rewrite ltype_own_shr_ref_unfold /shr_ltype_own.
+ iDestruct "HP" as "(%ly & %Halg & %Hly & #Hlb & Hcred & %r' & %Heq & Hb)".
+ injection Halg as <-. subst.
+ iFrame "Hlb %".
+ iMod (maybe_use_credit with "Hcred Hb") as "(Hcred & Hat & Hb)"; first done.
+ iDestruct "Hb" as "(%l' & Hl & Hb)".
+ iModIntro. iExists l'. iFrame.
+ iApply (logical_step_intro_maybe with "Hat").
+ iIntros "Hcred' !>". iIntros (bmin rt2 lt2 r2) "Hl Hb".
+ iModIntro. iSplitL.
+ - rewrite ltype_own_shr_ref_unfold /shr_ltype_own. iExists void*.
+ iSplitR; first done. iFrame "Hlb % ∗".
+ iExists _. iSplitR; first done. iNext. eauto with iFrame.
+ - iIntros "Hcond %Hrt". iDestruct "Hcond" as "[Hty Hrfn]".
+ subst. iSplit.
+ + by iApply (shr_ltype_place_cond_ty).
+ + destruct bmin; cbn in Hrt; [ done | subst rt2..].
+ all: by iApply (typed_place_cond_rfn_lift _ _ _ (λ r, PlaceIn (r))).
+ Qed.
+End acc.
+
+
+Section rules.
+ Context `{!typeGS Σ}.
+
+ Global Instance get_lft_names_shr_ref {rt} (ty : type rt) κ lfts lfts' name tree :
+ GetLftNames ty lfts tree lfts' →
+ GetLftNames (shr_ref ty κ) lfts (LftNameTreeRef name tree) (named_lft_update name κ lfts') := λ _, GLN.
+
+ Lemma typed_place_shr_owned {rto} π κ (lt2 : ltype rto) P E L l r wl bmin0 (T : place_cont_t (place_rfn rto)) :
+ (∀ l', typed_place π E L l' lt2 r (Shared κ ⊓ₖ bmin0) (Shared κ) P
+ (λ L' κs l2 b2 bmin rti tyli ri strong weak,
+ T L' (κs) l2 b2 bmin rti tyli ri
+ (option_map (λ strong, mk_strong
+ (λ rti2, (place_rfn (strong.(strong_rt) rti2)))%type
+ (λ rti2 lti2 ri2, ShrLtype (strong.(strong_lt) _ lti2 ri2) κ)
+ (λ rti2 (r : place_rfn rti2), PlaceIn (strong.(strong_rfn) _ r))
+ strong.(strong_R)) strong)
+ (fmap (λ weak, mk_weak
+ (λ lti2 ri2, ShrLtype (weak.(weak_lt) lti2 ri2) κ)
+ (λ (r : place_rfn rti), PlaceIn (weak.(weak_rfn) r))
+ weak.(weak_R)) weak)))
+ ⊢ typed_place π E L l (ShrLtype lt2 κ) (#r) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) T.
+ Proof.
+ iIntros "HR" (Φ F ??).
+ iIntros "#(LFT & TIME & LLCTX) #HE HL Hincl0 HP HΦ/=".
+ iPoseProof (shr_ltype_acc_owned F with "[$LFT $TIME $LLCTX] HP") as "(%Hly & Hlb & Hb)"; [done.. | ].
+ iApply fupd_wp. iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iMod "Hb" as "(%l' & Hl & Hb & Hcl)". iMod "HclF" as "_". iModIntro.
+ iApply (wp_logical_step with "TIME Hcl"); [solve_ndisj.. | ].
+ iApply (wp_deref with "Hl") => //; [solve_ndisj | by apply val_to_of_loc | ].
+ iNext. iIntros (st) "Hl Hcred Hc". iMod (fupd_mask_subseteq F) as "HclF"; first done.
+ iMod "HclF" as "_". iExists l'.
+ iSplitR. { iPureIntro. unfold mem_cast. rewrite val_to_of_loc. done. }
+ iApply ("HR" with "[//] [//] [$LFT $TIME $LLCTX] HE HL [] Hb"). { iApply bor_kind_min_incl_l. }
+ iModIntro. iIntros (L' κs l2 b2 bmin rti tyli ri strong weak) "#Hincl1 Hb Hs".
+ iApply ("HΦ" $! _ _ _ _ bmin _ _ _ _ _ with "Hincl1 Hb").
+ simpl. iSplit.
+ - (* strong *) iDestruct "Hs" as "[Hs _]".
+ destruct strong as [ strong | ]; last done.
+ iIntros (rti2 ltyi2 ri2) "Hl2 Hcond".
+ iMod ("Hs" with "Hl2 Hcond") as "(Hb & Hcond & HR)".
+ iMod ("Hc" $! (Owned false) with "Hl Hb") as "(Hb & _)".
+ iFrame. iPureIntro. simp_ltypes. done.
+ - (* weak *)
+ destruct weak as [ weak | ]; last done.
+ iDestruct "Hs" as "[_ Hs]".
+ iIntros (ltyi2 ri2 bmin').
+ iIntros "Hincl2 Hl2 Hcond".
+ iMod ("Hs" with "Hincl2 Hl2 Hcond") as "(Hb & Hcond & $ & HR)".
+ iMod ("Hc" with "Hl Hb") as "(Hb & Hcond')".
+ iPoseProof ("Hcond'" with "Hcond") as "Hcond".
+ iModIntro. iFrame "HR Hb".
+ iApply typed_place_cond_incl; last iApply "Hcond".
+ + iApply bor_kind_min_incl_r.
+ + iPureIntro. apply place_access_rt_rel_refl.
+ Qed.
+ Global Instance typed_place_shr_owned_inst {rto} E L π κ (lt2 : ltype rto) bmin0 r l wl P :
+ TypedPlace E L π l (ShrLtype lt2 κ) (PlaceIn (r)) bmin0 (Owned wl) (DerefPCtx Na1Ord PtrOp true :: P) | 30 := λ T, i2p (typed_place_shr_owned π κ lt2 P E L l r wl bmin0 T).
+
+
+ (* TODO more place instances *)
+
+ Lemma typed_place_ofty_shr {rt} `{Inhabited rt} π E L l (ty : type rt) κ (r : place_rfn (place_rfn rt)) bmin0 b P T :
+ typed_place π E L l (ShrLtype (◠ty) κ) r bmin0 b P T
+ ⊢ typed_place π E L l (◠(shr_ref ty κ)) r bmin0 b P T.
+ Proof.
+ iIntros "Hp". iApply typed_place_eqltype; last done.
+ iIntros (?) "HL CTX HE".
+ iIntros (??). iApply ltype_eq_sym. iApply shr_ref_unfold.
+ Qed.
+ Global Instance typed_place_ofty_shr_inst {rt} `{Inhabited rt} π E L l (ty : type rt) κ (r : place_rfn (place_rfn rt)) bmin0 b P :
+ TypedPlace E L π l (◠(shr_ref ty κ))%I r bmin0 b P | 30 := λ T, i2p (typed_place_ofty_shr π E L l ty κ r bmin0 b P T).
+
+ Lemma stratify_ltype_shr_owned {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) wl
+ (T : stratify_ltype_cont_t) :
+ (∀ l', stratify_ltype π E L mu mdu ma ml l' lt r (Shared κ) (λ L' R rt' lt' r',
+ match ma with
+ | StratRefoldFull =>
+ ∃ (_ : Inhabited rt'), cast_ltype_to_type E L' lt' (λ ty', T L' R _ (◠(shr_ref ty' κ))%I (#r'))
+ | _ => T L' R _ (ShrLtype lt' κ) (#r')
+ end))
+ ⊢ stratify_ltype π E L mu mdu ma ml l (ShrLtype lt κ) (#r) (Owned wl) T.
+ Proof.
+ iIntros "Hs". iIntros (?? ?) "#(LFT & TIME & LLCTX) #HE HL Hb".
+ iPoseProof (shr_ltype_acc_owned F with "[$LFT $TIME $LLCTX] Hb") as "Hb"; [done.. | ].
+ iDestruct "Hb" as "(%Hly & #Hlb & >(%l' & Hl & Hb & Hcl))".
+ iPoseProof ("Hs" with "[//] [//] [$LFT $TIME $LLCTX] HE HL Hb") as "Hb".
+ iMod "Hb" as "(%L' & %R & %rt' & %lt' & %r' & HL & %Hcond & Hstep & Hc)".
+ destruct (decide (ma = StratRefoldFull)) as [Heq | ].
+ - subst ma.
+ iDestruct "Hc" as "(% & %ty' & %Heq & HT)".
+ iPoseProof (eqltype_use F with "[$LFT $TIME $LLCTX] HE HL") as "(Hvs & HL)"; [done | .. ].
+ { apply full_eqltype_alt. apply Heq. }
+ (*iPoseProof (eqltype_acc with "[$LFT $TIME $LLCTX] HE HL") as "#Heq"; first done.*)
+ iModIntro. iExists L', R, _, _, _. iFrame.
+ iSplitR. { simp_ltypes. done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro. iIntros "(Hb & $) Hcl".
+ iMod ("Hvs" with "Hb") as "Hb".
+ iMod ("Hcl" $! (Shared κ) with "Hl Hb") as "(Hb & _)".
+ iDestruct (shr_ref_unfold_1 ty' κ (Owned wl)) as "(_ & #Hi & _)".
+ iMod (fupd_mask_mono with "(Hi Hb)") as "$"; first done.
+ done.
+ - iAssert (T L' R _ (ShrLtype lt' κ) (#r')) with "[Hc]" as "Hc".
+ { destruct ma; done. }
+ iModIntro. iExists L', R, _, _, _. iFrame.
+ iSplitR. { simp_ltypes; done. }
+ iApply logical_step_fupd.
+ iApply (logical_step_compose with "Hcl").
+ iApply (logical_step_compose with "Hstep").
+ iApply logical_step_intro. iIntros "(Hb & $) Hcl".
+ by iMod ("Hcl" $! (Shared κ) with "Hl Hb") as "($ & _)".
+ Qed.
+ Global Instance stratify_ltype_shr_owned_none_inst {rt} π E L mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : (place_rfn rt)) wl :
+ StratifyLtype π E L StratMutNone mdu ma ml l (ShrLtype lt κ) (#r) (Owned wl) := λ T, i2p (stratify_ltype_shr_owned π E L StratMutNone mdu ma ml l lt κ r wl T).
+
+ (* TODO Uniq *)
+
+ (* Notes on stratification of [Shared]:
+ basically:
+ when we are accessing, we are unfolding
+
+ - in principle, this should "just work" by operating under these laters.
+ Below shared references, the amount of unfolding we could have done is very limited: basically, we can only have
+ ShrBlocked or Shadowed.
+ For Shadowed: should easily be able to take it back.
+ For ShrBlocked: this might be more of a problem.
+ We actually need to execute the viewshift for the inheritance, right.
+ However, do we ever have nested shrblocked (ie below Shared) in practice?
+ => No. I cannot initialize a shrblocked from that, because I cannot initialize sharing.
+ Rather, creating a shr reference from a shared place should copy the existing sharing.
+
+ Then: I basically just want to be able to execute this stratification below the later.
+ Issue with using this stratify: the lifetime context stuff.
+ But in principle, shared stratification should also not use the lifetime context stuff.
+
+ Maybe have a separate notion of shared stratification to account for that?
+ That basically should just take the thing unter an iterated step_fupdN and also only need to provide the stratified thing under a step_fupdN.
+
+ Eventually: what happens if we do interior mutability?
+ then we will actually open an invariant and get some tokens for stuff back.
+ Though we might just want to have that for primitive ofty things, not nested
+
+ In the shared case, can we just set this up differently altogether?
+ Maybe just require subtyping of core?
+ Can Shared stuff always go directly to the core?
+ => Yes, I think so, for now.
+ Alternative: directly go to the core.
+ i.e. would have to prove that for Shared we can always go to the core.
+ For more advanced sharing patterns where we actually want to have shrblocked, this might not work though. but that is anyways far in the future now.
+ This is anyways slightly incompatible with the current model/needs work.
+
+ Options now:
+ - have stratify_ltype version for Shared that operates below the laters. Basically, this would just be a fancy version of subtyping though.
+ - use subtyping, by proving that it is a subtype of the core, and then folding that.
+ - use the core, but have proved it once and for all.
+
+ - maybe we also want to have the depth certificates here? *)
+ (* This is loosing information by dropping potential [ShadowedLtype], so we should only do it when really necessary. *)
+ Lemma stratify_ltype_shared {rt} π E L mu mdu ma {M} (ml : M) l (lt : ltype rt) κ (r : place_rfn rt) (T : stratify_ltype_cont_t):
+ (cast_ltype_to_type E L (ltype_core lt) (λ ty', T L True _ (◠ty')%I (r)))
+ ⊢ stratify_ltype π E L mu mdu ma ml l lt r (Shared κ) T.
+ Proof.
+ iIntros "HT". iIntros (???) "#CTX #HE HL Hl".
+ iDestruct "HT" as "(%ty & %Heq & HT)".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Heq"; first apply Heq.
+ iPoseProof (ltype_own_shared_to_core with "Hl") as "Hl".
+ iDestruct ("Heq" $! (Shared κ) r) as "((%Hsteq & #Hinc & _) & _)".
+ iPoseProof ("Hinc" with "Hl") as "Hl".
+ iExists L, _, _, _, _. iFrame.
+ iModIntro. iSplitR. { simp_ltypes. done. }
+ iApply logical_step_intro. iSplitL; done.
+ Qed.
+ Global Instance stratify_ltype_shared_inst1 {rt} π E L mu mdu {M} (ml : M) l (lt : ltype rt) κ (r : place_rfn rt) :
+ StratifyLtype π E L mu mdu StratRefoldFull ml l lt r (Shared κ) :=
+ λ T, i2p (stratify_ltype_shared π E L mu mdu StratRefoldFull ml l lt κ r T).
+ Global Instance stratify_ltype_shared_inst2 {rt} π E L mu mdu {M} (ml : M) l (lt : ltype rt) κ (r : place_rfn rt) :
+ StratifyLtype π E L mu mdu StratRefoldOpened ml l lt r (Shared κ) :=
+ λ T, i2p (stratify_ltype_shared π E L mu mdu StratRefoldOpened ml l lt κ r T).
+
+ Lemma stratify_ltype_ofty_shr {rt} `{Inhabited rt} π E L mu ma {M} (ml : M) l (ty : type rt) κ (r : place_rfn (place_rfn rt)) b T :
+ stratify_ltype π E L mu StratDoUnfold ma ml l (ShrLtype (◠ty) κ) r b T
+ ⊢ stratify_ltype π E L mu StratDoUnfold ma ml l (◠(shr_ref ty κ)) r b T.
+ Proof.
+ iIntros "Hp". iApply stratify_ltype_eqltype; iFrame.
+ iPureIntro. iIntros (?) "HL CTX HE".
+ iApply ltype_eq_sym. iApply shr_ref_unfold.
+ Qed.
+ Global Instance stratify_ltype_ofty_shr_inst {rt} `{Inhabited rt} π E L mu ma {M} (ml : M) l (ty : type rt) κ (r : place_rfn (place_rfn rt)) b :
+ StratifyLtype π E L mu StratDoUnfold ma ml l (◠(shr_ref ty κ))%I r b | 30 := λ T, i2p (stratify_ltype_ofty_shr π E L mu ma ml l ty κ r b T).
+ (** prove_place_cond instances *)
+ (* These need to have a lower priority than the ofty_refl instance (level 2) and the unblocking instances (level 5), but higher than the trivial "no" instance *)
+ Lemma prove_place_cond_unfold_shr_l E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k T :
+ prove_place_cond E L k (ShrLtype (◠ty) κ) lt T
+ ⊢ prove_place_cond E L k (◠(shr_ref ty κ)) lt T.
+ Proof.
+ iApply prove_place_cond_eqltype_l. apply symmetry. apply shr_ref_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_shr_l_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k :
+ ProvePlaceCond E L k (◠(shr_ref ty κ))%I lt | 10 := λ T, i2p (prove_place_cond_unfold_shr_l E L ty lt κ k T).
+ Lemma prove_place_cond_unfold_shr_r E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k T :
+ prove_place_cond E L k lt (ShrLtype (◠ty) κ) T
+ ⊢ prove_place_cond E L k lt (◠(shr_ref ty κ)) T.
+ Proof.
+ iApply prove_place_cond_eqltype_r. apply symmetry. apply shr_ref_unfold_full_eqltype; done.
+ Qed.
+ Global Instance prove_place_cond_unfold_shr_r_inst E L {rt1 rt2} `{Inhabited rt1} (ty : type rt1) (lt : ltype rt2) κ k :
+ ProvePlaceCond E L k lt (◠(shr_ref ty κ))%I | 10 := λ T, i2p (prove_place_cond_unfold_shr_r E L ty lt κ k T).
+
+ Lemma prove_place_cond_ShrLtype E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ k T :
+ prove_place_cond E L (Shared κ ⊓ₖ k) lt1 lt2 (λ upd, T $ access_result_lift place_rfn upd)
+ ⊢ prove_place_cond E L k (ShrLtype lt1 κ) (ShrLtype lt2 κ) T.
+ Proof.
+ (* TODO *)
+ Abort.
+
+ (** Typing rule for shared borrowing, manually applied by the tactics *)
+ Lemma type_shr_bor E L T e π κ_name ty_annot :
+ (∃ M, named_lfts M ∗ li_tactic (compute_map_lookup_nofail_goal M κ_name) (λ κ,
+ (named_lfts M -∗ typed_borrow_shr π E L e κ ty_annot (λ L' v rt ty r, T L' v (place_rfn rt) (shr_ref ty κ) (PlaceIn r)))))
+ ⊢ typed_val_expr π E L (&ref{Shr, ty_annot, κ_name} e) T.
+ Proof.
+ rewrite /compute_map_lookup_nofail_goal.
+ iIntros "(%M & Hnamed & %κ & _ & HT)". iIntros (Φ) "#(LFT & TIME & LLCTX) #HE HL HΦ".
+ wp_bind. iSpecialize ("HT" with "Hnamed"). iApply ("HT" $! _ ⊤ with "[//] [//] [//] [$LFT $TIME $LLCTX] HE HL").
+ iIntros (l) "HT".
+ unfold Ref. wp_bind. iApply ewp_fupd.
+ iApply (wp_logical_step with "TIME HT"); [solve_ndisj.. | ].
+ iApply wp_skip. iNext. iIntros "Hcred HT !> !>".
+ iApply (wp_logical_step with "TIME HT"); [solve_ndisj.. | ].
+ iApply wp_skip. iNext. iIntros "Hcred' HT".
+ iMod ("HT" with "Hcred'") as (L' rt ty r ly) "(#Hshr & %Halg & %Hly & #Hlb & #Hsc & HL & HT)".
+ iModIntro. iApply ("HΦ" with "HL [Hshr] HT").
+ iExists l, ly, r. iSplitR; first done. iFrame "Hlb Hsc %".
+ iSplitR; first done. iModIntro. iModIntro. done.
+ Qed.
+
+ (** cast_ltype *)
+ Lemma cast_ltype_to_type_shr E L {rt} `{Inhabited rt} (lt : ltype rt) κ T :
+ cast_ltype_to_type E L lt (λ ty, T (shr_ref ty κ))
+ ⊢ cast_ltype_to_type E L (ShrLtype lt κ) T.
+ Proof.
+ iIntros "Hs". iDestruct "Hs" as "(%ty & %Heq & HT)".
+ iExists (shr_ref ty κ). iFrame "HT". iPureIntro.
+ by apply shr_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance cast_ltype_to_type_shr_inst E L {rt} `{Inhabited rt} (lt : ltype rt) κ :
+ CastLtypeToType E L (ShrLtype lt κ) :=
+ λ T, i2p (cast_ltype_to_type_shr E L lt κ T).
+
+ (** subtyping *)
+ Lemma weak_subtype_shr_in E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) κ1 κ2 r1 r2 T :
+ (⌜lctx_lft_incl E L κ2 κ1⌠∗ weak_subtype E L r1 r2 ty1 ty2 T)
+ ⊢ weak_subtype E L #r1 #r2 (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof.
+ iIntros "(%Hincl & HT)". iIntros (??) "#CTX #HE HL".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE").
+ iMod ("HT" with "[//] CTX HE HL") as "(#Hsub & $ & $)".
+ iApply shr_ref_type_incl_in; done.
+ Qed.
+ Global Instance weak_subtype_shr_in_inst E L {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) κ1 κ2 r1 r2 :
+ Subtype E L #r1 #r2 (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 10:= λ T, i2p (weak_subtype_shr_in E L ty1 ty2 κ1 κ2 r1 r2 T).
+
+ Lemma weak_subtype_shr E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 r1 r2 T :
+ (⌜r1 = r2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_subtype E L ty1 ty2 T)
+ ⊢ weak_subtype E L r1 r2 (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof.
+ iIntros "(-> & %Hincl & %Hsubt & HT)". iIntros (??) "#CTX #HE HL".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE").
+ iPoseProof (full_subtype_acc with "HE HL") as "#Hsub"; first done.
+ iFrame. unshelve iApply shr_ref_type_incl; done.
+ Qed.
+ Global Instance weak_subtype_shr_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 r1 r2 :
+ Subtype E L r1 r2 (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 11 := λ T, i2p (weak_subtype_shr E L ty1 ty2 κ1 κ2 r1 r2 T).
+
+ Lemma weak_subtype_shr_evar_lft E L {rt} (ty1 ty2 : type rt) κ1 κ2 r1 r2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ weak_subtype E L r1 r2 (shr_ref ty1 κ1) (shr_ref ty2 κ1) T
+ ⊢ weak_subtype E L r1 r2 (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subtype_shr_evar_lft_inst E L {rt} (ty1 ty2 : type rt) κ1 κ2 r1 r2 `{!IsProtected κ2} :
+ Subtype E L r1 r2 (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 9 := λ T, i2p (weak_subtype_shr_evar_lft E L ty1 ty2 κ1 κ2 r1 r2 T).
+
+ Lemma mut_subtype_shr E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_subtype E L ty1 ty2 T
+ ⊢ mut_subtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof.
+ iIntros "(%Hincl & %Hsub & $)". iPureIntro. by eapply shr_ref_full_subtype.
+ Qed.
+ Global Instance mut_subtype_shr_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 :
+ MutSubtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 10 := λ T, i2p (mut_subtype_shr E L ty1 ty2 κ1 κ2 T).
+ Lemma mut_subtype_shr_evar_lft E L {rt} (ty1 ty2 : type rt) κ1 κ2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ mut_subtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ1) T
+ ⊢ mut_subtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_subtype_shr_evar_lft_inst E L {rt} (ty1 ty2 : type rt) κ1 κ2 `{!IsProtected κ2} :
+ MutSubtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 9:= λ T, i2p (mut_subtype_shr_evar_lft E L ty1 ty2 κ1 κ2 T).
+
+ Lemma mut_eqtype_shr E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ2 κ1⌠∗ ⌜lctx_lft_incl E L κ1 κ2⌠∗ mut_eqtype E L ty1 ty2 T
+ ⊢ mut_eqtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof.
+ iIntros "(%Hincl & %Hsub & %Hsub2 & $)". iPureIntro. split.
+ - eapply shr_ref_full_subtype; first done. by eapply full_eqtype_subtype_l.
+ - eapply shr_ref_full_subtype; first done. by eapply full_eqtype_subtype_r.
+ Qed.
+ Global Instance mut_eqtype_shr_inst E L {rt} `{!Inhabited rt} (ty1 ty2 : type rt) κ1 κ2 :
+ MutEqtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 10 := λ T, i2p (mut_eqtype_shr E L ty1 ty2 κ1 κ2 T).
+ Lemma mut_eqtype_shr_evar_lft E L {rt} (ty1 ty2 : type rt) κ1 κ2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ mut_eqtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ1) T
+ ⊢ mut_eqtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_eqtype_shr_evar_lft_inst E L {rt} (ty1 ty2 : type rt) κ1 κ2 `{!IsProtected κ2} :
+ MutEqtype E L (shr_ref ty1 κ1) (shr_ref ty2 κ2) | 9:= λ T, i2p (mut_eqtype_shr_evar_lft E L ty1 ty2 κ1 κ2 T).
+
+ (** subltyping *)
+ Lemma weak_subltype_shr_owned_in E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl κ1 κ2 r1 r2 T :
+ (∃ r2', ⌜r2 = #r2'⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ weak_subltype E L (Shared κ1) r1 r2' lt1 lt2 T)
+ ⊢ weak_subltype E L (Owned wl) #r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%r2' & -> & %Hincl & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl' & HL & $)".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE"). iFrame.
+ iApply (shr_ltype_incl_owned_in with "Hincl'").
+ done.
+ Qed.
+ Global Instance weak_subltype_shr_owned_in_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) wl κ1 κ2 r1 r2 :
+ SubLtype E L (Owned wl) #r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 10 := λ T, i2p (weak_subltype_shr_owned_in E L lt1 lt2 wl κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_shr_owned E L {rt} (lt1 : ltype rt) (lt2 : ltype rt) wl κ1 κ2 r1 r2 T :
+ (⌜r1 = r2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_subltype E L lt1 lt2 T)
+ ⊢ weak_subltype E L (Owned wl) r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(-> & %Hincl & %Hsubt & HT)" (??) "#CTX #HE HL".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hsub"; first apply Hsubt.
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE"). iFrame.
+ iApply (shr_ltype_incl_owned); last done.
+ iApply "Hsub".
+ Qed.
+ Global Instance weak_subltype_shr_owned_inst E L {rt} (lt1 : ltype rt) (lt2 : ltype rt) wl κ1 κ2 r1 r2 :
+ SubLtype E L (Owned wl) r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 11 := λ T, i2p (weak_subltype_shr_owned E L lt1 lt2 wl κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_shr_shared_in E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ κ1 κ2 r1 r2 T :
+ (∃ r2', ⌜r2 = #r2'⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ weak_subltype E L (Shared (κ1)) r1 r2' lt1 lt2 T)
+ ⊢ weak_subltype E L (Shared κ) #r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%r2' & -> & %Hincl & HT)" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl' & HL & $)".
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE"). iFrame.
+ iApply (shr_ltype_incl_shared_in with "[Hincl']"); last done.
+ done.
+ Qed.
+ Global Instance weak_subltype_shr_shared_in_inst E L {rt1 rt2} (lt1 : ltype rt1) (lt2 : ltype rt2) κ κ1 κ2 r1 r2 :
+ SubLtype E L (Shared κ) #r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 10 := λ T, i2p (weak_subltype_shr_shared_in E L lt1 lt2 κ κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_shr_shared E L {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ κ1 κ2 r1 r2 T :
+ (⌜r1 = r2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_subltype E L lt1 lt2 T)
+ ⊢ weak_subltype E L (Shared κ) r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(-> & %Hincl & %Hsubt & HT)" (??) "#CTX #HE HL".
+ iPoseProof (full_subltype_acc with "CTX HE HL") as "#Hsub"; first apply Hsubt.
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl"; first done.
+ iSpecialize ("Hincl" with "HE"). iFrame.
+ iApply (shr_ltype_incl_shared); last done.
+ iApply "Hsub".
+ Qed.
+ Global Instance weak_subltype_shr_shared_inst E L {rt} (lt1 : ltype rt) (lt2 : ltype rt) κ κ1 κ2 r1 r2 :
+ SubLtype E L (Shared κ) r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 11 := λ T, i2p (weak_subltype_shr_shared E L lt1 lt2 κ κ1 κ2 r1 r2 T).
+
+ (* Base instance that will trigger, e.g., for Uniq or PlaceGhost refinements *)
+ Lemma weak_subltype_shr_base E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 T :
+ ⌜r1 = r2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ ⌜lctx_lft_incl E L κ1 κ2⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(<- & %Hincl1 & %Hincl2 & %Hsubt & T)" (??) "#CTX #HE HL".
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hincl"; first done.
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl1"; first apply Hincl1.
+ iSpecialize ("Hincl1" with "HE").
+ iPoseProof (lctx_lft_incl_incl with "HL") as "#Hincl2"; first apply Hincl2.
+ iSpecialize ("Hincl2" with "HE").
+ iFrame. iApply shr_ltype_incl; done.
+ Qed.
+ Global Instance weak_subltype_shr_base_inst E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 :
+ SubLtype E L k r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 20 := λ T, i2p (weak_subltype_shr_base E L lt1 lt2 k κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_shr_evar_lft E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ1) T
+ ⊢ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance weak_subltype_shr_evar_lft_inst E L {rt} (lt1 lt2 : ltype rt) k κ1 κ2 r1 r2 `{!IsProtected κ2} :
+ SubLtype E L k r1 r2 (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 9 := λ T, i2p (weak_subltype_shr_evar_lft E L lt1 lt2 k κ1 κ2 r1 r2 T).
+
+ Lemma mut_subltype_shr E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ1 κ2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ mut_subltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Hsub1 & %Hsub2 & %Heq & $)".
+ iPureIntro. by eapply shr_full_subltype.
+ Qed.
+ Global Instance mut_subltype_shr_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ MutSubLtype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 10 := λ T, i2p (mut_subltype_shr E L lt1 lt2 κ1 κ2 T).
+
+ Lemma mut_subltype_shr_evar_lft E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ mut_subltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ1) T
+ ⊢ mut_subltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_subltype_shr_evar_lft_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 `{!IsProtected κ2} :
+ MutSubLtype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 9 := λ T, i2p (mut_subltype_shr_evar_lft E L lt1 lt2 κ1 κ2 T).
+
+ Lemma mut_eqltype_shr E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T :
+ ⌜lctx_lft_incl E L κ1 κ2⌠∗ ⌜lctx_lft_incl E L κ2 κ1⌠∗ mut_eqltype E L lt1 lt2 T
+ ⊢ mut_eqltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Heq1 & %Heq2 & %Heq & $)".
+ iPureIntro. by eapply shr_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_shr_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 :
+ MutEqLtype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) | 10 := λ T, i2p (mut_eqltype_shr E L lt1 lt2 κ1 κ2 T).
+
+ Lemma mut_eqltype_shr_evar_lft E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 T `{!IsProtected κ2} :
+ ⌜κ1 = κ2⌠∗ mut_eqltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ1) T
+ ⊢ mut_eqltype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) T.
+ Proof. iIntros "(<- & $)". Qed.
+ Global Instance mut_eqltype_shr_evar_lft_inst E L {rt} (lt1 lt2 : ltype rt) κ1 κ2 `{!IsProtected κ2} :
+ MutEqLtype E L (ShrLtype lt1 κ1) (ShrLtype lt2 κ2) := λ T, i2p (mut_eqltype_shr_evar_lft E L lt1 lt2 κ1 κ2 T).
+
+ (* Ofty unfolding if necessary *)
+ Lemma weak_subltype_shr_ofty_1_evar E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type (place_rfn rt2)) k κ1 r1 r2 T :
+ (∃ ty2', ⌜ty2 = shr_ref ty2' κ1⌠∗ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (◠(shr_ref ty2' κ1)) T)
+ ⊢ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)". done.
+ Qed.
+ Global Instance weak_subltype_shr_ofty_1_evar_inst E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type (place_rfn rt2)) k κ1 r1 r2 `{!IsProtected ty2} :
+ SubLtype E L k r1 r2 (ShrLtype lt1 κ1) (◠ty2)%I | 10 := λ T, i2p (weak_subltype_shr_ofty_1_evar E L lt1 ty2 k κ1 r1 r2 T).
+
+ Lemma weak_subltype_shr_ofty_1 E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype rt1) (ty2 : type (rt2)) k κ1 κ2 r1 r2 T :
+ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (ShrLtype (◠ty2) κ2) T
+ ⊢ weak_subltype E L k r1 r2 (ShrLtype lt1 κ1) (◠(shr_ref ty2 κ2)) T.
+ Proof.
+ iIntros "HT". iIntros (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "Hincl").
+ iApply shr_ref_unfold_1.
+ Qed.
+ Global Instance weak_subltype_shr_ofty_1_inst E L {rt1 rt2} `{!Inhabited rt2} (lt1 : ltype (rt1)) (ty2 : type rt2) k r1 r2 κ1 κ2 :
+ SubLtype E L k r1 r2 (ShrLtype lt1 κ1) (◠(shr_ref ty2 κ2))%I | 12 := λ T, i2p (weak_subltype_shr_ofty_1 E L lt1 ty2 k κ1 κ2 r1 r2 T).
+
+ Lemma weak_subltype_shr_ofty_2 E L {rt1 rt2} `{!Inhabited rt2} (ty1 : type (rt1)) (lt2 : ltype rt2) k r1 r2 κ1 κ2 T :
+ (weak_subltype E L k r1 r2 (ShrLtype (◠ty1) κ1) (ShrLtype lt2 κ2) T)
+ ⊢ weak_subltype E L k r1 r2 (◠(shr_ref ty1 κ1)) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "HT" (??) "#CTX #HE HL".
+ iMod ("HT" with "[//] CTX HE HL") as "(Hincl & $ & $)".
+ iApply (ltype_incl_trans with "[] Hincl").
+ iApply shr_ref_unfold_2.
+ Qed.
+ Global Instance weak_subltype_shr_ofty_2_inst E L {rt1 rt2} `{!Inhabited rt2} (ty1 : type (rt1)) (lt2 : ltype rt2) k r1 r2 κ1 κ2 :
+ SubLtype E L k r1 r2 (◠(shr_ref ty1 κ1))%I (ShrLtype lt2 κ2) | 10 := λ T, i2p (weak_subltype_shr_ofty_2 E L ty1 lt2 k r1 r2 κ1 κ2 T).
+
+ (* same for [mut_subltype] *)
+ Lemma mut_subltype_shr_ofty_1_evar E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) κ1 T :
+ (∃ ty2', ⌜ty2 = shr_ref ty2' κ1⌠∗ mut_subltype E L (ShrLtype lt1 κ1) (◠(shr_ref ty2' κ1)) T)
+ ⊢ mut_subltype E L (ShrLtype lt1 κ1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)". done.
+ Qed.
+ Global Instance mut_subltype_shr_ofty_1_evar_inst E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) κ1 `{!IsProtected ty2} :
+ MutSubLtype E L (ShrLtype lt1 κ1) (◠ty2)%I | 10 := λ T, i2p (mut_subltype_shr_ofty_1_evar E L lt1 ty2 κ1 T).
+
+ Lemma mut_subltype_shr_ofty_1 E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (rt)) κ1 κ2 T :
+ mut_subltype E L (ShrLtype lt1 κ1) (ShrLtype (◠ty2) κ2) T
+ ⊢ mut_subltype E L (ShrLtype lt1 κ1) (◠(shr_ref ty2 κ2)) T.
+ Proof.
+ iIntros "(%Hsub & $)". iPureIntro.
+ etrans; first done. eapply full_eqltype_subltype_l. by eapply shr_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_shr_ofty_1_inst E L {rt} `{!Inhabited rt} (lt1 : ltype (rt)) (ty2 : type rt) κ1 κ2 :
+ MutSubLtype E L (ShrLtype lt1 κ1) (◠(shr_ref ty2 κ2))%I | 12 := λ T, i2p (mut_subltype_shr_ofty_1 E L lt1 ty2 κ1 κ2 T).
+
+ Lemma mut_subltype_shr_ofty_2 E L {rt} `{!Inhabited rt} (ty1 : type rt) (lt2 : ltype rt) κ1 κ2 T :
+ (mut_subltype E L (ShrLtype (◠ty1) κ1) (ShrLtype lt2 κ2) T)
+ ⊢ mut_subltype E L (◠(shr_ref ty1 κ1)) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Hsub & $)". iPureIntro.
+ etrans; last done. eapply full_eqltype_subltype_r. by eapply shr_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_subltype_shr_ofty_2_inst E L {rt} `{!Inhabited rt} (ty1 : type rt) (lt2 : ltype rt) κ1 κ2 :
+ MutSubLtype E L (◠(shr_ref ty1 κ1))%I (ShrLtype lt2 κ2) | 10 := λ T, i2p (mut_subltype_shr_ofty_2 E L ty1 lt2 κ1 κ2 T).
+
+ (* same for [mut_eqltype] *)
+ Lemma mut_eqltype_shr_ofty_1_evar E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) κ1 T :
+ (∃ ty2', ⌜ty2 = shr_ref ty2' κ1⌠∗ mut_eqltype E L (ShrLtype lt1 κ1) (◠(shr_ref ty2' κ1)) T)
+ ⊢ mut_eqltype E L (ShrLtype lt1 κ1) (◠ty2) T.
+ Proof.
+ iIntros "(%ty2' & -> & HT)". done.
+ Qed.
+ Global Instance mut_eqltype_shr_ofty_1_evar_inst E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (place_rfn rt)) κ1 `{!IsProtected ty2} :
+ MutEqLtype E L (ShrLtype lt1 κ1) (◠ty2)%I | 10 := λ T, i2p (mut_eqltype_shr_ofty_1_evar E L lt1 ty2 κ1 T).
+
+ Lemma mut_eqltype_shr_ofty_1 E L {rt} `{!Inhabited rt} (lt1 : ltype rt) (ty2 : type (rt)) κ1 κ2 T :
+ mut_eqltype E L (ShrLtype lt1 κ1) (ShrLtype (◠ty2) κ2) T
+ ⊢ mut_eqltype E L (ShrLtype lt1 κ1) (◠(shr_ref ty2 κ2)) T.
+ Proof.
+ iIntros "(%Heq & $)". iPureIntro.
+ etrans; first done. by eapply shr_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_shr_ofty_1_inst E L {rt} `{!Inhabited rt} (lt1 : ltype (rt)) (ty2 : type rt) κ1 κ2 :
+ MutEqLtype E L (ShrLtype lt1 κ1) (◠(shr_ref ty2 κ2))%I | 12 := λ T, i2p (mut_eqltype_shr_ofty_1 E L lt1 ty2 κ1 κ2 T).
+
+ Lemma mut_eqltype_shr_ofty_2 E L {rt} `{!Inhabited rt} (ty1 : type rt) (lt2 : ltype rt) κ1 κ2 T :
+ (mut_eqltype E L (ShrLtype (◠ty1) κ1) (ShrLtype lt2 κ2) T)
+ ⊢ mut_eqltype E L (◠(shr_ref ty1 κ1)) (ShrLtype lt2 κ2) T.
+ Proof.
+ iIntros "(%Heq & $)". iPureIntro.
+ etrans; last done. symmetry. by eapply shr_ref_unfold_full_eqltype.
+ Qed.
+ Global Instance mut_eqltype_shr_ofty_2_inst E L {rt} `{!Inhabited rt} (ty1 : type rt) (lt2 : ltype rt) κ1 κ2 :
+ MutEqLtype E L (◠(shr_ref ty1 κ1))%I (ShrLtype lt2 κ2) | 10 := λ T, i2p (mut_eqltype_shr_ofty_2 E L ty1 lt2 κ1 κ2 T).
+
+ (** shortenlft *)
+ (*
+ Lemma type_shortenlft_shr E L sup_lfts {rt} `{!Inhabited rt} (ty : type rt) r κ π v T :
+ (∃ M κs, named_lfts M ∗ ⌜lookup_named_lfts M sup_lfts = Some κs⌠∗
+ ⌜lctx_lft_incl E L (lft_intersect_list' κs) κ⌠∗
+ (named_lfts M -∗ v â—áµ¥{Ï€} r @ shr_ref ty (lft_intersect_list' κs) -∗ T L)) -∗
+ typed_annot_expr E L 0 (ShortenLftAnnot sup_lfts) v (v â—áµ¥{Ï€} r @ shr_ref ty κ) T.
+ Proof.
+ iIntros "(%M & %κs & Hnamed & % & %Hincl & HT)".
+ iIntros "#CTX #HE HL Hv /=".
+ iPoseProof (lctx_lft_incl_incl with "HL HE") as "#Hsyn"; first done.
+ iModIntro. iExists L. iFrame "HL". iApply ("HT" with "Hnamed").
+ unshelve iApply (shr_ref_own_val_mono with "[//] [] Hv"); first done.
+ iIntros (?). iApply type_incl_refl.
+ Qed.
+ Global Instance type_shortenlft_shr_inst E L sup_lfts {rt} `{Inhabited rt} (ty : type rt) r κ π v :
+ TypedAnnotExpr E L 0 (ShortenLftAnnot sup_lfts) v (v â—áµ¥{Ï€} r @ shr_ref ty κ) :=
+ λ T, i2p (type_shortenlft_shr E L sup_lfts ty r κ π v T).
+ *)
+End rules.
diff --git a/theories/rust_typing/shims.v b/theories/rust_typing/shims.v
new file mode 100644
index 0000000000000000000000000000000000000000..ceb1c099f9f7d67e97591541646ab22f855e8ee7
--- /dev/null
+++ b/theories/rust_typing/shims.v
@@ -0,0 +1,2030 @@
+From refinedrust Require Import typing.
+
+
+
+(** Tuple defs *)
+(* Since the frontend doesn't generate them for now, we just provide a few pre-defined ones for reasonable sizes. *)
+Definition tuple1_sls (T0_st : syn_type) : struct_layout_spec :=
+ mk_sls "tuple1" [("0", T0_st)].
+Definition tuple1_rt (T0_rt : Type) : Type :=
+ plist place_rfn [T0_rt].
+Definition tuple1_ty `{!typeGS Σ} {T0_rt : Type} (T0_ty : type T0_rt) : type (tuple1_rt _) :=
+ struct_t (tuple1_sls (st_of T0_ty)) +[T0_ty].
+
+Definition tuple2_sls (T0_st T1_st : syn_type) : struct_layout_spec :=
+ mk_sls "tuple2" [("0", T0_st); ("1", T1_st)].
+Definition tuple2_rt (T0_rt : Type) (T1_rt : Type) : Type :=
+ plist place_rfn [T0_rt; T1_rt].
+Definition tuple2_ty `{!typeGS Σ} {T0_rt T1_rt : Type} (T0_ty : type T0_rt) (T1_ty : type T1_rt) : type (tuple2_rt _ _) :=
+ struct_t (tuple2_sls (st_of T0_ty) (st_of T1_ty)) +[T0_ty; T1_ty].
+
+Definition tuple3_sls (T0_st T1_st T2_st : syn_type) : struct_layout_spec :=
+ mk_sls "tuple3" [("0", T0_st); ("1", T1_st); ("2", T2_st)].
+Definition tuple3_rt (T0_rt : Type) (T1_rt : Type) (T2_rt : Type) : Type :=
+ plist place_rfn [T0_rt; T1_rt; T2_rt].
+Definition tuple3_ty `{!typeGS Σ} {T0_rt T1_rt T2_rt : Type} (T0_ty : type T0_rt) (T1_ty : type T1_rt) (T2_ty : type T2_rt) : type (tuple3_rt _ _ _) :=
+ struct_t (tuple3_sls (st_of T0_ty) (st_of T1_ty) (st_of T2_ty)) +[T0_ty; T1_ty; T2_ty].
+
+Definition tuple4_sls (T0_st T1_st T2_st T3_st : syn_type) : struct_layout_spec :=
+ mk_sls "tuple4" [("0", T0_st); ("1", T1_st); ("2", T2_st); ("3", T3_st)].
+Definition tuple4_rt (T0_rt : Type) (T1_rt : Type) (T2_rt : Type) (T3_rt : Type) : Type :=
+ plist place_rfn [T0_rt; T1_rt; T2_rt; T3_rt].
+Definition tuple4_ty `{!typeGS Σ} {T0_rt T1_rt T2_rt T3_rt : Type} (T0_ty : type T0_rt) (T1_ty : type T1_rt) (T2_ty : type T2_rt) (T3_ty : type T3_rt) : type (tuple4_rt _ _ _ _) :=
+ struct_t (tuple4_sls (st_of T0_ty) (st_of T1_ty) (st_of T2_ty) (st_of T3_ty)) +[T0_ty; T1_ty; T2_ty; T3_ty].
+
+Definition tuple5_sls (T0_st T1_st T2_st T3_st T4_st : syn_type) : struct_layout_spec :=
+ mk_sls "tuple5" [("0", T0_st); ("1", T1_st); ("2", T2_st); ("3", T3_st); ("4", T4_st)].
+Definition tuple5_rt (T0_rt : Type) (T1_rt : Type) (T2_rt : Type) (T3_rt : Type) (T4_rt : Type) : Type :=
+ plist place_rfn [T0_rt; T1_rt; T2_rt; T3_rt; T4_rt].
+Definition tuple5_ty `{!typeGS Σ} {T0_rt T1_rt T2_rt T3_rt T4_rt : Type} (T0_ty : type T0_rt) (T1_ty : type T1_rt) (T2_ty : type T2_rt) (T3_ty : type T3_rt) (T4_ty : type T4_rt) : type (tuple5_rt _ _ _ _ _) :=
+ struct_t (tuple5_sls (st_of T0_ty) (st_of T1_ty) (st_of T2_ty) (st_of T3_ty) (st_of T4_ty)) +[T0_ty; T1_ty; T2_ty; T3_ty; T4_ty].
+
+(* TODO move *)
+Lemma ly_align_log_in_u8 ly :
+ ly_align_in_bounds ly → Z.of_nat (ly_align_log ly) ∈ u8.
+Proof.
+ rewrite /ly_align_in_bounds/min_alloc_start/max_alloc_end/=/ly_align/bytes_per_addr/bytes_per_addr_log/=.
+ rewrite /bits_per_byte/=.
+ intros [Ha Hb].
+ split; first solve_goal.
+ rewrite /max_int/=/int_modulus/bits_per_int/bytes_per_int/it_byte_size_log/=.
+ rewrite /bits_per_byte/=.
+ assert ((2 ^ ly_align_log ly) ≤ 2 ^ (8%nat * 8))%nat as Hle.
+ { apply Nat2Z.inj_le. etrans; first apply Hb.
+ rewrite Nat2Z.inj_pow. nia.
+ }
+ apply PeanoNat.Nat.pow_le_mono_r_iff in Hle; last lia.
+ nia.
+Qed.
+Lemma ly_align_log_in_usize ly :
+ ly_align_in_bounds ly → Z.of_nat (ly_align_log ly) ∈ usize_t.
+Proof.
+ intros [_ Ha]%ly_align_log_in_u8.
+ split; first solve_goal.
+ etrans; first apply Ha.
+ rewrite /max_int/=/int_modulus/bits_per_int/bytes_per_int/it_byte_size_log/bits_per_byte/=.
+ nia.
+Qed.
+Lemma ly_align_in_usize ly :
+ ly_align_in_bounds ly → Z.of_nat (ly_align ly) ∈ usize_t.
+Proof.
+ intros [Ha Hb]. split; first solve_goal.
+ etrans; first apply Hb.
+ (* TODO: why doesn't this work anymore? *)
+ rewrite /max_alloc_end.
+ unfold max_alloc_end.
+ rewrite /bytes_per_addr/bytes_per_addr_log.
+ rewrite /max_int/=/int_modulus/bits_per_int/bytes_per_int/it_byte_size_log/=.
+ nia.
+Qed.
+
+(** ** Mem API *)
+
+(** mem::size_of *)
+Definition mem_size_of `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return (I2v (ly_size (use_layout_alg' T_st)) USize)
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_mem_size_of `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | () : unit, (λ Ï, []); λ Ï€, True)
+ → ∃ () : unit, (ly_size (use_layout_alg' T_st)) @ int usize_t; λ π, True.
+Lemma mem_size_of_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (mem_size_of T_st) [] (type_of_mem_size_of T_rt T_st).
+Proof.
+ start_function "mem_size_of" ( () ) ( () ).
+ repeat liRStep.
+ Unshelve.
+ all: unshelve_sidecond; solve_goal.
+Qed.
+
+(** mem::align_of *)
+Definition mem_align_of `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return (I2v (ly_align (use_layout_alg' T_st)) USize)
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_mem_align_of `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | () : unit, (λ Ï, []); λ Ï€, True)
+ → ∃ () : unit, (ly_align (use_layout_alg' T_st)) @ int usize_t; λ π, True.
+Lemma mem_align_of_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (mem_align_of T_st) [] (type_of_mem_align_of T_rt T_st).
+Proof.
+ start_function "mem_align_of" ( () ) ( () ).
+ repeat liRStep. Unshelve.
+ all: unshelve_sidecond.
+ by apply ly_align_in_usize.
+Qed.
+
+(** align_log_of -- gives the log2 of the alignment *)
+Definition mem_align_log_of `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return (I2v (ly_align_log (use_layout_alg' T_st)) USize)
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_mem_align_log_of `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | () : unit, (λ Ï, []); λ Ï€, True)
+ → ∃ () : unit, (ly_align_log (use_layout_alg' T_st)) @ int usize_t; λ π, True.
+Lemma mem_align_of_log_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (mem_align_log_of T_st) [] (type_of_mem_align_log_of T_rt T_st).
+Proof.
+ start_function "mem_align_log_of" ( () ) ( () ).
+ repeat liRStep. Unshelve.
+ all: unshelve_sidecond.
+ by eapply ly_align_log_in_usize.
+Qed.
+
+(** ** Ptr API *)
+
+(** copy_nonoverlapping *)
+(*
+ This just does a bytewise untyped copy, matching the intended Rust semantics. The sequence of bytes does not have to be a valid representation at any type.
+
+ fn copy_nonoverlapping<T>(size, src, dst) {
+ let mut count: usize = 0;
+
+ assert_unsafe_precondition!(
+ is_aligned_and_not_null(src)
+ && is_aligned_and_not_null(dst)
+ && is_nonoverlapping(src, dst, count)
+ );
+
+ let src = src as *const u8;
+ let dst = dst as *mut u8;
+ // do a bytewise copy
+ while count < size {
+ // uses untyped read + assignment, NOT the typed assignment in surface Rust!
+ *(dst.add(count)) = *src.add(count);
+ count+=1;
+ }
+ }
+
+ *)
+(* TODO: challenge for speccing this: what ownership do we require for src?
+ - technically, we could require a shared ref.
+ but: that is stronger than necessary - it asserts a validity invariant, whereas we should not require anything like that.
+ is that also true if I have &shr (bytewise v) -- i.e. the type below the shared ref does not assert any validity invariant?
+ I feel like that should be a pretty strong spec.
+ - we could also try to take fractional ownership - but that would be quite a heavyweight change for this.
+ - just take full ownership, similar to dst - but that is unnecessarily strong *)
+Definition copy_nonoverlapping `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("size", usize_t : layout); ("src", void* ); ("dst", void* )];
+ f_local_vars := [("count", usize_t : layout)];
+ f_code :=
+ <["_bb0" :=
+ "count" <-{IntOp usize_t} I2v 0 USize;
+ (* TODO: add safety checks *)
+ annot: StopAnnot;
+ Goto "_bb_loop_head"
+ ]>%E $
+ <["_bb_loop_head" :=
+
+ if{BoolOp}:
+ (use{IntOp usize_t} "count") <{IntOp usize_t, IntOp usize_t, u8} (use{IntOp usize_t} "size")
+ then
+ Goto "_bb_loop_body"
+ else
+ Goto "_bb_loop_exit"
+ ]>%E $
+ <["_bb_loop_body" :=
+ ((!{PtrOp} "dst") at_offset{use_layout_alg' T_st, PtrOp, IntOp usize_t} use{IntOp usize_t} "count")
+ <-{UntypedOp (use_layout_alg' T_st)}
+ use{UntypedOp (use_layout_alg' T_st)} (
+ ((!{PtrOp} "src") at_offset{use_layout_alg' T_st, PtrOp, IntOp usize_t} use{IntOp usize_t} "count"));
+ "count" <-{IntOp usize_t} (use{IntOp usize_t} "count") +{IntOp usize_t, IntOp usize_t} (I2v 1 USize);
+ Goto "_bb_loop_head"
+ ]>%E $
+ <["_bb_loop_exit" :=
+ annot: StopAnnot;
+ return zst_val
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+Definition type_of_copy_nonoverlapping `{!typeGS Σ} (T_rt : Type) (T_st : syn_type):=
+ fn(∀ () : 0 | (len, l_s, l_t, v_s) : (nat * loc * loc * val), (λ Ï, []);
+ Z.of_nat len @ int usize_t, l_s @ alias_ptr_t, l_t @ alias_ptr_t; λ π,
+ l_s â—â‚—[Ï€, Owned false] PlaceIn v_s @ (â— value_t (UntypedSynType (mk_array_layout (use_layout_alg' T_st) len))) ∗
+ l_t â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout (use_layout_alg' T_st) len))))
+ → ∃ () : unit, () @ unit_t; λ π,
+ l_s â—â‚—[Ï€, Owned false] PlaceIn v_s @ (â— value_t (UntypedSynType (mk_array_layout (use_layout_alg' T_st) len))) ∗
+ l_t â—â‚—[Ï€, Owned false] PlaceIn v_s @ (â— value_t (UntypedSynType (mk_array_layout (use_layout_alg' T_st) len))).
+Lemma copy_nonoverlapping_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (copy_nonoverlapping T_st) [IntSynType usize_t] (type_of_copy_nonoverlapping T_rt T_st).
+Proof.
+ start_function "copy_nonoverlapping" ( () ) ( [[[len l_s] l_t] v_s] ).
+ intros ls_size ls_src ls_dst ls_count.
+ repeat liRStep; liShow.
+
+ (* manual proof from here to formulate the loop invariant *)
+ iApply typed_stmt_annot_skip.
+ iSelect (_ â—â‚—[_, _] PlaceIn (Z.of_nat len) @ _)%I (fun H => iRename H into "Hlen").
+ iSelect (_ â—â‚—[_, _] PlaceIn 0%Z @ _)%I (fun H => iRename H into "Hcount").
+ iSelect (_ â—â‚—[_, _] PlaceIn l_s @ (â— alias_ptr_t))%I (fun H => iRename H into "Hsrc").
+ iSelect (_ â—â‚—[_, _] PlaceIn l_t @ (â— alias_ptr_t))%I (fun H => iRename H into "Hdst").
+ iSelect (l_s â—â‚—[_, _] _ @ _)%I (fun H => iRename H into "Hs").
+ iSelect (l_t â—â‚—[_, _] _ @ _)%I (fun H => iRename H into "Ht").
+ iApply fupd_typed_stmt.
+ iMod (ofty_uninit_to_value_t with "Ht") as "(%v_t & Ht)"; first done.
+ iMod (ofty_value_t_has_length with "Hs") as "(%Hlen_s & Hs)"; first done.
+ { sidecond_hook. revert select (ly_size (mk_array_layout _ _) ≤ _).
+ rewrite /mk_array_layout/=. lia. }
+ iMod (ofty_value_t_has_length with "Ht") as "(%Hlen_t & Ht)"; first done.
+ { sidecond_hook. revert select (ly_size (mk_array_layout _ _) ≤ _).
+ rewrite /mk_array_layout/=. lia. }
+
+ (* turn it into arrays *)
+ iPoseProof (ofty_value_t_untyped_to_array with "Hs") as "Hs".
+ iPoseProof (ofty_value_t_untyped_to_array with "Ht") as "Ht".
+ iModIntro.
+
+ set (loop_inv := (λ (E : elctx) (L : llctx),
+ ∃ (i : nat),
+ ⌜L = [Ï âŠ‘â‚—{0} []]⌠∗
+ ⌜E = []⌠∗
+ (credit_store 0 0 ∗
+ ls_size â—â‚—[Ï€, Owned false] PlaceIn (Z.of_nat len) @ (â— int usize_t) ∗
+ ls_count â—â‚—[Ï€, Owned false] PlaceIn (Z.of_nat i) @ (â— int usize_t) ∗
+ ls_src â—â‚—[Ï€, Owned false] PlaceIn l_s @ (â— alias_ptr_t) ∗
+ ls_dst â—â‚—[Ï€, Owned false] PlaceIn l_t @ (â— alias_ptr_t) ∗
+ l_s â—â‚—[ Ï€, Owned false] # (fmap (M:=list) PlaceIn (reshape (replicate len (ly_size T_st_ly)) v_s)) @ (â— array_t (value_t (UntypedSynType T_st_ly)) len) ∗
+ l_t â—â‚—[Ï€, Owned false] #(fmap (M:=list) PlaceIn (take i (reshape (replicate len (ly_size T_st_ly)) v_s) ++ drop i (reshape (replicate len (ly_size T_st_ly)) v_t))) @ (â— array_t (value_t (UntypedSynType T_st_ly)) len)))%I).
+ iApply (typed_goto_acc _ _ _ _ _ loop_inv).
+ { unfold_code_marker_and_compute_map_lookup. }
+ liRStep; liShow. iExists 0%nat.
+ repeat liRStep. liShow.
+ iRename select (loop_inv _ _) into "Hinv".
+ iDestruct "Hinv" as "(%i & -> & -> & Hcredit & Hlen & Hcount & Hsrc & Hdst & Hs & Ht)".
+ repeat liRStep; liShow.
+ (*return: go back to values *)
+ assert (take i (reshape (replicate len (ly_size T_st_ly)) v_s) ++ drop i (reshape (replicate len (ly_size T_st_ly)) v_t) = (reshape (replicate len (ly_size T_st_ly)) (take (i * ly_size T_st_ly) v_s ++ drop (i * ly_size T_st_ly) v_t))) as ->.
+ { shelve. }
+ iPoseProof (ofty_value_t_untyped_from_array with "Hs") as "Hs".
+ iPoseProof (ofty_value_t_untyped_from_array with "Ht") as "Ht".
+ iApply typed_stmt_annot_skip.
+ repeat liRStep; liShow.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve.
+ + solve_goal.
+ + cbn. rewrite -list_fmap_insert. rewrite list_insert_id; done.
+ + cbn. rewrite -list_fmap_insert.
+ rewrite insert_app_r_alt; first last.
+ { rewrite take_length. lia. }
+ rewrite take_length reshape_length.
+ rewrite Nat.min_l; first last. { rewrite replicate_length. lia. }
+ rewrite Nat.sub_diag.
+ f_equiv. f_equiv.
+ rename select (reshape _ v_s !! i = Some _) into Hlook.
+ rename select (i < len)%nat into Hi.
+ clear -Hlook Hi.
+ rewrite Nat.add_1_r.
+ erewrite take_S_r; last done.
+ rewrite -app_assoc.
+ f_equiv.
+ rewrite insert_take_drop; first last. { rewrite drop_length reshape_length replicate_length. lia. }
+ rewrite take_0 drop_drop. rewrite Nat.add_1_r. done.
+ + rewrite take_ge; last solve_goal with nia.
+ rewrite drop_ge; last solve_goal with nia.
+ by rewrite app_nil_r.
+ + rewrite drop_ge; first last. { rewrite reshape_length replicate_length. lia. }
+ rewrite app_nil_r.
+ rewrite drop_ge; first last. { solve_goal with nia. }
+ rewrite app_nil_r.
+ assert (len ≤ i) as Hle by lia. clear -Hle Hlen_s.
+ rewrite take_ge. 2: { rewrite reshape_length replicate_length. lia. }
+ rewrite take_ge; first done.
+ rewrite Hlen_s /mk_array_layout{1}/ly_size/=. nia.
+Qed.
+
+Definition ptr_write `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("dst", void* ); ("src", use_layout_alg' T_st)];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ (* NOTE: the rust impl uses copy_nonoverlapping and then asserts with an intrinsic that the validity invariant for T holds,
+ but we don't have such a thing and should simply use a typed copy *)
+ !{PtrOp} "dst" <-{use_op_alg' T_st} use{use_op_alg' T_st} "src";
+ return zst_val
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+(* Maybe this should also be specced in terms of value? *)
+Definition type_of_ptr_write `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ (()) : 0 | (T_ty, l, r) : (type T_rt * loc * T_rt), (λ Ï, []);
+ l @ alias_ptr_t, r @ T_ty; λ π,
+ (⌜T_st = T_ty.(ty_syn_type)⌠∗ ⌜ty_allows_reads T_ty⌠∗ ⌜ty_allows_writes T_ty⌠∗ l â—â‚—[Ï€, Owned false] .@ (â— uninit (T_ty.(ty_syn_type)))))
+ → ∃ () : unit, () @ unit_t; λ π,
+ l â—â‚—[Ï€, Owned false] PlaceIn r @ â— T_ty.
+
+Lemma ptr_write_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (ptr_write T_st) [] (type_of_ptr_write T_rt T_st).
+Proof.
+ start_function "ptr_write" ( [] ) ( [[T_ty l] r] ).
+ intros ls_dst ls_src.
+ repeat liRStep; liShow.
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: inv_layout_alg; done.
+Qed.
+
+
+Definition ptr_read `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("src", void* )];
+ f_local_vars := [("tmp", use_layout_alg' T_st)];
+ f_code :=
+ <["_bb0" :=
+ "tmp" <-{use_op_alg' T_st} use{use_op_alg' T_st} (!{PtrOp} "src");
+ return (use{use_op_alg' T_st} "tmp")
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_ptr_read `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (T_ty, l, r) : (type T_rt * loc * T_rt), (λ Ï, []);
+ l @ alias_ptr_t; λ π,
+ ⌜T_st = ty_syn_type T_ty⌠∗
+ ⌜ty_allows_reads T_ty⌠∗
+ (*(l â—â‚—[Ï€, Owned false] PlaceIn vs @ (â— value_t (T_ty.(ty_syn_type))))*)
+ (l â—â‚—[Ï€, Owned false] #r @ (â— T_ty))
+ )
+ (* TODO really, we would like to have this stronger spec that looses less information.
+ However, some parts of the type system (e.g. enum initialization) cannot deal well yet with moving in values again. *)
+ (*→ ∃ vs : val, vs @ value_t (T_ty.(ty_syn_type)); λ π,*)
+ (*(l â—â‚—[Ï€, Owned false] PlaceIn vs @ (â— value_t (T_ty.(ty_syn_type)))) ∗*)
+ (*vs â—áµ¥{Ï€} r @ T_ty*)
+ → ∃ () : unit, r @ T_ty; λ π,
+ (l â—â‚—[Ï€, Owned false] .@ (â— uninit (T_ty.(ty_syn_type))))
+ (*vs â—áµ¥{Ï€} r @ T_ty*)
+.
+
+Lemma ptr_read_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (ptr_read T_st) [T_st] (type_of_ptr_read T_rt T_st).
+Proof.
+ start_function "ptr_read" ( () ) ( [[T_ty l] r] ).
+ (* locally override the instance used for moves *)
+
+ liRStepUntil (typed_read_end).
+ iApply type_read_ofty_move_owned_value.
+ liFromSyntax.
+ repeat liRStep; liShow.
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+Qed.
+
+(*assert_unsafe_precondition!(is_aligned_and_not_null(src) && is_aligned_and_not_null(dst));*)
+(* "`copy` is semantically equivalent to C's [`memmove`], but with the argument
+ order swapped. Copying takes place as if the bytes were copied from `src`
+ to a temporary array and then copied from the array to `dst`."
+ We take this literally and create a new temporary allocation.
+*)
+Definition ptr_copy `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("src", void* ); ("dst", void* ); ("count", usize_t : layout)];
+ f_local_vars := [("tmp", void* )];
+ f_code :=
+ <["_bb0" :=
+ (*"tmp" <-{PtrOp} All*)
+ return zst_val
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+(* TODO *)
+Definition sublist_lookup' {A} (i n : nat) (l : list A) := take n (drop i l).
+Definition ptr_copy_result {A} (off_src : nat) (off_dst : nat) (count : nat) (xs : list (place_rfn (option A))) :=
+ let wipe_src := list_inserts off_src (replicate count (#None)) xs in
+ let ins_dst := list_inserts off_dst (sublist_lookup' off_src count xs) wipe_src in
+ ins_dst.
+
+(* This spec really relies on the fact that the core type system does not usually disassemble arrays, but keeps them as one chunk in the context. *)
+(* (Of course, ptr::copy_nonoverlapping is an exception) *)
+Definition type_of_ptr_copy `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (T_ty, l, off_src, off_dst, count, len, xs) : (type T_rt * loc * nat * nat * Z * nat * list (place_rfn (option (place_rfn T_rt)))), (λ Ï, []);
+ (l, off_src) @ offset_ptr_t T_st,
+ (l, off_dst) @ offset_ptr_t T_st,
+ count @ int usize_t; λ π,
+ ⌜T_st = ty_syn_type T_ty⌠∗
+ (l â—â‚—[Ï€, Owned false] (#xs) @ (â— array_t (maybe_uninit T_ty) len)) ∗
+ ⌜(0 ≤ count)%Z⌠∗
+ ⌜0 ≤ off_src⌠∗
+ ⌜0 ≤ off_dst⌠∗
+ ⌜(off_src + count < len)%Z⌠∗
+ ⌜(off_dst + count < len)%ZâŒ)
+ → ∃ () : unit, () @ unit_t; λ π,
+ l â—â‚—[Ï€, Owned false] (#(ptr_copy_result off_src off_dst (Z.to_nat count) xs)) @ (â— array_t (maybe_uninit T_ty) len).
+
+Lemma ptr_copy_typed `{!typeGS Σ} π (T_rt : Type) (T_st : syn_type) (T_ly : layout) :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (ptr_copy T_st) [PtrSynType] (type_of_ptr_copy T_rt T_st).
+Proof.
+Abort.
+
+(** ptr::invalid *)
+(* Our implementation does not actually do anything with the type parameter, it's just there to mirror the Rust API. *)
+Definition ptr_invalid `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("align", usize_t : layout)];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return (UnOp (CastOp PtrOp) (IntOp usize_t) (UnOp EraseProv (UntypedOp usize_t) (use{IntOp usize_t} "align")))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_ptr_invalid `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (n) : nat, (λ Ï, []); Z.of_nat n @ int usize_t; λ Ï€, ⌜(min_alloc_start ≤ n)%Z ∧ (n ≤ max_alloc_end)%ZâŒ)
+ → ∃ l : loc, l @ alias_ptr_t; (λ Ï€, ⌜l `aligned_to` n⌠∗ l â—â‚—[Ï€, Owned false] .@ â— unit_t).
+Lemma ptr_invalid_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (ptr_invalid T_st) [] (type_of_ptr_invalid T_rt T_st).
+Proof.
+ intros.
+ start_function "ptr_invalid" ( () ) ( n ) => l.
+ repeat liRStep. liShow.
+ (* EraseProv *)
+ iIntros "Hv" (Φ) "#CTX #HE HL Hcont".
+ rewrite {1}/ty_own_val /=. iDestruct "Hv" as %[Hv Hsz].
+ iApply wp_erase_prov.
+ { rewrite /has_layout_val. erewrite (val_to_Z_ot_length _ (IntOp usize_t)); done. }
+ iApply ("Hcont" $! _ _ _ (int usize_t) n with "HL []").
+ { rewrite /ty_own_val/=. iSplit; last done. iPureIntro. by apply val_to_Z_erase_prov. }
+
+ iIntros "Hv" (Φ') "_ _ HL Hcont".
+ rewrite {1}/ty_own_val /=. iDestruct "Hv" as %[Hv' _].
+ iApply wp_cast_int_ptr_prov_none; [done | done | done | | done | ].
+ { apply val_to_byte_prov_erase_prov. }
+ iIntros "!> Hl Hcred".
+ iApply ("Hcont" $! _ _ _ (alias_ptr_t) _ with "HL").
+ { rewrite /ty_own_val /=. done. }
+ iAssert (val_of_loc (ProvAlloc None, n : addr) â—áµ¥{Ï€} (ProvAlloc None, n : addr) @ alias_ptr_t)%I as "?".
+ { rewrite /ty_own_val /= //. }
+ iAssert ((ProvAlloc None, n : addr) â—â‚—[Ï€, Owned false] .@ â— unit_t)%I with "[Hl]" as "?".
+ { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists _. simpl. iSplitR; first done.
+ iSplitR. { iPureIntro. eapply Z.divide_1_l. }
+ iSplitR; first done.
+ iPoseProof (heap_mapsto_loc_in_bounds with "Hl") as "#Hlb".
+ iSplitR; first done. iSplitR; first done.
+ iExists (). iSplitR; first done.
+ iModIntro. iExists []. iFrame. rewrite /ty_own_val /= //. }
+
+ repeat liRStep.
+ Unshelve.
+ all: unshelve_sidecond; sidecond_hook.
+ rewrite /aligned_to /=. apply Z.divide_refl.
+Qed.
+
+(** inspired by NonNull::dangling *)
+Definition ptr_dangling `{!LayoutAlg} (T_st : syn_type) (mem_align_of_loc : loc) (ptr_invalid_loc : loc) : function := {|
+ f_args := [];
+ f_local_vars := [("align", usize_t : layout)];
+ f_code :=
+ <["_bb0" :=
+ "align" <-{IntOp usize_t} CallE mem_align_of_loc [] [@{expr} ];
+ return (CallE ptr_invalid_loc [] [@{expr} use{IntOp usize_t} "align"])
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_ptr_dangling `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | () : unit, (λ Ï, []); λ Ï€, True)
+ → ∃ (l) : loc, l @ alias_ptr_t; λ π, ⌜l `has_layout_loc` (use_layout_alg' T_st)⌠∗
+ (l â—â‚—[Ï€, Owned false] .@ â— (uninit UnitSynType)) ∗ freeable_nz l 0 1 HeapAlloc.
+Lemma ptr_dangling_typed `{!typeGS Σ} π T_rt T_st T_ly mem_align_of_loc ptr_invalid_loc :
+ syn_type_has_layout T_st T_ly →
+ mem_align_of_loc â—áµ¥{Ï€} mem_align_of_loc @ function_ptr [] (type_of_mem_align_of T_rt T_st) -∗
+ ptr_invalid_loc â—áµ¥{Ï€} ptr_invalid_loc @ function_ptr [IntSynType usize_t] (type_of_ptr_invalid T_rt T_st) -∗
+ typed_function π (ptr_dangling T_st mem_align_of_loc ptr_invalid_loc) [IntSynType usize_t] (type_of_ptr_dangling T_rt T_st).
+Proof.
+ start_function "ptr_dangling" ( () ) ( () ) => l_align.
+ init_lfts (∅).
+ repeat liRStep; liShow.
+ Unshelve.
+ all: unshelve_sidecond; sidecond_hook.
+Qed.
+
+
+(** mut_ptr::offset / const_ptr::offset *)
+Definition ptr_offset `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("self", void* ); ("count", isize_t : layout)];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return ((use{PtrOp} "self") at_offset{use_layout_alg' T_st, PtrOp, IntOp isize_t} (use{IntOp isize_t} "count"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0"
+|}.
+
+Inductive trace_offset :=
+ | TraceOffset (offset : Z).
+
+Definition type_of_ptr_offset `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (l, offset) : loc * Z, (λ Ï, []); l @ alias_ptr_t, (offset) @ int isize_t; λ Ï€,
+ ⌜l `has_layout_loc` (use_layout_alg' T_st)⌠∗
+ ⌜(offset * size_of_st T_st)%Z ∈ isize_t⌠∗
+ case_destruct (bool_decide (offset < 0))%Z
+ (λ b _, if b then loc_in_bounds l (Z.to_nat (-offset) * size_of_st T_st) 0 else loc_in_bounds l 0 (Z.to_nat offset * size_of_st T_st))
+
+ (*loc_in_bounds l*)
+ (*(if bool_decide (offset < 0)%Z then Z.to_nat (-offset) * size_of_st T_st else 0)*)
+ (*(if bool_decide (offset > 0)%Z then Z.to_nat offset * size_of_st T_st else 0)*)
+ ) →
+ ∃ () : unit, (l offsetst{T_st}ₗ offset) @ alias_ptr_t; λ π, £ (S (num_laters_per_step 1)) ∗ atime 1.
+
+Lemma ptr_offset_typed `{!typeGS Σ} π T_rt T_st T_ly :
+ syn_type_has_layout T_st T_ly →
+ ⊢ typed_function π (ptr_offset T_st) [] (type_of_ptr_offset T_rt T_st).
+Proof.
+ intros.
+ start_function "ptr_offset" ( () ) ( [l offset] ) => l_self l_count.
+ init_lfts ∅.
+ repeat liRStep. liShow.
+ liFromSyntax.
+ iIntros "Hbounds".
+ (* do the actual offset *)
+ iAssert (loc_in_bounds l (if (decide (offset < 0)) then (Z.to_nat (-offset) * size_of_st T_st)%nat else 0%nat) (if decide (offset > 0)%Z then (Z.to_nat offset * size_of_st T_st)%nat else 0%nat))%I with "[Hbounds]" as "#Hbounds'" .
+ { rewrite /case_if.
+ case_decide; case_decide; case_bool_decide; eauto with lia.
+ iApply (loc_in_bounds_shorten_suf with "[Hbounds //]"). lia. }
+ repeat liRStep; liShow.
+ iIntros "Hv1 Hv2" (Φ) "#CTX #HE HL Hcont".
+ rewrite {1}/ty_own_val /=. iDestruct "Hv1" as %[Hv1 Hsz1].
+ rewrite {1}/ty_own_val /=. iDestruct "Hv2" as "->".
+ iDestruct (loc_in_bounds_ptr_in_range with "Hbounds'") as %[Hran1 Hran2].
+ rewrite /size_of_st. simplify_layout_goal.
+ iRename select (credit_store _ _) into "Hstore".
+ iPoseProof (credit_store_borrow_receipt with "Hstore") as "(Hat & Hatcl)".
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iMod (persistent_time_receipt_0) as "Hp".
+ iApply (wp_ptr_offset_credits with "TIME Hat Hp").
+ { done. }
+ { apply val_to_of_loc. }
+ { done. }
+ { split; simplify_layout_goal; lia. }
+ { rewrite /offset_loc. fold (size_of_st T_st).
+ iApply (loc_in_bounds_offset with "Hbounds'").
+ { done. }
+ { destruct l; simpl. clear Hran2. case_decide; lia. }
+ { destruct l; simpl. clear Hran1. case_decide; lia. }
+ }
+ { iApply (loc_in_bounds_offset with "Hbounds'"); [ done | | ].
+ { clear Hran2. case_decide; lia. }
+ { clear Hran1. case_decide; lia. }
+ }
+ iNext. simpl. iEval (rewrite additive_time_receipt_succ). iIntros "Hcred [Hat Hat']".
+ iPoseProof ("Hatcl" with "Hat'") as "Hstore".
+ iPoseProof (credit_store_donate with "Hstore Hcred") as "Hstore".
+ iPoseProof (credit_store_donate_atime with "Hstore Hat") as "Hstore".
+ iApply ("Hcont" $! _ _ _ (alias_ptr_t) with "HL").
+ { rewrite /ty_own_val /=. done. }
+ iAssert ((l offset{use_layout_alg' T_st}â‚— offset) â—áµ¥{ Ï€} l offset{use_layout_alg' T_st}â‚— offset @ alias_ptr_t)%I as "?".
+ { rewrite /ty_own_val /= //. }
+
+ repeat liRStep; liShow.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal.
+Qed.
+
+Definition ptr_add `{!LayoutAlg} (T_st : syn_type) (ptr_offset_loc : loc) : function := {|
+ f_args := [("self", void* ); ("count", usize_t : layout)];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ (* cast the usize to isize *)
+ return (CallE ptr_offset_loc [] [@{expr} use{PtrOp} "self"; UnOp (CastOp (IntOp isize_t)) (IntOp usize_t) use{IntOp usize_t} "count"])
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+Definition type_of_ptr_add `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (l, offset) : loc * Z, (λ Ï, []); l @ alias_ptr_t, (offset) @ int usize_t; λ Ï€,
+ ⌜l `has_layout_loc` (use_layout_alg' T_st)⌠∗
+ ⌜(offset * size_of_st T_st)%Z ∈ isize_t⌠∗
+ loc_in_bounds l 0 ((Z.to_nat offset) * size_of_st T_st)
+ ) →
+ ∃ () : unit, (l, Z.to_nat offset) @ offset_ptr_t T_st; λ π, £ (S (num_laters_per_step 1)) ∗ atime 1.
+
+Lemma ptr_add_typed `{!typeGS Σ} π T_rt T_st T_ly ptr_offset_loc :
+ syn_type_has_layout T_st T_ly →
+ ptr_offset_loc â—áµ¥{Ï€} ptr_offset_loc @ function_ptr [PtrSynType; IntSynType isize_t] (type_of_ptr_offset T_rt T_st) -∗
+ typed_function π (ptr_add T_st ptr_offset_loc) [] (type_of_ptr_add T_rt T_st).
+Proof.
+ intros.
+ start_function "mut_ptr_add" ( () ) ( [l offset] ) => l_self l_count.
+ init_lfts ∅.
+ repeat liRStep; liShow.
+ Unshelve. all: unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal.
+
+ (* basically, the reasoning is:
+ - if T is a ZST, then the wrapped offset gets annihilated everywhere, so it's fine.
+ - else, we also know that it's in isize_t, so it's same as before.
+ *)
+ 4,6: rewrite /OffsetLocSt; simplify_layout (use_layout_alg' T_st); do 2 f_equiv.
+ all: destruct (decide (ly_size T_st_ly = 0%nat));
+ [ lia | assert (min_int isize_t ≤ offset ≤ max_int isize_t)%Z; prepare_sideconditions; normalize_and_simpl_goal; try (unfold_common_defs; solve_goal)].
+ all: rewrite wrap_to_int_id.
+ all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; try (unfold_common_defs; solve_goal).
+Qed.
+
+Definition ptr_is_null `{!LayoutAlg} (T_st : syn_type) : function := {|
+ f_args := [("self", void* )];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return (use{PtrOp} "self" = {PtrOp, PtrOp, u8} NULL)
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+Definition type_of_ptr_is_null `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (l) : loc, (λ Ï, []); l @ alias_ptr_t; λ Ï€, True) → ∃ b : bool, b @ bool_t; λ Ï€, ⌜b = bool_decide (l.2 = 0)âŒ.
+(* TODO should maybe adapt pointer comparison semantics beforehand, because Caesium currently requires the loc_in_bounds stuff for comparison. *)
+(* TODO should also have some automation to learn things - i.e. gain knowledge that b = false in case we actually have ownership *)
+
+
+
+
+(** Allocator API *)
+(*
+ how do we specify allocations?
+ - option 1: have an owned_ptr type (essentially box, but without the deallocation permission) and keep the deallocation permission external
+ - option 2: just return a box (this is a bit of a red herring, since it really would not be a Rust Box)
+ - option 3: have an allocation_t type that also deals with the additional flexibility for freeable permissions we will need for gathering stuff for reallocation.
+ + we need this anyways, but can we also use it here?
+ => work this out in detail first, then decide here.
+ - option 4: use ofty + value
+ => Going with this.
+ *)
+
+Definition alloc_alloc `{!LayoutAlg} : function := {|
+ f_args := [("size", usize_t : layout); ("align_log2", usize_t : layout)];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ return (Alloc (use{IntOp usize_t} "size") (use{IntOp usize_t} "align_log2"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+ |}.
+Definition type_of_alloc_alloc `{!typeGS Σ} :=
+ fn(∀ () : 0 | (size, align_log2) : (Z * Z), (λ Ï, []); size @ int usize_t, align_log2 @ int usize_t; λ Ï€,
+ ⌜size ∈ isize_t⌠∗ ⌜(size > 0)%Z⌠∗
+ (* TODO: this restriction would not be necessary, but needed because the layout algorithm requires it. Can we lift this? *)
+ ⌜layout_wf (Layout (Z.to_nat size) (Z.to_nat align_log2))⌠∗
+ ⌜ly_align_in_bounds (Layout (Z.to_nat size) (Z.to_nat align_log2))âŒ
+ ) →
+ ∃ (l) : loc, l @ alias_ptr_t; λ π,
+ l â—â‚—[Ï€, Owned false] .@ (â— (uninit (UntypedSynType (Layout (Z.to_nat size) (Z.to_nat align_log2))))) ∗
+ (*l â—â‚—[Ï€, Owned false] #v @ (â— (value_t (UntypedSynType (Layout (Z.to_nat size) (Z.to_nat align_log2))))) ∗*)
+ freeable_nz l (Z.to_nat size) 1 HeapAlloc.
+Lemma alloc_alloc_typed `{!typeGS Σ} π :
+ ⊢ typed_function π alloc_alloc [] (type_of_alloc_alloc).
+Proof.
+ Local Typeclasses Opaque layout_wf.
+ start_function "alloc_alloc" ( () ) ( [size align_log2] ) => l_size l_align_log2.
+ repeat liRStep. liShow.
+
+ (* do the alloc *)
+ typed_val_expr_bind. repeat liRStep; liShow.
+ typed_val_expr_bind. repeat liRStep; liShow.
+ iSelect (_ â—áµ¥{_} size @ _)%I (fun H => iRename H into "Hsize").
+ iSelect (_ â—áµ¥{_} align_log2 @ _)%I (fun H => iRename H into "Halign_log2").
+ rewrite {1 2}/ty_own_val /=. iDestruct "Hsize" as "[%Hsize _]".
+ iDestruct "Halign_log2" as "[%Halign_log2 _]".
+ iIntros (Φ) "#CTX HE HL Hcont".
+ iApply (wp_alloc _ _ _ _ (Z.to_nat size) (Z.to_nat align_log2)).
+ { rewrite Hsize. f_equiv.
+ apply val_to_Z_unsigned_nonneg in Hsize; last done. lia. }
+ { rewrite Halign_log2. f_equiv.
+ apply val_to_Z_unsigned_nonneg in Halign_log2; last done. lia. }
+ { lia. }
+ iIntros "!>" (l) "Hl Hf %Hly Hcred".
+ iApply ("Hcont" $! _ _ _ (alias_ptr_t) l with "HL []").
+ { rewrite /ty_own_val /=. done. }
+ set (ly := (Layout (Z.to_nat size) (Z.to_nat align_log2))).
+ iAssert (l â—â‚—[Ï€, Owned false] .@ â— (uninit (UntypedSynType ly)))%I with "[Hl]" as "Hl'".
+ { rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ assert (syn_type_has_layout (UntypedSynType ly) ly) as Hly'.
+ { solve_layout_alg. }
+ (*subst ly. rewrite /layout_wf /ly_align /ly_size. cbn. *)
+ (*apply Nat2Z_divide. done. }*)
+ iExists ly. simpl. iSplitR; first done.
+ iSplitR; first done. iSplitR; first done.
+ iPoseProof (heap_mapsto_loc_in_bounds with "Hl") as "#Hlb".
+ iSplitR. { rewrite replicate_length /ly /ly_size /=. done. }
+ iSplitR; first done.
+ iExists tt. iSplitR; first done.
+ iModIntro. iExists _. iFrame. rewrite uninit_own_spec. iExists ly.
+ iSplitR; first done. iPureIntro. rewrite /has_layout_val replicate_length /ly /ly_size //. }
+
+ (*value_subsume_full_goal_ofty*)
+ iRevert "Hf".
+
+ repeat liRStep; liShow.
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal.
+Qed.
+
+Notation "'free{' e_size ',' e_align '}' e_ptr ; s" := (Free e_size%E e_align%E e_ptr%E s%E)
+ (at level 80, s at level 200, format "'[v' 'free{' e_size ',' e_align '}' e_ptr ';' '/' s ']'") : expr_scope.
+Definition alloc_dealloc `{!LayoutAlg} : function := {|
+ f_args := [("size", usize_t : layout); ("align", usize_t : layout); ("ptr", void* )];
+ f_local_vars := [];
+ f_code :=
+ <["_bb0" :=
+ free{ use{IntOp usize_t} "size", use{IntOp usize_t} "align"} (use{PtrOp} "ptr");
+ return zst_val
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+Definition type_of_alloc_dealloc `{!typeGS Σ} :=
+ fn(∀ () : 0 | (size, align_log2, ptr) : (Z * Z * loc), (λ Ï, []); size @ int usize_t, align_log2 @ int usize_t, ptr @ alias_ptr_t; λ Ï€,
+ freeable_nz ptr (Z.to_nat size) 1 HeapAlloc ∗
+ ⌜(0 < size)%Z⌠∗
+ ptr â—â‚—[Ï€, Owned false] .@ (â— (uninit (UntypedSynType (Layout (Z.to_nat size) (Z.to_nat align_log2))))) ) →
+ ∃ () : unit, () @ unit_t; λ π, True.
+
+Lemma alloc_dealloc_typed `{!typeGS Σ} π :
+ ⊢ typed_function π alloc_dealloc [] (type_of_alloc_dealloc).
+Proof.
+ start_function "alloc_dealloc" ( () ) ( [[size align_log2] ptr] ) => l_size l_align_log2 l_ptr.
+ repeat liRStep. liShow.
+
+ (* do the free *)
+ typed_stmt_bind. repeat liRStep; liShow.
+ typed_stmt_bind. repeat liRStep; liShow.
+ typed_stmt_bind. repeat liRStep; liShow.
+ iSelect (_ â—áµ¥{_} size @ _)%I (fun H => iRename H into "Hsize").
+ iSelect (_ â—áµ¥{_} align_log2 @ _)%I (fun H => iRename H into "Halign_log2").
+ iSelect (ptr â—â‚—[_, _] _ @ _)%I (fun H => iRename H into "Hptr").
+ iSelect (freeable_nz _ _ _ _) (fun H => iRename H into "Hfree").
+ rewrite {1 2}/ty_own_val /=. iDestruct "Hsize" as "[%Hsize _]".
+ iDestruct "Halign_log2" as "[%Halign_log2 _]".
+ iIntros "#CTX #HE HL".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. simpl.
+ set (ly := Layout (Z.to_nat size) (Z.to_nat align_log2)).
+ iDestruct "Hptr" as "(%ly' & %Hst & %Hly & _ & #Hlb & _ & %r' & <- & Hb)".
+ specialize (syn_type_has_layout_untyped_inv _ _ Hst) as (-> & ? & ?).
+ iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ iDestruct "Hb" as "(%v' & Hptr & Hv')".
+ iPoseProof (ty_own_val_has_layout with "Hv'") as "%Hlyv'"; first done.
+
+ iApply (wps_free _ _ _ ptr _ _ (Z.to_nat size) (Z.to_nat align_log2) with "[Hptr] [Hfree]").
+ { rewrite Hsize. f_equiv.
+ apply val_to_Z_unsigned_nonneg in Hsize; last done. lia. }
+ { rewrite Halign_log2. f_equiv.
+ apply val_to_Z_unsigned_nonneg in Halign_log2; last done. lia. }
+ { lia. }
+ { iExists _. iFrame. fold ly. done. }
+ { rewrite /freeable_nz.
+ destruct ((Z.to_nat size)) eqn:Heq; first lia. done. }
+ iIntros "!> Hcred".
+
+ to_typed_stmt "CTX HE HL".
+ repeat liRStep; liShow.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
+Qed.
+
+(**
+ fn alloc_realloc(old_size, align, new_size, ptr) -> *mut u8 {
+ let new_ptr = alloc::alloc(new_size, align);
+ copy_nonoverlapping(ptr, new_ptr, min(old_size, new_size));
+ alloc::dealloc(old_size, align, ptr);
+ new_ptr
+ }
+*)
+Definition alloc_realloc `{!LayoutAlg} (alloc_alloc_loc : loc) (copy_nonoverlapping_loc : loc) (alloc_dealloc_loc : loc) : function := {|
+ f_args := [("old_size", usize_t : layout); ("align", usize_t : layout); ("new_size", usize_t : layout); ("ptr", void* )];
+ f_local_vars := [("new_ptr", void* ); ("min_size", usize_t : layout)];
+ f_code :=
+ <["_bb0" :=
+ "new_ptr" <-{PtrOp} CallE alloc_alloc_loc [] [@{expr} use{IntOp usize_t} "new_size"; use{IntOp usize_t} "align"];
+ "min_size" <-{IntOp usize_t} (IfE BoolOp (use{IntOp usize_t} "new_size" <{IntOp usize_t, IntOp usize_t, u8} use{IntOp usize_t} "old_size") (use{IntOp usize_t} "new_size") (use{IntOp usize_t} "old_size"));
+ annot: StopAnnot;
+ expr: CallE copy_nonoverlapping_loc [] [@{expr} use{IntOp usize_t} "min_size"; use{PtrOp} "ptr"; use{PtrOp} "new_ptr"];
+ expr: CallE alloc_dealloc_loc [] [@{expr} use{IntOp usize_t} "old_size"; use{IntOp usize_t} "align"; use{PtrOp} "ptr"];
+ return (use{PtrOp} "new_ptr")
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+
+#[global] Typeclasses Opaque layout_wf.
+
+(* TODO move *)
+Lemma fupd_typed_val_expr `{!typeGS Σ} π E L e T :
+ (|={⊤}=> typed_val_expr π E L e T) -∗ typed_val_expr π E L e T.
+Proof.
+ iIntros "HT" (?) "CTX HE HL Hc".
+ iApply fupd_wp. iMod ("HT") as "HT". iApply ("HT" with "CTX HE HL Hc").
+Qed.
+Lemma fupd_typed_call `{!typeGS Σ} π E L κs v (P : iProp Σ) vl tys T :
+ (|={⊤}=> typed_call π E L κs v P vl tys T) -∗ typed_call π E L κs v P vl tys T.
+Proof.
+ iIntros "HT HP Ha".
+ iApply fupd_typed_val_expr. iMod "HT" as "HT". iApply ("HT" with "HP Ha").
+Qed.
+
+
+(* TODO move *)
+Lemma ofty_value_t_untyped_to_bytes `{!typeGS Σ} π l vn ly :
+ l â—â‚—[Ï€, Owned false] #vn @ (â— value_t (UntypedSynType ly)) -∗
+ l â—â‚—[Ï€, Owned false] #vn @ (â— value_t (UntypedSynType $ mk_array_layout u8 (ly_size ly))).
+Proof.
+ (* We can always go to something with a lower alignment *)
+ iIntros "Hl". iPoseProof (ltype_own_has_layout with "Hl") as "(%ly' & %Halg & %Hly)".
+ simp_ltypes in Halg. simpl in Halg.
+ apply syn_type_has_layout_untyped_inv in Halg as (-> & ? & ?).
+ iApply (ofty_value_t_untyped_reduce_alignment with "Hl").
+ - simpl. lia.
+ - rewrite /has_layout_loc/ly_align/mk_array_layout/u8/=.
+ rewrite /aligned_to. apply Z.divide_1_l.
+ - rewrite /layout_wf/ly_align/u8/=. apply Z.divide_1_l.
+ - done.
+Qed.
+Lemma value_t_untyped_length `{!typeGS Σ} π v v1 ly :
+ v â—áµ¥{Ï€} v1 @ value_t (UntypedSynType ly) -∗
+ ⌜length v1 = ly_size ly⌠∗ ⌜length v = ly_size lyâŒ.
+Proof.
+ rewrite /ty_own_val/=.
+ iDestruct 1 as "(%ot & %Hot & %Hmc & %Hly & %Hst)".
+ apply use_op_alg_untyped_inv in Hot as ->.
+ apply syn_type_has_layout_untyped_inv in Hst as (<- & ? & ?).
+ apply is_memcast_val_untyped_inv in Hmc as ->.
+ rewrite /has_layout_val in Hly. simpl in *.
+ done.
+Qed.
+Lemma ofty_value_t_untyped_length `{!typeGS Σ} F π l ly v1 :
+ lftE ⊆ F →
+ l â—â‚—[Ï€, Owned false] #v1 @ (â— value_t (UntypedSynType ly)) ={F}=∗
+ ⌜length v1 = ly_size ly⌠∗ l â—â‚—[Ï€, Owned false] #v1 @ (â— value_t (UntypedSynType ly)).
+Proof.
+ iIntros (?) "Hl".
+ rewrite ltype_own_ofty_unfold/lty_of_ty_own.
+ iDestruct "Hl" as "(%ly' & % & % & ? & ? & ? & %r' & <- & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "(%v & Hl & Hv)"; first done.
+ iPoseProof (value_t_untyped_length with "Hv") as "(% & %)".
+ iR. iModIntro. iExists _. iFrame. iR. iR. iExists _. iR.
+ iModIntro. eauto with iFrame.
+Qed.
+
+Lemma ofty_value_t_untyped_split_adjacent_array `{!typeGS Σ} F π l (n m k : nat) ly v1 :
+ lftE ⊆ F →
+ n = (m + k)%nat →
+ layout_wf ly →
+ l â—â‚—[ Ï€, Owned false] # v1 @ (â— value_t (UntypedSynType (mk_array_layout ly n))) ={F}=∗
+ l â—â‚—[ Ï€, Owned false] # (take (ly_size ly * k) v1) @ (â— value_t (UntypedSynType (mk_array_layout ly k))) ∗
+ (l offset{ly}â‚— k) â—â‚—[ Ï€, Owned false] # (drop (ly_size ly * k) v1) @ (â— value_t (UntypedSynType (mk_array_layout ly m))).
+Proof.
+ iIntros (? Hn ?).
+ rewrite /offset_loc.
+ assert (ly_size (mk_array_layout ly k) = ly_size ly * k)%nat as Heq. { simpl. lia. }
+ rewrite -Nat2Z.inj_mul. rewrite -{3}Heq.
+ iIntros "Hl". iMod (ofty_value_t_untyped_length with "Hl") as "(%Hlen & Hl)"; first done.
+ simpl in *.
+ iApply (ofty_value_t_split_adjacent with "Hl").
+ - done.
+ - simpl. lia.
+ - simpl. lia.
+ - simpl. lia.
+ - rewrite take_drop//.
+ - rewrite take_length. simpl. lia.
+ - by apply array_layout_wf.
+ - by apply array_layout_wf.
+Qed.
+
+Definition type_of_alloc_realloc `{!typeGS Σ} :=
+ fn(∀ () : 0 | (old_size, align_log2, new_size, ptr_old, v) : (Z * Z * Z * loc * val), (λ Ï, []); old_size @ int usize_t, align_log2 @ int usize_t, new_size @ int usize_t, ptr_old @ alias_ptr_t; λ Ï€,
+ (* TODO restriction of the spec: we cannot shrink it *)
+ ⌜(old_size ≤ new_size)%Z⌠∗
+ ⌜(0 < old_size)%Z⌠∗
+ ⌜new_size ≤ max_int isize_t⌠∗
+ (* TODO: restriction placed by our syntype model, not required in Rust *)
+ ⌜layout_wf (Layout (Z.to_nat new_size) (Z.to_nat align_log2))⌠∗
+ (*⌜ly_align_in_bounds (Layout (Z.to_nat new_size) (Z.to_nat align_log2))⌠∗*)
+ (*⌜layout_wf (Layout (Z.to_nat old_size) (Z.to_nat align_log2))⌠∗*)
+ ptr_old â—â‚—[Ï€, Owned false] PlaceIn v @ (â— value_t (UntypedSynType (Layout (Z.to_nat old_size) (Z.to_nat align_log2)))) ∗
+ freeable_nz ptr_old (Z.to_nat old_size) 1 HeapAlloc) →
+ ∃ (ptr_new, v') : (loc * val), ptr_new @ alias_ptr_t; λ π,
+ freeable_nz ptr_new (Z.to_nat new_size) 1 HeapAlloc ∗
+ ptr_new â—â‚—[Ï€, Owned false] #(v ++ v') @ (â— value_t (UntypedSynType (Layout (Z.to_nat new_size) (Z.to_nat align_log2)))) ∗
+ ⌜v' `has_layout_val` (Layout (Z.to_nat (new_size - old_size)) (Z.to_nat align_log2))âŒ
+.
+#[global] Typeclasses Opaque Z.divide.
+Lemma alloc_realloc_typed `{!typeGS Σ} π alloc_alloc_loc copy_nonoverlapping_loc alloc_dealloc_loc :
+ alloc_alloc_loc â—áµ¥{Ï€} alloc_alloc_loc @ function_ptr [IntSynType usize_t; IntSynType usize_t] (type_of_alloc_alloc) -∗
+ copy_nonoverlapping_loc â—áµ¥{Ï€} copy_nonoverlapping_loc @ function_ptr [IntSynType usize_t; PtrSynType; PtrSynType] (type_of_copy_nonoverlapping Z (IntSynType u8)) -∗
+ alloc_dealloc_loc â—áµ¥{Ï€} alloc_dealloc_loc @ function_ptr [IntSynType usize_t; IntSynType usize_t; PtrSynType] (type_of_alloc_dealloc) -∗
+ typed_function π (alloc_realloc alloc_alloc_loc copy_nonoverlapping_loc alloc_dealloc_loc) [PtrSynType; IntSynType usize_t] type_of_alloc_realloc.
+Proof.
+ start_function "alloc_realloc" ( () ) ( [[[[old_size align_log2] new_size] ptr_old] v_old] ) => l_old_size l_align_log2 l_new_size l_ptr_old l_ptr_new l_min_size.
+ init_lfts ∅.
+ set (old_ly := Layout (Z.to_nat old_size) (Z.to_nat align_log2)).
+ set (new_ly := Layout (Z.to_nat new_size) (Z.to_nat align_log2)).
+ repeat liRStep. liShow.
+ fold old_ly new_ly.
+ (* augment context with layout well-formedness info *)
+ iRename select (ptr_old â—â‚—[_, _] _ @ _)%I into "Hold".
+ iRename select (x' â—â‚—[_, _] _ @ _)%I into "Hnew".
+ iPoseProof (ltype_own_has_layout with "Hold") as "(%ly_old & %Halg_old & %)".
+ iPoseProof (ltype_own_has_layout with "Hnew") as "(%ly_new & %Halg_new & %)".
+ simp_ltypes in Halg_old. apply syn_type_has_layout_untyped_inv in Halg_old as (-> & ? & ?).
+ simp_ltypes in Halg_new. apply syn_type_has_layout_untyped_inv in Halg_new as (-> & _ & _).
+
+ iApply typed_stmt_annot_skip.
+ liRStepUntil (typed_call).
+ (* make into value, because the part not affected by the memcpy will be returned *)
+ iRename select (x' â—â‚—[_, _] .@ _)%I into "Hnew".
+
+ (* The copy_nonoverlapping does a bytewise copy, so we need to convert it into an "array" of bytes *)
+ iApply fupd_typed_call.
+ iMod (ofty_uninit_to_value_t with "Hnew") as "(%vn & Hnew)"; first done.
+ iMod (ofty_value_t_has_length with "Hnew") as "(%Hlen & Hnew)"; [done | | ].
+ { eapply syn_type_has_layout_untyped; [done.. | | done]. rewrite /ly_size/=. lia. }
+ iPoseProof (ofty_value_t_untyped_to_bytes with "Hnew") as "Hnew".
+ iMod (ofty_value_t_untyped_split_adjacent_array _ _ _ _ (ly_size new_ly - ly_size old_ly) (ly_size old_ly) with "Hnew") as "(Hnew1 & Hnew2)"; first done.
+ { simpl. lia. }
+ { rewrite /layout_wf/ly_align/it_layout. simpl. apply Z.divide_1_l. }
+ simpl. rewrite !Nat.add_0_r.
+ iModIntro.
+
+ (*repeat liRStep; liShow.*)
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+liRStep; liShow.
+
+ iApply subsume_full_ofty_owned_subtype.
+ simpl.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ iApply owned_subtype_to_uninit.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ liRStep; liShow.
+ rewrite Nat.add_0_r.
+ assert ((x' offset{u8}â‚— Z.to_nat old_size) = x' +â‚— Z.to_nat old_size) as ->.
+ { rewrite /offset_loc. rewrite /ly_size/=/bytes_per_int/=.
+ f_equiv. lia. }
+ liRStep; liShow.
+ (*Set Typeclasses Debug.*)
+ liRStep; liShow.
+ liRStep; liShow.
+ liInst Hevar1 (mk_array_layout u8 (Z.to_nat new_size - Z.to_nat old_size)).
+ repeat liRStep; liShow.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; try (unfold_common_defs; solve_goal); unsolved_sidecond_hook.
+ all: try by (rewrite /has_layout_loc/layout_wf/aligned_to/ly_align/u8/=; apply Z.divide_1_l).
+
+ { rewrite /has_layout_val drop_length/=. rewrite Hlen/new_ly/ly_size/=. lia. }
+Qed.
+
+
+
+
+(** Box API *)
+Definition box_new `{!LayoutAlg} (T_st : syn_type) (mem_size_of_T_loc : loc) (ptr_dangling_T_loc : loc) : function := {|
+ f_args := [("x", use_layout_alg' T_st)];
+ f_local_vars := [
+ ("__0", void* : layout);
+ ("size", usize_t : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ (* check if the size is 0 *)
+ "size" <-{IntOp usize_t} CallE mem_size_of_T_loc [] [@{expr} ];
+ if{BoolOp}: use{IntOp usize_t} "size" = {IntOp usize_t, IntOp usize_t, u8} I2v 0 USize
+ then Goto "_bb1"
+ else Goto "_bb2"
+ ]>%E $
+ <["_bb2" :=
+ (* non-ZST, do an actual allocation *)
+ (* TODO maybe call alloc_alloc here? *)
+ "__0" <-{ PtrOp } box{ T_st };
+ !{ PtrOp } "__0" <-{ use_op_alg' T_st } (use{use_op_alg' T_st} "x");
+ return (use{ PtrOp } ("__0"))
+ ]>%E $
+ <["_bb1" :=
+ (* ZST, use a dangling pointer *)
+ "__0" <-{PtrOp} CallE ptr_dangling_T_loc [] [@{expr} ];
+ annot: StopAnnot;
+ (* do a zero-sized write - this is fine *)
+ !{ PtrOp } "__0" <-{ use_op_alg' T_st } (use{use_op_alg' T_st} "x");
+ return (use{PtrOp} "__0")
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+(* TODO move *)
+Lemma typed_stmt_annot_credits `{!typeGS Σ} Ï€ E L {A} (a : A) s rf R Ï n :
+ atime n -∗
+ (atime (S n) -∗ £ (S (num_laters_per_step n)) -∗ typed_stmt Ï€ E L s rf R Ï) -∗
+ typed_stmt Ï€ E L (annot: a; s) rf R Ï.
+Proof.
+ iIntros "Hat HT".
+ iIntros "#CTX #HE HL".
+ iMod (persistent_time_receipt_0) as "Hp".
+ iApply (derived.wps_annot_credits with "[] Hat Hp").
+ { iDestruct "CTX" as "(_ & $ & _)". }
+ iNext. iIntros "Hcred Hat".
+ rewrite Nat.add_0_r.
+ iApply ("HT" with "Hat Hcred CTX HE HL").
+Qed.
+
+
+Definition type_of_box_new `{!typeGS Σ} T_rt T_st :=
+ fn(∀ () : 0 | (T, x) : type T_rt * T_rt, (λ Ï, []); x @ T; λ Ï€, ⌜ty_syn_type T = T_st⌠∗ ⌜ty_allows_reads T⌠∗ ⌜ty_allows_writes TâŒ)
+ → ∃ () : (), PlaceIn x @ box T; λ π, True.
+Lemma box_new_typed `{!typeGS Σ} π T_st (T_rt : Type) (mem_size_of_T_loc ptr_dangling_T_loc : loc) :
+ syn_type_is_layoutable T_st →
+ mem_size_of_T_loc â—áµ¥{Ï€} mem_size_of_T_loc @ function_ptr [] (type_of_mem_size_of T_rt T_st) -∗
+ ptr_dangling_T_loc â—áµ¥{Ï€} ptr_dangling_T_loc @ function_ptr [] (type_of_ptr_dangling T_rt T_st) -∗
+ typed_function π (box_new T_st mem_size_of_T_loc ptr_dangling_T_loc) [PtrSynType; IntSynType usize_t] (type_of_box_new T_rt T_st).
+Proof.
+ start_function "box_new" ( () ) ( (T, x) ) => arg_x local_0 local_size.
+ init_tyvars (<["T" := existT _ T]> ∅).
+ init_lfts ∅.
+ repeat liRStep; liShow.
+ - (* zero branch *)
+ (* TODO maybe use place instance for alias_ptr instead of manually wrapping up the pointsto *)
+ iRename select (credit_store _ _) into "Hstore".
+ iPoseProof (credit_store_borrow_receipt with "Hstore") as "(Hat & Hcl_store)".
+
+ iApply (typed_stmt_annot_credits with "Hat").
+ iIntros "Hat Hcred".
+ rewrite lc_succ. iDestruct "Hcred" as "(Hcred1 & Hcred)".
+ rewrite (additive_time_receipt_succ 1). iDestruct "Hat" as "(Hat1 & Hat)".
+ iPoseProof ("Hcl_store" with "Hat") as "Hstore".
+
+ (* make a box type out of the alias_ptr *)
+ iSelect (_ â—â‚—[_, _] _ @ â— (uninit UnitSynType))%I (fun H => iRename H into "H_pts").
+ iSelect (local_0 â—â‚—[_, _] _ @ _)%I (fun H => iRename H into "H_0").
+ iAssert (local_0 â—â‚—[Ï€, Owned false] #(#()) @ â— box (uninit (ty_syn_type T)))%I with "[H_pts H_0 Hcred Hat1]" as "H_0".
+ { iApply (ofty_owned_subtype_aligned with "[-H_0] H_0").
+ { solve_layout_alg. }
+ { done. }
+ iSplitR. { iPureIntro. intros ly1 ly2 Hptr1 Hptr2. simpl in *. f_equiv. by eapply syn_type_has_layout_inj. }
+ iSplitR. { simpl. eauto. }
+ iIntros (v2) "Hv".
+ iEval (rewrite /ty_own_val/=) in "Hv". iDestruct "Hv" as "->".
+ iEval (rewrite /ty_own_val/=).
+ iExists x', _. iR. iR. iR.
+ iPoseProof (ltype_own_loc_in_bounds with "H_pts") as "#Hlb".
+ { simp_ltypes. solve_layout_alg. }
+ simpl.
+ unfold_no_enrich. inv_layout_alg.
+ rename select (ly_size T_st_ly = _) into Hsz. rewrite Hsz. iFrame "Hlb".
+ iFrame. iExists tt. iR. iNext.
+ rewrite ltype_own_ofty_unfold/lty_of_ty_own.
+ iDestruct "H_pts" as "(%ly & % & % & _ & _ & _ & %r' & <- & >(%v2 & Hpt & Hb))".
+ iModIntro. iExists v2. iFrame.
+ rewrite {3 4}/ty_own_val/=.
+ iDestruct "Hb" as "(%ly' & %Hstly' & %Hlyv & ?)".
+ iExists _. iR. iFrame. iPureIntro.
+ apply syn_type_has_layout_unit_inv in Hstly'; subst.
+ move: Hlyv. rewrite /has_layout_val => ->. rewrite Hsz. done.
+ }
+ repeat liRStep.
+ - (* non-zero branch, do the allocation *)
+ iIntros (?) "#CTX #HE HL Hcont".
+ rewrite /Box.
+ unfold_no_enrich. inv_layout_alg.
+ have: (Z.of_nat $ ly_size T_st_ly) ∈ usize_t by done.
+ efeed pose proof (ly_align_log_in_usize T_st_ly) as Ha; first done.
+ move: Ha.
+ intros [? Halign]%(val_of_Z_is_Some None) [? Hsz]%(val_of_Z_is_Some None).
+ iDestruct "CTX" as "(LFT & TIME & LLCTX)".
+ iSelect (credit_store _ _) ltac:(fun H => iRename H into "Hstore").
+ iPoseProof (credit_store_borrow_receipt with "Hstore") as "(Hat & Hstore)".
+ iMod (persistent_time_receipt_0) as "Hp".
+ iApply (wp_alloc_credits with "TIME Hat Hp").
+ { done. }
+ { simplify_layout_goal. rewrite /i2v Hsz /=. by eapply val_to_of_Z. }
+ { simplify_layout_goal. rewrite /i2v Halign /=. by eapply val_to_of_Z. }
+ { case_bool_decide; [done | lia]. }
+ iIntros "!> %l Hl Hfree %Hly [Hcred1 Hcred] Hat".
+ rewrite (additive_time_receipt_succ 1). iDestruct "Hat" as "[Hat1 Hat]".
+ iPoseProof ("Hstore" with "Hat1") as "Hstore".
+ iApply ("Hcont" $! _ _ _ (box (uninit (ty_syn_type T))) (PlaceIn ()) with "HL [Hfree Hl Hcred Hat]").
+ { iExists _, _. iSplitR; first done. iSplitR; first done.
+ match goal with | H : use_layout_alg (ty_syn_type T) = Some ?ly |- _ => rename ly into T_ly; rename H into H_T end.
+ iR.
+ iPoseProof (heap_mapsto_loc_in_bounds with "Hl") as "#Hlb".
+ rewrite replicate_length. iFrame "Hlb". simpl. iSplitR; first done. iFrame.
+ iSplitL "Hfree". { by iApply freeable_freeable_nz. }
+ iExists (). iSplitR; first done. iNext. iModIntro.
+ iExists _. iFrame. rewrite uninit_own_spec. iExists T_ly.
+ iSplitR; first done. rewrite /has_layout_val replicate_length //. }
+ iSplitR; first done.
+ repeat liRStep; liShow.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; try (unfold_common_defs; solve_goal); unsolved_sidecond_hook.
+ (* TODO : why do we manually need to unfold for this? *)
+ all: unfold_no_enrich; inv_layout_alg.
+ all: sidecond_hook; solve_goal.
+Qed.
+
+(* Drop functions receive a pointer to the thing to drop, just like drop_in_place *)
+
+(* Drop for box *)
+Definition drop_box_T (T_ly : layout) (drop_T_loc : loc) : function := {|
+ f_args := [("x", void*)];
+ f_local_vars := [
+ ("__0", unit_sl : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ (* TODO: have a path for ZST *)
+ (* drop T in-place, pass a pointer to the T *)
+ expr: Call drop_T_loc [&raw{Mut} (!{PtrOp} (!{PtrOp} "x"))];
+ (* now free the memory *)
+ (* TODO: use alloc_dealloc here? *)
+ (*Free (use{ PtrOp } (!{PtrOp} "x"));*)
+ (* return *)
+ "__0" <-{ UntypedOp (unit_sl) } zst_val;
+ return (use{ UntypedOp (unit_sl) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+
+(* Drop for integer types *)
+Definition drop_int (it : int_type) : function := {|
+ f_args := [("x", void* : layout)];
+ f_local_vars := [
+ ("__0", unit_sl : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ (* do nothing *)
+ "__0" <-{ UntypedOp (unit_sl) } zst_val;
+ return (use{ UntypedOp (unit_sl) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+(* Drop for mutable references *)
+Definition drop_mutref : function := {|
+ f_args := [("x", void*)];
+ f_local_vars := [
+ ("__0", unit_sl : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ (* do nothing, but on the ghost level, do a ghost drop *)
+ "__0" <-{ UntypedOp (unit_sl) } zst_val;
+ return (use{ UntypedOp (unit_sl) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+(* Drop for shared references *)
+Definition drop_shrref : function := {|
+ f_args := [("x", void*)];
+ f_local_vars := [
+ ("__0", unit_sl : layout)
+ ];
+ f_code :=
+ <["_bb0" :=
+ (* do nothing *)
+ "__0" <-{ UntypedOp (unit_sl) } zst_val;
+ return (use{ UntypedOp (unit_sl) } ("__0"))
+ ]>%E $
+ ∅;
+ f_init := "_bb0";
+|}.
+
+
+
+(** ** Array allocator shims *)
+
+Definition size_of_array_in_bytes `{!LayoutAlg} (st : syn_type) (len : nat) : nat :=
+ let ly := use_layout_alg' st in
+ ly.(ly_size) * len.
+Global Hint Unfold size_of_array_in_bytes : core.
+
+(** alloc_array *)
+Definition alloc_array (T_st : syn_type) (mem_align_log_of_T_loc : loc) (mem_size_of_T_loc : loc) (alloc_alloc_loc : loc) : function := {|
+ f_args := [("len", usize_t : layout)];
+ f_local_vars := [
+ ("__0", void* : layout);
+ ("align_log2", usize_t : layout);
+ ("size_of_T", usize_t : layout);
+ ("bytes", usize_t : layout)
+ ];
+ f_code :=
+ <["bb0" :=
+ "align_log2" <-{ IntOp usize_t } CallE mem_align_log_of_T_loc [] [@{expr} ];
+ "size_of_T" <-{IntOp usize_t} CallE mem_size_of_T_loc [] [@{expr} ];
+ "bytes" <-{ IntOp usize_t } ((use{IntOp usize_t} "len") ×c{IntOp usize_t, IntOp usize_t} (use{IntOp usize_t} "size_of_T"));
+ "__0" <-{PtrOp} CallE alloc_alloc_loc [] [@{expr} use{IntOp usize_t} "bytes"; use{IntOp usize_t} "align_log2"];
+ return (use{PtrOp} "__0")
+ ]>%E $
+ ∅;
+ f_init := "bb0";
+ |}.
+
+Definition type_of_alloc_array `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (size) : (Z), (λ Ï, []); size @ int usize_t; λ Ï€,
+ ⌜Z.of_nat (size_of_array_in_bytes T_st (Z.to_nat size)) ∈ isize_t⌠∗
+ ⌜(size > 0)%Z⌠∗
+ ⌜(size_of_st T_st > 0)%ZâŒ) →
+ ∃ l : loc, l @ alias_ptr_t; λ π,
+ l â—â‚—[Ï€, Owned false] .@ (â— (uninit (ArraySynType T_st (Z.to_nat size)))) ∗
+ freeable_nz l ((size_of_array_in_bytes T_st (Z.to_nat size))) 1 HeapAlloc.
+
+Lemma alloc_array_layout_wf T_st_ly size :
+ layout_wf T_st_ly →
+ layout_wf
+ {|
+ ly_size := Z.to_nat size * ly_size T_st_ly;
+ ly_align_log := ly_align_log T_st_ly
+ |}.
+Proof.
+ intros (x & Hwf).
+ exists (Z.to_nat size * x)%Z.
+ simpl. rewrite {1}/ly_align {1}/ly_align_log. simpl.
+ fold (ly_align T_st_ly). lia.
+Qed.
+Lemma alloc_array_typed `{!typeGS Σ} π T_rt (T_st : syn_type) (mem_align_log_of_T_loc mem_size_of_T_loc alloc_alloc_loc : loc) :
+ syn_type_is_layoutable T_st →
+ mem_align_log_of_T_loc â—áµ¥{Ï€} mem_align_log_of_T_loc @ function_ptr [] (type_of_mem_align_log_of T_rt T_st) -∗
+ mem_size_of_T_loc â—áµ¥{Ï€} mem_size_of_T_loc @ function_ptr [] (type_of_mem_size_of T_rt T_st) -∗
+ alloc_alloc_loc â—áµ¥{Ï€} alloc_alloc_loc @ function_ptr [IntSynType usize_t; IntSynType usize_t] (type_of_alloc_alloc) -∗
+ typed_function π (alloc_array T_st mem_align_log_of_T_loc mem_size_of_T_loc alloc_alloc_loc) [PtrSynType; IntSynType usize_t; IntSynType usize_t; IntSynType usize_t] (type_of_alloc_array T_rt T_st).
+Proof.
+ start_function "alloc_array" ( () ) ( size ) => arg_len local_0 local_align_log2 local_size_of_T local_bytes.
+ init_tyvars ∅.
+ init_lfts ∅.
+ repeat liRStep; liShow.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
+ Unshelve. all: by apply alloc_array_layout_wf.
+Qed.
+
+(** realloc_array *)
+Definition realloc_array (T_st : syn_type) (mem_align_log_of_T_loc : loc) (mem_size_of_T_loc : loc) (alloc_realloc_loc : loc) : function := {|
+ f_args := [
+ ("old_len", usize_t : layout);
+ ("ptr", void* : layout);
+ ("new_len", usize_t : layout)
+ ];
+ f_local_vars := [
+ ("__0", void* : layout);
+ ("align_log2", usize_t : layout);
+ ("size_of_T", usize_t : layout);
+ ("old_bytes", usize_t : layout);
+ ("new_bytes", usize_t : layout)
+ ];
+ f_code :=
+ <["bb0" :=
+ "align_log2" <-{ IntOp usize_t } CallE mem_align_log_of_T_loc [] [@{expr} ];
+ "size_of_T" <-{IntOp usize_t} CallE mem_size_of_T_loc [] [@{expr} ];
+ "old_bytes" <-{ IntOp usize_t } ((use{IntOp usize_t} "old_len") ×c{IntOp usize_t, IntOp usize_t} (use{IntOp usize_t} "size_of_T"));
+ "new_bytes" <-{ IntOp usize_t } ((use{IntOp usize_t} "new_len") ×c{IntOp usize_t, IntOp usize_t} (use{IntOp usize_t} "size_of_T"));
+ "__0" <-{PtrOp} CallE alloc_realloc_loc [] [@{expr} use{IntOp usize_t} "old_bytes"; use{IntOp usize_t} "align_log2"; use{IntOp usize_t} "new_bytes"; use{PtrOp} "ptr"];
+ return (use{PtrOp} "__0")
+ ]>%E $
+ ∅;
+ f_init := "bb0";
+ |}.
+
+(* Spec is using UntypedSynType (instead of ArraySynType) because this is using untyped copies *)
+Definition type_of_realloc_array `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (old_size, new_size, l, v) : (Z * Z * loc * val), (λ Ï, []);
+ old_size @ int usize_t, l @ alias_ptr_t, new_size @ int usize_t; λ π,
+ freeable_nz l (size_of_array_in_bytes T_st (Z.to_nat old_size)) 1 HeapAlloc ∗
+ l â—â‚—[Ï€, Owned false] #v @ (â— value_t (UntypedSynType (mk_array_layout (use_layout_alg' T_st) (Z.to_nat old_size)))) ∗
+ ⌜(old_size ≤ new_size)%Z⌠∗
+ ⌜Z.of_nat (size_of_array_in_bytes T_st (Z.to_nat new_size)) ∈ isize_t⌠∗
+ ⌜(old_size > 0)%Z⌠∗
+ ⌜(size_of_st T_st > 0)%ZâŒ) →
+ ∃ (l', v') : (loc * val), l' @ alias_ptr_t; λ π,
+ l' â—â‚—[Ï€, Owned false] #(v ++ v') @ (â— (value_t (UntypedSynType (mk_array_layout (use_layout_alg' T_st) (Z.to_nat new_size))))) ∗
+ v' â—áµ¥{Ï€} .@ uninit (UntypedSynType (mk_array_layout (use_layout_alg' T_st) (Z.to_nat (new_size - old_size)))) ∗
+ freeable_nz l' ((size_of_array_in_bytes T_st (Z.to_nat new_size))) 1 HeapAlloc.
+
+Lemma realloc_array_typed `{!typeGS Σ} π T_rt (T_st : syn_type) (mem_align_log_of_T_loc mem_size_of_T_loc alloc_realloc_loc : loc) :
+ syn_type_is_layoutable T_st →
+ mem_align_log_of_T_loc â—áµ¥{Ï€} mem_align_log_of_T_loc @ function_ptr [] (type_of_mem_align_log_of T_rt T_st) -∗
+ mem_size_of_T_loc â—áµ¥{Ï€} mem_size_of_T_loc @ function_ptr [] (type_of_mem_size_of T_rt T_st) -∗
+ alloc_realloc_loc â—áµ¥{Ï€} alloc_realloc_loc @ function_ptr [IntSynType usize_t; IntSynType usize_t; IntSynType usize_t; PtrSynType] (type_of_alloc_realloc) -∗
+ typed_function π (realloc_array T_st mem_align_log_of_T_loc mem_size_of_T_loc alloc_realloc_loc) [PtrSynType; IntSynType usize_t; IntSynType usize_t; IntSynType usize_t; IntSynType usize_t] (type_of_realloc_array T_rt T_st).
+Proof.
+ start_function "realloc_array" ( () ) ( [[[old_size new_size] l] v] ) => arg_old_len arg_ptr arg_new_len local_0 local_align_log2 local_size_of_T local_old_bytes local_new_bytes.
+ init_tyvars ∅.
+ init_lfts ∅.
+ repeat liRStep; liShow.
+ iAssert (x'0 â—áµ¥{Ï€} .@ uninit (UntypedSynType (mk_array_layout T_st_ly (Z.to_nat (new_size - old_size)))))%I as "Ha".
+ { rewrite uninit_own_spec. iExists _.
+ { iSplitR.
+ { iPureIntro. solve_layout_alg. solve_goal. }
+ iPureIntro. rewrite /has_layout_val.
+ match goal with | H : x'0 `has_layout_val` _ |- _ => rename H into Hlen end.
+ rewrite Hlen.
+ solve_goal.
+ }
+ }
+ repeat liRStep; liShow.
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal.
+ all: try solve_goal; try (unfold_common_defs; solve_goal); unsolved_sidecond_hook.
+ all: rewrite Nat.mul_comm; by apply array_layout_wf.
+Qed.
+
+
+(** dealloc_array *)
+Definition dealloc_array `{!LayoutAlg} (T_st : syn_type) (mem_align_log_of_T_loc : loc) (mem_size_of_T_loc : loc) (alloc_dealloc_loc : loc) : function := {|
+ f_args := [
+ ("len", usize_t : layout);
+ ("ptr", void* : layout)
+ ];
+ f_local_vars := [
+ ("__0", use_layout_alg' UnitSynType : layout);
+ ("align_log2", usize_t : layout);
+ ("size_of_T", usize_t : layout);
+ ("bytes", usize_t : layout)
+ ];
+ f_code :=
+ <["bb0" :=
+ "align_log2" <-{ IntOp usize_t } CallE mem_align_log_of_T_loc [] [@{expr} ];
+ "size_of_T" <-{IntOp usize_t} CallE mem_size_of_T_loc [] [@{expr} ];
+ "bytes" <-{ IntOp usize_t } ((use{IntOp usize_t} "len") ×c{IntOp usize_t, IntOp usize_t} (use{IntOp usize_t} "size_of_T"));
+ expr: CallE alloc_dealloc_loc [] [@{expr} use{IntOp usize_t} "bytes"; use{IntOp usize_t} "align_log2"; use{PtrOp} "ptr"];
+ "__0" <-{use_op_alg' UnitSynType} zst_val;
+ return (use{use_op_alg' UnitSynType} "__0")
+ ]>%E $
+ ∅;
+ f_init := "bb0";
+ |}.
+
+Definition type_of_dealloc_array `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (size, l) : (Z * loc), (λ Ï, []);
+ size @ int usize_t, l @ alias_ptr_t; λ π,
+ freeable_nz l (size_of_array_in_bytes T_st (Z.to_nat size)) 1 HeapAlloc ∗
+ l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout (use_layout_alg' T_st) (Z.to_nat size)))) ∗
+ ⌜(size > 0)%Z⌠∗
+ ⌜Z.of_nat (size_of_array_in_bytes T_st (Z.to_nat size)) ∈ isize_t⌠∗
+ ⌜(size_of_st T_st > 0)%ZâŒ) →
+ ∃ () : unit, () @ unit_t; λ π, True.
+
+
+Lemma dealloc_array_typed `{!typeGS Σ} π T_rt (T_st : syn_type) (mem_align_log_of_T_loc mem_size_of_T_loc alloc_dealloc_loc : loc) :
+ syn_type_is_layoutable T_st →
+ mem_align_log_of_T_loc â—áµ¥{Ï€} mem_align_log_of_T_loc @ function_ptr [] (type_of_mem_align_log_of T_rt T_st) -∗
+ mem_size_of_T_loc â—áµ¥{Ï€} mem_size_of_T_loc @ function_ptr [] (type_of_mem_size_of T_rt T_st) -∗
+ alloc_dealloc_loc â—áµ¥{Ï€} alloc_dealloc_loc @ function_ptr [IntSynType usize_t; IntSynType usize_t; PtrSynType] (type_of_alloc_dealloc) -∗
+ typed_function π (dealloc_array T_st mem_align_log_of_T_loc mem_size_of_T_loc alloc_dealloc_loc) [UnitSynType; IntSynType usize_t; IntSynType usize_t; IntSynType usize_t] (type_of_dealloc_array T_rt T_st).
+Proof.
+ start_function "dealloc_array" ( () ) ( [size l] ) => arg_len arg_ptr local_0 local_align_log2 local_size_of_T local_bytes.
+ init_tyvars ∅.
+ init_lfts ∅.
+ repeat liRStep; liShow.
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; try (unfold_common_defs; solve_goal); unsolved_sidecond_hook.
+ rewrite Nat.mul_comm.
+ by apply array_layout_wf.
+Qed.
+
+(** check_array_layoutable *)
+Definition check_array_layoutable `{!LayoutAlg} (T_st : syn_type) (mem_align_log_of_T_loc : loc) (mem_size_of_T_loc : loc) : function := {|
+ f_args := [
+ ("len", usize_t : layout)
+ ];
+ f_local_vars := [
+ ("__0", use_layout_alg' BoolSynType : layout);
+ ("align_log2", usize_t : layout);
+ ("size_of_T", usize_t : layout);
+ ("bytes", usize_t : layout);
+ ("check", use_layout_alg' BoolSynType : layout)
+ ];
+ f_code :=
+ <["bb0" :=
+ "align_log2" <-{ IntOp usize_t } CallE mem_align_log_of_T_loc [] [@{expr} ];
+ "size_of_T" <-{IntOp usize_t} CallE mem_size_of_T_loc [] [@{expr} ];
+ "check" <-{ BoolOp } CheckBinOp MulOp (IntOp usize_t) (IntOp usize_t) (use{IntOp usize_t} "len") (use{IntOp usize_t} "size_of_T");
+ if{BoolOp}: (use{BoolOp} "check") then Goto "bb1" else Goto "bb2" ]>%E $
+ <["bb1" :=
+ (* result fits into usize *)
+ "bytes" <-{ IntOp usize_t } ((use{IntOp usize_t} "len") ×c{IntOp usize_t, IntOp usize_t} (use{IntOp usize_t} "size_of_T"));
+ "__0" <-{use_op_alg' BoolSynType} ((use{IntOp usize_t} "bytes") ≤{IntOp usize_t, IntOp usize_t, u8} (I2v (max_int isize_t) USize));
+ return (use{use_op_alg' BoolSynType} "__0")
+ ]>%E $
+ <["bb2" :=
+ (* result does not fit into usize *)
+ return (Val (val_of_bool false))
+ ]>%E $
+ ∅;
+ f_init := "bb0";
+ |}.
+
+Definition type_of_check_array_layoutable `{!typeGS Σ} (T_rt : Type) (T_st : syn_type) :=
+ fn(∀ () : 0 | (size) : (Z), (λ Ï, []); size @ int usize_t; λ Ï€, True) →
+ ∃ () : unit, (bool_decide (size_of_array_in_bytes T_st (Z.to_nat size) ≤ max_int isize_t)%Z) @ bool_t; λ π, True.
+
+Lemma check_array_layoutable_typed `{!typeGS Σ} π T_rt (T_st : syn_type) (mem_align_log_of_T_loc mem_size_of_T_loc : loc) :
+ syn_type_is_layoutable T_st →
+ mem_align_log_of_T_loc â—áµ¥{Ï€} mem_align_log_of_T_loc @ function_ptr [] (type_of_mem_align_log_of T_rt T_st) -∗
+ mem_size_of_T_loc â—áµ¥{Ï€} mem_size_of_T_loc @ function_ptr [] (type_of_mem_size_of T_rt T_st) -∗
+ typed_function π (check_array_layoutable T_st mem_align_log_of_T_loc mem_size_of_T_loc) [BoolSynType; IntSynType usize_t; IntSynType usize_t; IntSynType usize_t; BoolSynType] (type_of_check_array_layoutable T_rt T_st).
+Proof.
+ start_function "check_array_layoutable" ( () ) ( size ) => arg_len local_0 local_align_log2 local_size_of_T local_bytes local_check.
+ init_tyvars ∅.
+ init_lfts ∅.
+ repeat liRStep; liShow.
+
+ typed_val_expr_bind.
+ repeat liRStep; liShow.
+ typed_val_expr_bind.
+ repeat liRStep; liShow.
+ iIntros (?) "#CTX #HE HL HC".
+ iRename select (_ â—áµ¥{_} size @ int usize_t)%I into "Hv1".
+ iRename select (_ â—áµ¥{_} ly_size T_st_ly @ int usize_t)%I into "Hv2".
+ iPoseProof (ty_own_int_in_range with "Hv1") as "%Hsz". destruct Hsz.
+ iEval (rewrite /ty_own_val/=) in "Hv1".
+ iEval (rewrite /ty_own_val/=) in "Hv2".
+ iDestruct "Hv1" as "(%Hsize &_)".
+ iDestruct "Hv2" as "(%HTsize & _)".
+ iApply wp_check_int_arithop; [done.. | ].
+ iNext. iIntros "_".
+ iApply ("HC" $! _ _ _ (bool_t) with "HL"). { iApply type_val_bool'. }
+
+ repeat liRStep.
+
+ Unshelve. all: unshelve_sidecond; sidecond_hook.
+ Unshelve. all: prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
+Qed.
diff --git a/theories/rust_typing/tests.v b/theories/rust_typing/tests.v
new file mode 100644
index 0000000000000000000000000000000000000000..a575e7d3243c89133d95339f402e08559f7d8489
--- /dev/null
+++ b/theories/rust_typing/tests.v
@@ -0,0 +1,1075 @@
+From refinedrust Require Export type.
+From refinedrust Require Import alias_ptr existentials.
+From refinedrust Require Import int programs program_rules functions uninit references products automation.
+From refinedrust Require Import enum.
+Set Default Proof Using "Type".
+
+(** * Test cases for sidecondition solvers declared in [automation/solvers.v] *)
+
+(** compute_map_lookup *)
+Section test.
+ Context `{!typeGS Σ}.
+
+ Lemma test_compute_map_lookup_1 (M : gmap string lft) (κ : lft) :
+ M = <[ "lft1" := κ]> $ ∅ →
+ M !! "lft1" = Some κ.
+ Proof.
+ intros ->.
+ solve_compute_map_lookup; solve[fail].
+ Abort.
+
+ Lemma test_compute_map_lookup_1 (M : gmap string lft) (κ : lft) :
+ M = (named_lft_update "lft1" κ) ∅ →
+ M !! "lft1" = Some κ.
+ Proof.
+ intros ->.
+ solve_compute_map_lookup; solve[fail].
+ Abort.
+
+ Lemma test_compute_map_lookup_2 (M : gmap string lft) (κ : lft) :
+ M = <[ "lft1" := κ]> $ ∅ →
+ ∃ κ', M !! "lft1" = Some κ'.
+ Proof.
+ intros ->. eexists _.
+ solve_compute_map_lookup; solve[fail].
+ Abort.
+
+ Lemma test_compute_map_lookup_3 M (κ : lft) :
+ M = <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (compute_map_lookup_goal M "lft1") (λ v,
+ ⌜v = Some κ⌠∗ True).
+ Proof.
+ intros ->.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Abort.
+
+ Lemma test_compute_map_lookup_3 M (κ : lft) :
+ M = named_lft_update "lft1" κ ∅ →
+ ⊢@{iPropI Σ} li_tactic (compute_map_lookup_goal M "lft1") (λ v,
+ ⌜v = Some κ⌠∗ True).
+ Proof.
+ intros ->.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Abort.
+
+ Lemma test_compute_map_lookup_4 M (κ κ' : lft) :
+ M = <["lft2" := κ']> $ <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (compute_map_lookup_nofail_goal M "lft1") (λ v,
+ ⌜v = κ⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Abort.
+
+ Lemma test_compute_map_lookup_5 M (κ : lft) :
+ M = <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (compute_map_lookup_goal M "lft2") (λ v,
+ ⌜v = None⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Abort.
+
+ Lemma test (M : gmap string lft) (κ1 κ2 : lft) :
+ M = (<["κ1" := κ1]> $ <["κ2" := κ2]> $ ∅) →
+ ∃ ls, Forall2 (λ k v, M !! k = Some v) ["κ1"; "κ2"] ls ∧ ls = [κ1; κ2].
+ Proof.
+ intros ->. eexists. split; first compute_map_lookups. done.
+ Abort.
+
+ Lemma test κ ulft__ :
+ ⊢@{iPropI Σ} li_tactic (compute_map_lookup_goal (named_lft_update "plft17" κ (named_lft_update "plft12" κ (named_lft_update "llft6" κ (named_lft_update "plft11" ulft__ (named_lft_update "ulft__" ulft__ ∅))))) "llft6") (λ v,
+ ⌜v = Some κ⌠∗ True).
+ Proof.
+ iStartProof.
+ unshelve (repeat liRStep); solve[fail].
+ Abort.
+End test.
+
+(** simplify_gmap *)
+Section test.
+ Context `{!typeGS Σ}.
+
+ Lemma test_simplify_gmap_1 (M : gmap string lft) (κ : lft) :
+ M = <[ "lft1" := κ]> $ ∅ →
+ ∃ M', M' = delete "lft1" M.
+ Proof.
+ intros ->.
+ eexists _.
+ unshelve solve_simplify_gmap; solve[fail].
+ Qed.
+
+ Lemma test_simplify_lft_map_1 (M : gmap string lft) (κ : lft) :
+ M = named_lft_update "lft1" κ $ ∅ →
+ ∃ M', opaque_eq M' (named_lft_delete "lft1" M).
+ Proof.
+ intros ->.
+ eexists _.
+ unshelve solve_simplify_lft_map; solve[fail].
+ Qed.
+
+ Lemma test_simplify_gmap_2 (M : gmap string lft) (κ κ' : lft) :
+ M = <["lft2" := κ']> $ <[ "lft1" := κ]> $ ∅ →
+ ∃ M', delete "lft1" M = M'.
+ Proof.
+ intros ->.
+ eexists _.
+ unshelve solve_simplify_gmap; solve[fail].
+ Qed.
+
+ Lemma test_simplify_gmap_3 M (κ κ' : lft) :
+ M = <["lft2" := κ']> $ <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (simplify_gmap_goal M) (λ M',
+ ⌜M' = M⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+
+ Lemma test_simplify_lft_map_3 M (κ κ' : lft) :
+ M = (named_lft_update "lft2" κ' (named_lft_update "lft1" κ ∅)) →
+ ⊢@{iPropI Σ} li_tactic (simplify_lft_map_goal M) (λ M',
+ ⌜M' = M⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+
+ Lemma test_simplify_gmap_4 M (κ κ' : lft) :
+ M = <["lft2" := κ']> $ <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (simplify_gmap_goal (delete "lft1" M)) (λ M',
+ ⌜M' = <["lft2" := κ']> $ ∅⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+
+ (* for overwriting, we should first explicitly delete the old entry *)
+ Lemma test_simplify_gmap_5 M (κ κ' : lft) :
+ M = <["lft2" := κ']> $ <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (simplify_gmap_goal (<["lft1" := κ']> $ delete "lft1" M)) (λ M',
+ ⌜M' = <["lft1" := κ']> $ <["lft2" := κ']> $ ∅⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+
+ Lemma test_simplify_gmap_6 M (κ κ' : lft) :
+ M = <["lft2" := κ']> $ <[ "lft1" := κ]> $ ∅ →
+ ⊢@{iPropI Σ} li_tactic (simplify_gmap_goal (delete "lft3" M)) (λ M',
+ ⌜M' = <["lft2" := κ']> $ <["lft1" := κ]> $ ∅⌠∗ True).
+ Proof.
+ liRStep.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+
+ Lemma test_simplify_gmap_7 (ulft__ : lft) :
+ ⊢@{iPropI Σ} li_tactic (simplify_gmap_goal (<["plft4":=ulft__]> (delete "plft4" (<["ulft__":=ulft__]> ∅)))) (λ M',
+ ⌜M' = <["plft4":=ulft__]> (<["ulft__":=ulft__]> ∅)⌠∗ True).
+ Proof.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+
+ Lemma test_simplify_lft_names1 ulft__ κ :
+ ⊢@{iPropI Σ} li_tactic (simplify_lft_map_goal (named_lft_update "plft17" κ (named_lft_delete "plft17" (named_lft_update "plft12" κ (named_lft_update "llft6" κ (named_lft_update "plft11" ulft__ ((named_lft_update "ulft__" ulft__ ∅))))))))
+ (λ M',
+ ⌜M' = (named_lft_update "plft17" κ ((named_lft_update "plft12" κ (named_lft_update "llft6" κ (named_lft_update "plft11" ulft__ ((named_lft_update "ulft__" ulft__ ∅)))))))⌠∗ True).
+ Proof.
+ iStartProof. unshelve (repeat liRStep); solve[fail].
+ Qed.
+End test.
+
+(** inv_layout_alg *)
+Section test.
+ Context `{LayoutAlg}.
+ Context (T_st : syn_type).
+
+ (** Struct tests *)
+ Definition s1_spec :=
+ mk_sls "s1_T" [("s1_f1", T_st); ("s1_f2", IntSynType i32)].
+ Definition s2_spec :=
+ mk_sls "s2_T" [("s2_f1", PtrSynType); ("s2_f2", s1_spec : syn_type)].
+
+ Lemma inv_test' s2_ly :
+ use_struct_layout_alg s2_spec = Some s2_ly →
+ ∃ s2_sl : struct_layout, s2_ly = s2_sl ∧
+ ∃ s1_sl : struct_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ sl_has_members s1_sl [("s1_f1", T_ly); ("s1_f2", (it_layout i32))] ∧
+ sl_has_members s2_sl [("s2_f1", void*); ("s2_f2", (layout_of s1_sl))].
+ Proof.
+ intros Hly.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+
+ Lemma inv_test s2_ly :
+ use_layout_alg s2_spec = Some s2_ly →
+ ∃ s2_sl : struct_layout, s2_ly = layout_of s2_sl ∧
+ ∃ s1_sl : struct_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ sl_has_members s1_sl [("s1_f1", T_ly); ("s1_f2", (it_layout i32))] ∧
+ sl_has_members s2_sl [("s2_f1", void*); ("s2_f2", (layout_of s1_sl))].
+ Proof.
+ intros Hly.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+
+ Lemma inv_test3 :
+ syn_type_is_layoutable (s2_spec) →
+ ∃ s2_sl : struct_layout,
+ ∃ s1_sl : struct_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ sl_has_members s1_sl [("s1_f1", T_ly); ("s1_f2", (it_layout i32))] ∧
+ sl_has_members s2_sl [("s2_f1", void*); ("s2_f2", (layout_of s1_sl))].
+ Proof.
+ intros Hly. inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+
+ Lemma inv_test4 len :
+ syn_type_is_layoutable (ArraySynType T_st len) →
+ syn_type_is_layoutable T_st.
+ Proof.
+ intros Hly. inv_layout_alg.
+ solve_layout_alg; solve[fail].
+ Abort.
+
+ Lemma inv_test5 {rt} (T_ty : type rt) (xs : list nat) ly :
+ T_st = ty_syn_type T_ty →
+ use_layout_alg (ArraySynType (ty_syn_type T_ty) (length xs)) = Some ly →
+ syn_type_is_layoutable (T_st).
+ Proof.
+ intros ? H1. inv_layout_alg.
+ solve_layout_alg; solve[fail].
+ Abort.
+
+ (** Union tests *)
+ Definition u1_spec :=
+ mk_uls "u1_T" [("u1_v1", T_st); ("u1_v2", IntSynType i32)].
+ Definition u2_spec :=
+ mk_uls "u2_T" [("u2_v1", PtrSynType); ("u2_v2", u1_spec : syn_type)].
+
+ Lemma inv_test' u2_ly :
+ use_union_layout_alg u2_spec = Some u2_ly →
+ ∃ u2_ul : union_layout, u2_ly = u2_ul ∧
+ ∃ u1_ul : union_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ ul_has_variants u1_ul [("u1_v1", T_ly); ("u1_v2", (it_layout i32))] ∧
+ ul_has_variants u2_ul [("u2_v1", void*); ("u2_v2", (ul_layout u1_ul))].
+ Proof.
+ intros Hly.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+
+ Lemma inv_test u2_ly :
+ use_layout_alg u2_spec = Some u2_ly →
+ ∃ u2_ul : union_layout, u2_ly = ul_layout u2_ul ∧
+ ∃ u1_ul : union_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ ul_has_variants u1_ul [("u1_v1", T_ly); ("u1_v2", (it_layout i32))] ∧
+ ul_has_variants u2_ul [("u2_v1", void*); ("u2_v2", (ul_layout u1_ul))].
+ Proof.
+ intros Hly.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+
+ Lemma inv_test3 :
+ syn_type_is_layoutable (u2_spec) →
+ ∃ u2_ul : union_layout,
+ ∃ u1_ul : union_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ ul_has_variants u1_ul [("u1_v1", T_ly); ("u1_v2", (it_layout i32))] ∧
+ ul_has_variants u2_ul [("u2_v1", void*); ("u2_v2", (ul_layout u1_ul))].
+ Proof.
+ intros Hly. inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+
+ (** Enums *)
+ Definition std_option_Option_None_sls : struct_layout_spec := mk_sls "std_option_Option_None" [].
+ Definition std_option_Option_Some_sls : struct_layout_spec := mk_sls "std_option_Option_Some" [
+ ("0", T_st)].
+ Program Definition std_option_Option_els : enum_layout_spec := mk_els "std_option_Option" ISize [
+ ("None", std_option_Option_None_sls : syn_type);
+ ("Some", std_option_Option_Some_sls : syn_type)] [("None", 0); ("Some", 1)].
+
+ Lemma inv_test e_ly :
+ use_enum_layout_alg std_option_Option_els = Some e_ly →
+ enum_layout_spec_is_layoutable std_option_Option_els.
+ Proof.
+ intros.
+ inv_layout_alg.
+ (* TODO why doesn't this work*)
+ (*solve_layout_alg.*)
+ Abort.
+
+ (** Untyped *)
+ Lemma inv_test2 ily :
+ use_layout_alg (UntypedSynType (it_layout i32)) = Some ily →
+ ily = it_layout i32.
+ Proof.
+ intros Hly. inv_layout_alg. reflexivity.
+ Abort.
+
+ (* Regression test: this should not diverge, ensured by the [DONT_ENRICH] markers we place in simplification *)
+ Lemma inv_test3 U_st :
+ syn_type_is_layoutable T_st →
+ syn_type_is_layoutable U_st →
+ True.
+ Proof.
+ intros.
+ timeout 4 (intros; inv_layout_alg).
+ Abort.
+
+ (* Regression test: having the same assumption twice should not break anything. *)
+ Lemma inv_test5 T_ly1 T_ly2 :
+ syn_type_has_layout T_st T_ly1 →
+ syn_type_has_layout T_st T_ly2 →
+ T_ly1 = T_ly2.
+ Proof.
+ intros ??.
+ inv_layout_alg.
+ reflexivity.
+ Abort.
+ Lemma inv_test4 :
+ syn_type_is_layoutable (s2_spec) →
+ syn_type_is_layoutable (s1_spec) →
+ ∃ s2_sl : struct_layout,
+ ∃ s1_sl : struct_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ sl_has_members s1_sl [("s1_f1", T_ly); ("s1_f2", (it_layout i32))] ∧
+ sl_has_members s2_sl [("s2_f1", void*); ("s2_f2", (layout_of s1_sl))].
+ Proof.
+ intros ? ?.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+ Lemma inv_test4' :
+ syn_type_is_layoutable (s1_spec) →
+ syn_type_is_layoutable (s2_spec) →
+ ∃ s2_sl : struct_layout,
+ ∃ s1_sl : struct_layout,
+ ∃ T_ly, syn_type_has_layout T_st T_ly ∧
+ sl_has_members s1_sl [("s1_f1", T_ly); ("s1_f2", (it_layout i32))] ∧
+ sl_has_members s2_sl [("s2_f1", void*); ("s2_f2", (layout_of s1_sl))].
+ Proof.
+ intros ? ?.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+End test.
+
+Section test.
+ Lemma inv_test `{!typeGS Σ} {rt} (T : type rt) s2_ly :
+ use_layout_alg (s2_spec (ty_syn_type T)) = Some s2_ly →
+ use_layout_alg (s2_spec (ty_syn_type T)) = Some s2_ly →
+ ∃ s2_sl : struct_layout, s2_ly = layout_of s2_sl ∧
+ ∃ s1_sl : struct_layout,
+ ∃ T_ly, syn_type_has_layout (ty_syn_type T) T_ly ∧
+ sl_has_members s1_sl [("s1_f1", T_ly); ("s1_f2", (it_layout i32))] ∧
+ sl_has_members s2_sl [("s2_f1", void*); ("s2_f2", (layout_of s1_sl))].
+ Proof.
+ intros Hly.
+ inv_layout_alg.
+ intros Ha.
+ inv_layout_alg.
+ eauto 10; solve[fail].
+ Abort.
+End test.
+
+(** layout solver *)
+Section test.
+ Context `{!typeGS Σ}.
+ Context (T_st : syn_type).
+
+ Lemma solve_layout_size_test1 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ ly_size T_ly * 42 ≤ ly_size (mk_array_layout T_ly 42).
+ Proof.
+ intros. solve_layout_size; solve[fail].
+ Abort.
+
+ Lemma solve_layout_size_test2 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ (size_of_st T_st * 43 ≤ max_int isize_t)%Z →
+ ly_size (use_layout_alg' (ArraySynType T_st 42)) ≤ ly_size (use_layout_alg' (ArraySynType T_st 43)).
+ Proof.
+ intros. solve_layout_size; solve[fail].
+ Abort.
+
+ Lemma solve_layout_size_test3 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ size_of_st (UntypedSynType (use_layout_alg' T_st)) = ly_size T_ly.
+ Proof.
+ intros. solve_layout_size; solve [fail].
+ Abort.
+
+ Lemma solve_layout_size_test4 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ (size_of_st T_st * 43 ≤ max_int isize_t)%Z →
+ size_of_st T_st > 0 →
+ ly_size (use_layout_alg' (ArraySynType T_st 42)) < ly_size (use_layout_alg' (ArraySynType T_st 43)).
+ Proof.
+ intros. solve_layout_size; solve[fail].
+ Abort.
+
+ Lemma solve_layout_alg_test1 :
+ use_layout_alg (IntSynType u16) = Some (it_layout u16).
+ Proof.
+ solve_layout_alg; solve [fail].
+ Abort.
+
+ Lemma solve_layout_alg_test1 s2_ly :
+ use_layout_alg (s2_spec T_st) = Some s2_ly →
+ syn_type_has_layout (s2_spec T_st) s2_ly.
+ Proof.
+ intros. inv_layout_alg.
+ solve_layout_alg; solve [fail].
+ Abort.
+
+ Lemma solve_layout_alg_test2 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ (ly_size T_ly * 42 ≤ max_int isize_t)%Z →
+ syn_type_has_layout (ArraySynType T_st 42) (mk_array_layout T_ly 42).
+ Proof.
+ intros. solve_layout_alg; solve [fail].
+ Abort.
+
+ Lemma solve_layout_alg_test2' T_ly size :
+ use_layout_alg T_st = Some T_ly →
+ (ly_size T_ly * Z.to_nat size ≤ max_int isize_t)%Z →
+ ∃ ly, syn_type_has_layout (ArraySynType T_st (Z.to_nat size)) ly.
+ Proof.
+ intros. eexists.
+ solve_layout_alg.
+ Abort.
+
+ Lemma solve_layout_alg_test3 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ syn_type_has_layout (UntypedSynType (use_layout_alg' T_st)) T_ly.
+ Proof.
+ intros. solve_layout_alg; solve [fail].
+ Abort.
+
+ Lemma solve_layout_alg_test4 T_ly :
+ use_layout_alg T_st = Some T_ly →
+ ∃ ly, syn_type_has_layout (UntypedSynType (use_layout_alg' T_st)) ly.
+ Proof.
+ intros. eexists. solve_layout_alg; solve[fail].
+ Abort.
+
+ Lemma solve_layout_alg_test5 s2_ly :
+ use_layout_alg (s2_spec T_st) = Some s2_ly →
+ ∃ s2_sl, struct_layout_spec_has_layout (s2_spec T_st) s2_sl.
+ Proof.
+ intros. inv_layout_alg.
+ eexists. solve_layout_alg; solve[fail].
+ Abort.
+
+ Lemma solve_layout_alg_test6 s2_ly :
+ use_layout_alg (s2_spec T_st) = Some s2_ly →
+ syn_type_has_layout (s2_spec T_st) (use_layout_alg' (s2_spec T_st)).
+ Proof.
+ intros. inv_layout_alg.
+ solve_layout_alg; solve[fail].
+ Abort.
+
+ Lemma solve_layout_alg_test7 s2_ly :
+ use_layout_alg (s2_spec T_st) = Some s2_ly →
+ struct_layout_spec_has_layout (s2_spec T_st) (use_struct_layout_alg' (s2_spec T_st)).
+ Proof.
+ intros. inv_layout_alg.
+ solve_layout_alg; solve[fail].
+ Abort.
+
+ Lemma solve_layout_alg_test8 {T_rt} (T_ty : type T_rt) T_ly :
+ syn_type_has_layout (ty_syn_type T_ty) T_ly →
+ syn_type_has_layout (ty_syn_type T_ty) (use_layout_alg' (ty_syn_type T_ty)).
+ Proof.
+ intros. inv_layout_alg.
+ solve_layout_alg; solve[fail].
+ Abort.
+
+ Lemma solve_layout_alg_test9 s2_ly :
+ use_layout_alg (s2_spec T_st) = Some s2_ly →
+ syn_type_is_layoutable (UntypedSynType (use_layout_alg' (s2_spec T_st))).
+ Proof.
+ intros. inv_layout_alg.
+ solve_layout_alg; solve [fail].
+ Abort.
+
+ Lemma solve_layout_alg_test10 ly :
+ use_layout_alg (std_option_Option_els T_st) = Some ly →
+ syn_type_is_layoutable (std_option_Option_els T_st).
+ Proof.
+ intros. inv_layout_alg.
+ solve_layout_alg; solve[fail].
+ Abort.
+End test.
+
+(** solve_op_alg *)
+Section test.
+ Context `{!typeGS Σ}.
+
+ Lemma solve_op_alg_test1 :
+ use_op_alg (IntSynType u16) = Some (IntOp $ u16).
+ Proof.
+ solve_op_alg; solve [fail].
+ Abort.
+
+ Lemma solve_op_alg_test1 T_st :
+ syn_type_is_layoutable T_st →
+ use_op_alg T_st = Some (use_op_alg' T_st).
+ Proof.
+ intros; inv_layout_alg.
+ solve_op_alg; solve [fail].
+ Abort.
+
+ Lemma solve_op_alg_test1 T_st s2_sl s1_sl :
+ use_struct_layout_alg (s2_spec T_st) = Some s2_sl →
+ use_struct_layout_alg (s1_spec T_st) = Some s1_sl →
+ use_op_alg (s2_spec T_st) = Some (StructOp s2_sl [PtrOp; StructOp s1_sl [use_op_alg' T_st; IntOp i32]]).
+ Proof.
+ intros. inv_layout_alg.
+ solve_op_alg; solve [fail].
+ Abort.
+
+ Lemma solve_op_alg_test3 T_st T_ly :
+ use_layout_alg T_st = Some T_ly →
+ use_op_alg (UntypedSynType (use_layout_alg' T_st)) = Some $ UntypedOp T_ly.
+ Proof.
+ intros. solve_op_alg; solve [fail].
+ Abort.
+
+ Lemma solve_op_alg_test4 T_st T_ly :
+ use_layout_alg T_st = Some T_ly →
+ ∃ ot, use_op_alg (UntypedSynType (use_layout_alg' T_st)) = Some ot.
+ Proof.
+ intros. eexists. solve_op_alg; solve[fail].
+ Abort.
+
+ Lemma solve_op_alg_test5 {T_rt} (T_ty : type T_rt) T_ly :
+ syn_type_has_layout (ty_syn_type T_ty) T_ly →
+ use_op_alg (ty_syn_type T_ty) = Some (use_op_alg' (ty_syn_type T_ty)).
+ Proof.
+ intros. inv_layout_alg.
+ solve_op_alg; solve[fail].
+ Abort.
+
+ Lemma solve_op_alg_test6 :
+ use_op_alg' (IntSynType i32) = IntOp i32.
+ Proof.
+ intros. inv_layout_alg.
+ solve_op_alg; solve[fail].
+ Abort.
+End test.
+
+(** solve_interpret_rust_type *)
+Section test.
+ Context `{!typeGS Σ}.
+
+ Context (testX : ∀ `{!typeGS Σ} {rt} (ty : type rt), type rt).
+
+ (* TODO: better error handling in the tactic above.
+ Somehow the Ltac2 exceptions get gobbled up and just a no match error is raised... *)
+ Lemma interpret_rust_type_test0 {rt} (T_ty : type rt) κ :
+ ∃ ty, interpret_rust_type_pure_goal (<["κ" := κ]> ∅) (RSTLitType ["testX"] [RSTInt I32]) ty ∧ ty = testX _ _ (int i32).
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ eexists _; split; [ solve_interpret_rust_type | ]. done.
+ Abort.
+
+ Lemma interpret_rust_type_test1 {rt} (T_ty : type rt) :
+ ∃ rt2 (ty2 : type rt2), interpret_rust_type_pure_goal (∅) (RSTInt I32) ty2.
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ eexists _, _. solve_interpret_rust_type; solve[fail].
+ Abort.
+
+ Lemma interpret_rust_type_test1 {rt} (T_ty : type rt) :
+ interpret_rust_type_pure_goal (∅) (RSTTyVar "T") T_ty.
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ solve_interpret_rust_type; solve[fail].
+ Abort.
+
+ Lemma interpret_rust_type_test2 {rt} (T_ty : type rt) :
+ interpret_rust_type_pure_goal (∅) (RSTInt I32) (int i32).
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ solve_interpret_rust_type; solve[fail].
+ Abort.
+
+ Lemma interpret_rust_type_test3 {rt} (T_ty : type rt) sls :
+ interpret_rust_type_pure_goal (∅) (RSTStruct sls [RSTInt I32]) (struct_t sls +[int i32]).
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ solve_interpret_rust_type; solve[fail].
+ Abort.
+
+ Lemma interpret_rust_type_test4 {rt} (T_ty : type rt) κ :
+ ∃ ty, interpret_rust_type_pure_goal (<["κ" := κ]> ∅) (RSTRef Mut "κ" (RSTInt I32)) ty ∧ ty = (mut_ref (int i32) κ).
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ eexists _; split; [solve_interpret_rust_type | ]. done.
+ Abort.
+
+ (*
+ Import enum_test.
+ Lemma bla {rt} (T_ty : type rt) ulft__ :
+ ∃ ty, interpret_rust_type_pure_goal (named_lft_update "plft5" ulft__ (named_lft_update "ulft__" ulft__ ∅)) (RSTLitType ["std_option_Option_ty"] [RSTTyVar "T"]) ty ∧ ty = std_option_Option_ty T_ty.
+ Proof.
+ init_tyvars (<["T" := (existT _ T_ty)]> ∅).
+ eexists _. split. { solve_interpret_rust_type. } done.
+ Abort.
+ *)
+End test.
+
+(** solve_lft_incl *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 E κ κ' κ'' c1 c2 :
+ lctx_lft_incl E [κ ⊑ₗ{c1} [κ'; κ]; κ' ⊑ₗ{c2} [κ'']] (κ) (κ'').
+ Proof.
+ solve_lft_incl; solve[fail].
+ Abort.
+
+ Lemma test2 κ κ' :
+ lctx_lft_incl [κ' ⊑ₑ κ'; κ ⊑ₑ κ'] [] κ κ'.
+ Proof.
+ solve_lft_incl; solve[fail].
+ Abort.
+
+ Lemma test2' {rt} (T : type rt) κ κ' :
+ lctx_lft_incl (ty_wf_E T ++ [κ' ⊑ₑ κ'; κ ⊑ₑ κ']) [] κ κ'.
+ Proof.
+ solve_lft_incl; solve[fail].
+ Abort.
+
+ Lemma test3 E L κ :
+ lctx_lft_incl E L κ κ.
+ Proof.
+ solve_lft_incl; solve[fail].
+ Abort.
+
+ Lemma test4 E κ κ' κ'' c2 :
+ lctx_lft_incl E [κ ≡ₗ [κ'; κ]; κ' ⊑ₗ{c2} [κ'']] (κ) (κ'').
+ Proof.
+ solve_lft_incl; solve[fail].
+ Abort.
+
+ Lemma test5 Ï0 Ï ulft_a :
+ lctx_lft_incl_list [Ï0 ⊑ₑ Ï; Ï âŠ‘â‚‘ ulft_a] [Ï âŠ‘â‚—{ 0} []] [Ï0] [ulft_a].
+ Proof.
+ solve_lft_incl_list; solve[fail].
+ Abort.
+
+ Lemma test6 E κ κ' κ'' c2 :
+ lctx_lft_incl E [κ ≡ₗ [κ']; κ' ⊑ₗ{c2} [κ'']] (κ') (κ).
+ Proof.
+ solve_lft_incl; solve[fail].
+ Abort.
+End test.
+
+(** solve_lft_alive *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 κ κ' c1 c2 :
+ lctx_lft_alive [] [κ ⊑ₗ{c1} [κ']; κ' ⊑ₗ{c2} []] κ.
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+
+ Lemma test2 κ κ' Ï c :
+ lctx_lft_alive [κ ⊑ₑ κ'; Ï âŠ‘â‚‘ κ] [Ï âŠ‘â‚—{c} []] κ'.
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+
+ Lemma test3 κ κ' κ'' Ï c1 c2 :
+ lctx_lft_alive [κ ⊑ₑ κ'; Ï âŠ‘â‚‘ κ ] [Ï âŠ‘â‚—{c1} []; κ'' ⊑ₗ{c2} [κ'; Ï]] κ''.
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+
+ Lemma test3 κ κ' κ'' Ï c1 :
+ lctx_lft_alive [κ ⊑ₑ κ'; Ï âŠ‘â‚‘ κ ] [Ï âŠ‘â‚—{c1} []; κ'' ≡ₗ [κ'; Ï]] κ''.
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+
+ (* needs backtracking *)
+ Lemma test3 κ κ' Ï c1 :
+ lctx_lft_alive [κ' ⊑ₑ κ; Ï âŠ‘â‚‘ κ] [Ï âŠ‘â‚—{c1} []] κ.
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+
+ Lemma test4 κ κ' c1 c2 :
+ lctx_lft_alive [] [κ ⊑ₗ{c1} [κ']; κ' ⊑ₗ{c2} []] (κ ⊓ κ).
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+
+ Lemma test5 κ c1 :
+ Forall (lctx_lft_alive [] [κ ⊑ₗ{c1} []]) [κ; κ].
+ Proof.
+ solve_lft_alive; solve[fail].
+ Abort.
+End test.
+
+(** simplify_elctx *)
+Section test.
+
+ Section RawVec_sls.
+ Context `{!typeGS Σ}.
+
+ Definition RawVec_sls (T_st : syn_type) : struct_layout_spec := mk_sls "RawVec" [
+ ("ptr", PtrSynType);
+ ("cap", IntSynType USize);
+ ("_marker", UnitSynType)].
+ End RawVec_sls.
+ Section Vec_sls.
+ Context `{!typeGS Σ}.
+
+ Definition Vec_sls (T_st : syn_type) : struct_layout_spec := mk_sls "Vec" [
+ ("buf", (syn_type_of_sls ((RawVec_sls (T_st)))));
+ ("len", IntSynType USize)].
+ End Vec_sls.
+ Section RawVec_ty.
+ Context `{!typeGS Σ}.
+ Context {T_rt : Type}.
+ Context (T_ty : type (T_rt)).
+
+ Definition RawVec_ty : type (plist place_rfn [_ : Type; Z : Type; unit : Type]) := struct_t (RawVec_sls (ty_syn_type T_ty)) +[
+ alias_ptr_t;
+ (int USize);
+ unit_t].
+ Definition RawVec_rt : Type := Eval hnf in rt_of RawVec_ty.
+ Global Typeclasses Transparent RawVec_ty.
+ End RawVec_ty.
+
+ Section RawVec_inv_t.
+ Context `{!typeGS Σ}.
+ Context {T_rt : Type}.
+ Context (T_ty : type (T_rt)).
+
+ Program Definition RawVec_inv_t_inv_spec : ex_inv_def ((RawVec_rt)) ((loc * nat)) := mk_ex_inv_def
+ (λ π inner_rfn '(l, cap) , ⌜inner_rfn = (-[#(l); #(Z.of_nat cap); #(tt)])⌠∗ True)%I
+ (λ π κ inner_rfn '(l, cap), ⌜inner_rfn = -[#(l); #(Z.of_nat cap); #(tt)]⌠∗ True)%I
+ ([])
+ ([])
+ _ _ _
+ .
+ Next Obligation. ex_t_solve_persistent. Qed.
+ Next Obligation.
+ ex_plain_t_solve_shr_mono.
+ Qed.
+ Next Obligation.
+ ex_plain_t_solve_shr.
+ Qed.
+
+ Definition RawVec_inv_t : type ((loc * nat)) :=
+ ex_plain_t _ _ RawVec_inv_t_inv_spec (RawVec_ty T_ty).
+ End RawVec_inv_t.
+
+ Section Vec_ty.
+ Context `{!typeGS Σ}.
+ Context {T_rt : Type}.
+ Context (T_ty : type (T_rt)).
+
+ Definition Vec_ty : type (plist place_rfn [_ : Type; Z : Type]) := struct_t (Vec_sls (ty_syn_type T_ty)) +[
+ (RawVec_inv_t (T_ty));
+ (int USize)].
+ Definition Vec_rt : Type := Eval hnf in rt_of Vec_ty.
+ Global Typeclasses Transparent Vec_ty.
+ End Vec_ty.
+
+ Section Vec_inv_t.
+ Context `{!typeGS Σ}.
+ Context {T_rt : Type}.
+ Context (T_ty : type (T_rt)).
+
+ Program Definition Vec_inv_t_inv_spec : ex_inv_def ((Vec_rt)) (list (place_rfn T_rt)) := mk_ex_inv_def
+ (λ π inner_rfn 'xs, ∃ (cap : nat) (l : loc), ⌜inner_rfn = -[#((l, cap)); #(Z.of_nat $ length xs)]⌠∗ ⌜length xs ≤ cap⌠∗ True)%I
+ (λ π κ inner_rfn 'xs, ∃ (cap : nat) (l : loc), ⌜inner_rfn = -[#((l, cap)); #(Z.of_nat $ length xs)]⌠∗ ⌜length xs ≤ cap⌠∗ True)%I
+ ([] ++ (ty_lfts T_ty))
+ ([] ++ (ty_wf_E T_ty))
+ _ _ _
+ .
+ Next Obligation.
+ ex_t_solve_persistent.
+ Qed.
+ Next Obligation.
+ ex_plain_t_solve_shr_mono.
+ Qed.
+ Next Obligation.
+ ex_plain_t_solve_shr.
+ Qed.
+
+ Definition Vec_inv_t : type (list (place_rfn T_rt)) :=
+ ex_plain_t _ _ Vec_inv_t_inv_spec (Vec_ty T_ty).
+ Hint Unfold Vec_inv_t : tyunfold.
+ End Vec_inv_t.
+
+ Lemma test1 `{!typeGS Σ} {T_rt} (T_ty : type T_rt) xs γ x ulft__ Ï : ∃ E',
+ ([] ++
+ tyl_wf_E
+ (map map_rtype
+ [existT (place_rfn (list (place_rfn T_rt)) * gname)%type
+ (mut_ref (Vec_inv_t T_ty) ulft__, (# xs, γ));
+ existT T_rt (T_ty, x)]) ++
+ tyl_outlives_E
+ (map map_rtype
+ [existT (place_rfn (list (place_rfn T_rt)) * gname)%type
+ (mut_ref (Vec_inv_t T_ty) ulft__, (# xs, γ));
+ existT T_rt (T_ty, x)]) Ï ++ ty_wf_E unit_t ++ ty_outlives_E unit_t Ï) = E' ∧ E' = E'.
+ Proof.
+ eexists.
+ split; [solve simplify_elctx | done].
+ Abort.
+End test.
+
+(** reorder_elctx *)
+Section test.
+ Context `{!typeGS Σ}.
+
+ Lemma test1 E0 E1 κ1 κ2 :
+ ∃ K0, (κ1 ⊑ₑ κ2) :: E0 ++ (κ2 ⊑ₑ κ1) :: E1 ≡ₚ K0 ∧ K0 = (κ1 ⊑ₑ κ2) :: (κ2 ⊑ₑ κ1) :: E0 ++ E1.
+ Proof.
+ eexists _. split.
+ { reorder_elctx. }
+ done.
+ Abort.
+
+ Lemma test1 E0 E1 κ1 κ2 :
+ ∃ K0, (κ1 ⊑ₑ κ2) :: E0 ++ E1 ++ [κ2 ⊑ₑ κ1] ≡ₚ K0 ∧ K0 = (κ1 ⊑ₑ κ2) :: (κ2 ⊑ₑ κ1) :: E0 ++ E1.
+ Proof.
+ eexists _. split.
+ { reorder_elctx. }
+ done.
+ Abort.
+End test.
+
+
+
+(** solve_elctx_sat *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 κ κ' :
+ elctx_sat [κ ⊑ₑ κ'] [] [κ ⊑ₑ κ'; κ ⊑ₑ κ'].
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+ Lemma test2 κ κ' κ'' c1 :
+ elctx_sat [κ ⊑ₑ κ'] [κ' ⊑ₗ{c1} [κ'']] [κ ⊑ₑ κ''].
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+ Lemma test3 Ï0 Ï c1 :
+ elctx_sat ((Ï0 ⊑ₑ Ï) :: ty_outlives_E (uninit (IntSynType i32)) Ï) [Ï âŠ‘â‚—{c1} []] (ty_outlives_E (uninit (IntSynType i32)) Ï).
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+ Lemma test4 Ï0 Ï :
+ elctx_sat [Ï0 ⊑ₑ Ï] [Ï âŠ‘â‚—{ 0} []] (lfts_outlives_E (ty_lfts alias_ptr_t) Ï0).
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+ Lemma test5 Ï0 Ï {rt} (T_ty : type rt) :
+ elctx_sat (ty_outlives_E (T_ty) Ï ++ (Ï0 ⊑ₑ Ï) :: ty_outlives_E (T_ty) Ï) [Ï âŠ‘â‚—{ 0} []] ((Ï âŠ‘â‚‘ Ï) :: ty_outlives_E (T_ty) Ï0).
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+ Lemma test6 Ï0 Ï {rt} (T_ty : type rt) :
+ elctx_sat ((Ï0 ⊑ₑ Ï) :: ty_wf_E (T_ty)) [Ï âŠ‘â‚—{ 0} []] ((Ï âŠ‘â‚‘ Ï) :: ty_wf_E (T_ty)).
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+ Lemma test7 Ï0 Ï {rt} (T_ty : type rt) :
+ elctx_sat ((Ï0 ⊑ₑ Ï) :: ty_outlives_E T_ty Ï ++ ty_wf_E (T_ty)) [Ï âŠ‘â‚—{ 0} []] ((Ï âŠ‘â‚‘ Ï) :: ty_wf_E (T_ty)).
+ Proof. solve_elctx_sat; solve[fail]. Abort.
+
+End test.
+
+(** solve_bor_kind_alive *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 E L :
+ lctx_bor_kind_alive E L (Owned false).
+ Proof. solve[solve_bor_kind_alive]. Abort.
+
+ Lemma test2 κ γ c1 :
+ lctx_bor_kind_alive [] [κ ⊑ₗ{c1} []] (Uniq κ γ ⊓ₖ Uniq κ γ ⊓ₖ Owned true).
+ Proof. solve [solve_bor_kind_alive]. Abort.
+
+ Lemma test3 κ κ' c1 :
+ lctx_bor_kind_alive [κ' ⊑ₑ κ] [κ' ⊑ₗ{c1} []] (Shared κ ⊓ₖ Owned false).
+ Proof. solve[solve_bor_kind_alive]. Abort.
+End test.
+
+(** solve_bor_kind_incl *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 E L :
+ lctx_bor_kind_incl E L (Owned false) (Owned true).
+ Proof. solve[solve_bor_kind_incl]. Abort.
+
+ Lemma test2 κ γ c1 :
+ lctx_bor_kind_incl [] [κ ⊑ₗ{c1} []] (Owned false ⊓ₖ Uniq κ γ) (Owned true).
+ Proof. solve[solve_bor_kind_incl]. Abort.
+
+ Lemma test3 κ γ κ' γ' c1 :
+ lctx_bor_kind_incl [κ' ⊑ₑ static] [κ ⊑ₗ{c1} [κ']] (Owned false ⊓ₖ Uniq κ γ) (Uniq κ' γ').
+ Proof. solve[solve_bor_kind_incl]. Abort.
+
+ Lemma test4 κ κ' γ' c1 :
+ lctx_bor_kind_incl [κ' ⊑ₑ static] [κ ⊑ₗ{c1} [κ']] (Shared κ ⊓ₖ Shared κ) (Shared κ ⊓ₖ Uniq κ' γ').
+ Proof. solve[solve_bor_kind_incl]. Abort.
+
+ Lemma test5 κ κ' c1 :
+ lctx_bor_kind_incl [κ' ⊑ₑ static] [κ ⊑ₗ{c1} [κ']] (Shared κ) (Shared κ' ⊓ₖ Owned false).
+ Proof. solve[solve_bor_kind_incl]. Abort.
+End test.
+
+(** solve_bor_kind_direct_incl *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 E L :
+ lctx_bor_kind_direct_incl E L (Owned false) (Owned false).
+ Proof. solve[solve_bor_kind_direct_incl]. Abort.
+
+ Lemma test2 κ γ c1 :
+ lctx_bor_kind_direct_incl [] [κ ⊑ₗ{c1} []] (Owned false ⊓ₖ Uniq κ γ) (Uniq κ γ).
+ Proof. solve[solve_bor_kind_direct_incl]. Abort.
+
+ Lemma test3 κ γ κ' c1 :
+ lctx_bor_kind_direct_incl [κ' ⊑ₑ static] [κ ⊑ₗ{c1} [κ']] (Owned false ⊓ₖ Uniq κ γ) (Uniq κ' γ).
+ Proof. solve[solve_bor_kind_direct_incl]. Abort.
+
+ Lemma test4 κ κ' γ' c1 :
+ lctx_bor_kind_direct_incl [κ' ⊑ₑ static] [κ ⊑ₗ{c1} [κ']] (Shared κ ⊓ₖ Shared κ) (Shared κ ⊓ₖ Uniq κ' γ').
+ Proof. solve[solve_bor_kind_direct_incl]. Abort.
+
+ Lemma test5 κ κ' c1 :
+ lctx_bor_kind_direct_incl [κ' ⊑ₑ static] [κ ⊑ₗ{c1} [κ']] (Shared κ) (Shared κ' ⊓ₖ Owned false).
+ Proof. solve[solve_bor_kind_direct_incl]. Abort.
+End test.
+
+(** solve_lft_alive_count *)
+Section test.
+ Context `{typeGS Σ}.
+
+ Lemma test1 κ κ' :
+ lctx_lft_alive_count [] [κ ⊑ₗ{0} [κ']; κ' ⊑ₗ{0} []] κ [κ; κ'] [κ ⊑ₗ{1} [κ']; κ' ⊑ₗ{1} []].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+
+ Lemma test2 κ κ' Ï c :
+ lctx_lft_alive_count [κ ⊑ₑ κ'; Ï âŠ‘â‚‘ κ] [Ï âŠ‘â‚—{c} []] κ' [Ï] [Ï âŠ‘â‚—{S c} []].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+
+ Lemma test3 κ κ' κ'' Ï c1 c2 :
+ lctx_lft_alive_count [κ ⊑ₑ κ'; Ï âŠ‘â‚‘ κ ] [Ï âŠ‘â‚—{c1} []; κ'' ⊑ₗ{c2} [κ'; Ï]] κ'' [κ''; Ï; Ï] [Ï âŠ‘â‚—{2+ c1} []; κ'' ⊑ₗ{S c2} [κ'; Ï]].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+
+ Lemma test3 κ κ' κ'' Ï c1 :
+ lctx_lft_alive_count [κ ⊑ₑ κ'; Ï âŠ‘â‚‘ κ ] [Ï âŠ‘â‚—{c1} []; κ'' ≡ₗ[κ'; Ï]] κ'' [Ï; Ï] [Ï âŠ‘â‚—{2+ c1} []; κ'' ≡ₗ [κ'; Ï]].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+
+ (* needs backtracking *)
+ Lemma test3 κ κ' Ï c :
+ lctx_lft_alive_count [κ' ⊑ₑ κ; Ï âŠ‘â‚‘ κ] [Ï âŠ‘â‚—{c} []] κ [Ï] [Ï âŠ‘â‚—{S c} []].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+
+ Lemma test4 κ κ' :
+ lctx_lft_alive_count [] [κ ⊑ₗ{0} [κ']; κ' ⊑ₗ{0} []] (κ ⊓ κ) [κ; κ'; κ; κ'] [κ ⊑ₗ{2} [κ']; κ' ⊑ₗ{2} []].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+
+ Lemma test5 {rt} (T_ty : type rt) ulft__ Ï :
+ lctx_lft_alive_count ((Ï âŠ‘â‚‘ ulft__) :: ty_outlives_E T_ty Ï ++ ty_outlives_E T_ty Ï ++ ty_outlives_E T_ty ulft__ ++ ty_wf_E T_ty) [Ï âŠ‘â‚—{ 0} []] ulft__ [Ï] [Ï âŠ‘â‚—{ 1} []].
+ Proof.
+ solve_lft_alive_count; solve[fail].
+ Abort.
+End test.
+
+(** solve_llctx_release_toks *)
+Section test.
+ Context `{!invGS Σ, !lctxGS Σ, !lftGS Σ lft_userE}.
+ (*Context `{typeGS Σ}.*)
+
+ Lemma test1 κ κ' :
+ llctx_release_toks [κ ⊑ₗ{1} [κ']; κ' ⊑ₗ{1} []] [κ; κ'] [κ ⊑ₗ{0} [κ']; κ' ⊑ₗ{0} []].
+ Proof.
+ solve_llctx_release_toks; solve[fail].
+ Abort.
+ Lemma test2 Ï c :
+ llctx_release_toks [Ï âŠ‘â‚—{S c} []] [Ï] [Ï âŠ‘â‚—{c} []].
+ Proof.
+ solve_llctx_release_toks; solve[fail].
+ Abort.
+ Lemma test3 κ' κ'' Ï c1 c2 :
+ llctx_release_toks [Ï âŠ‘â‚—{2+ c1} []; κ'' ⊑ₗ{S c2} [κ'; Ï]] [κ''; Ï; Ï] [Ï âŠ‘â‚—{c1} []; κ'' ⊑ₗ{c2} [κ'; Ï]].
+ Proof.
+ solve_llctx_release_toks; solve[fail].
+ Abort.
+ Lemma test3 Ï c :
+ llctx_release_toks [Ï âŠ‘â‚—{S c} []] [Ï] [Ï âŠ‘â‚—{c} []].
+ Proof.
+ solve_llctx_release_toks; solve[fail].
+ Abort.
+ Lemma test4 κ κ' :
+ llctx_release_toks [κ ⊑ₗ{2} [κ']; κ' ⊑ₗ{2} []] [κ; κ'; κ; κ'] [κ ⊑ₗ{0} [κ']; κ' ⊑ₗ{0} []].
+ Proof.
+ solve_llctx_release_toks; solve[fail].
+ Abort.
+ Lemma test5 κ κ' κ2 :
+ llctx_release_toks [κ ⊑ₗ{2} [κ']; κ' ⊑ₗ{2} []] [κ2; κ; κ'; κ; κ'; κ2] [κ ⊑ₗ{0} [κ']; κ' ⊑ₗ{0} []].
+ Proof.
+ solve_llctx_release_toks; solve[fail].
+ Abort.
+End test.
+
+
+(** solve_llctx_find_llft *)
+Section test.
+ Lemma lft_find_test (κ κ' κ2 : lft) :
+ ∃ L', llctx_find_llft [κ2 ≡ₗ []; κ ⊑ₗ{1} []; κ' ⊑ₗ{0} [κ]] κ' LlctxFindLftFull [κ] L' ∧ L' = [κ2 ≡ₗ []; κ ⊑ₗ{1} []].
+ Proof.
+ eexists. split; first solve[solve_llctx_find_llft]. done.
+ Abort.
+
+ Lemma lft_find_test2 (κ κ' κ2 : lft) :
+ ∃ L' κs, llctx_find_llft [κ2 ≡ₗ []; κ ⊑ₗ{1} []; κ' ⊑ₗ{0} [κ]] κ2 LlctxFindLftAlias κs L' ∧ κs = [].
+ Proof.
+ eexists _, _.
+ split; first solve[solve_llctx_find_llft]. done.
+ Abort.
+
+ Lemma lft_find_test3 (κ κ' κ2 : lft) :
+ ∃ L' κs, llctx_find_llft [κ2 ≡ₗ []; κ ⊑ₗ{1} []; κ' ⊑ₗ{0} [κ]] κ LlctxFindLftOwned κs L' ∧ κs = [].
+ Proof.
+ eexists _, _.
+ split; first solve[solve_llctx_find_llft]. done.
+ Abort.
+End test.
+
+(** solve_bor_kind_outlives *)
+Section test.
+ Context `{!typeGS Σ}.
+
+ Lemma lctx_bor_kind_outlives_test1 κ1 κ2 :
+ lctx_bor_kind_outlives [] [κ1 ⊑ₗ{0} [κ2]] (Shared κ2) κ1.
+ Proof.
+ solve_bor_kind_outlives; solve [fail].
+ Abort.
+End test.
diff --git a/theories/rust_typing/type.v b/theories/rust_typing/type.v
new file mode 100644
index 0000000000000000000000000000000000000000..75701629f37686f36ae6dba4b6c9b8c09df04373
--- /dev/null
+++ b/theories/rust_typing/type.v
@@ -0,0 +1,819 @@
+From iris.bi Require Export fractional.
+From iris.base_logic.lib Require Export invariants na_invariants.
+From caesium Require Export proofmode notation syntypes.
+From lrust.lifetime Require Export frac_borrow.
+From refinedrust Require Export base util pinned_borrows lft_contexts gvar_refinement memcasts.
+From caesium Require Import derived.
+From iris Require Import options.
+
+Class typeGS Σ := TypeG {
+ type_heapG :: refinedcG Σ;
+ type_lftGS :: lftGS Σ lft_userE;
+ type_na_invG :: na_invG Σ;
+ type_frac_borrowG :: frac_borG Σ;
+ type_lctxGS :: lctxGS Σ;
+ type_ghost_var :: ghost_varG Σ RT;
+ type_pinnedBorG :: pinnedBorG Σ;
+ (* we also fix a global layout algorithm here *)
+ ALG :: LayoutAlg;
+}.
+#[export] Hint Mode typeGS - : typeclass_instances.
+
+Definition rrust_ctx `{typeGS Σ} : iProp Σ := lft_ctx ∗ time_ctx ∗ llctx_ctx.
+
+Definition thread_id := na_inv_pool_name.
+
+(* The number of credits we deposit in the interpretation of Box/&mut for accessing them at a logical_step. *)
+Definition num_cred := 5%nat.
+Lemma num_cred_le `{!typeGS Σ} n :
+ (1 ≤ n)%nat →
+ num_cred ≤ num_laters_per_step n.
+Proof.
+ rewrite /num_cred/num_laters_per_step /=. lia.
+Qed.
+
+(**
+ Types are defined via ownership of values with a determined layout.
+ This encodes that types are always movable in Rust. *)
+
+(*
+What is the right way to handle sharing? One pain point are all the fancy updates and so on that we need to strip.
+This is particularly bad for mut refs: we have an alternation
+ &κ' (|==> ... |==> &pin κ (... |==> inner))
+and want to use unnesting + sharing of the inner one.
+Here, we use later credits at a logical step to get to
+ &(κ' ⊓ κ) inner
+ *)
+Record type `{!typeGS Σ} (rt : Type) := {
+ ty_own_val : thread_id → rt → val → iProp Σ;
+ ty_syn_type : syn_type;
+ (* this is formulated as a property of the semantic type, because the memcast compatibility is a semantic property *)
+ (* TODO is this the right formulation? the valid op_types should already be determined by the syn_type
+ we could require some properties that ty_has_op_type ot mt implies that ot is valid for ty_syn_type.
+ otoh, it's questionable whether we really need that.
+ *)
+ ty_has_op_type : op_type → memcast_compat_type → Prop;
+
+
+ ty_shr : lft → thread_id → rt → loc → iProp Σ;
+ (* We have a separate well-formedness predicate to capture persistent + timeless information about
+ the type's structure. Needed to evade troubles with the ltype unfolding equations. *)
+ ty_sidecond : iProp Σ;
+ (* In essence, this is a kind of "ghost-drop" that only happens at the level of the logic when a value goes out-of-scope/ is unused.)
+ Most importantly, we use it to get observations out of mutable borrows.
+ (Note that we will also need a proper "Drop" class for the drop trait, but that's different.)
+ *)
+ ty_ghost_drop : thread_id → rt → iProp Σ;
+ (* [ty_lfts] is the set of lifetimes that needs to be active for this type to make sense.*)
+ ty_lfts : list lft;
+ (* [ty_wf_E] is a set of inclusion constraints on lifetimes that need to hold for the type to make sense. *)
+ ty_wf_E : elctx;
+
+ (**
+ Note: Can we require this with a later over the ty_own_val, but no later over the layout?
+ No: we usually need timelessness to extract it, which would require an update.
+ But with this formulation, the client can still eliminate laters at updates by monotonicity of laters over wands.
+ *)
+ ty_has_layout π r v :
+ ty_own_val Ï€ r v -∗ ∃ ly : layout, ⌜syn_type_has_layout ty_syn_type ly⌠∗ ⌜v `has_layout_val` lyâŒ;
+ (* if we specify a particular op_type, its layout needs to be compatible with the underlying syntactic type *)
+ ty_op_type_stable ot mt : ty_has_op_type ot mt → syn_type_has_layout ty_syn_type (ot_layout ot);
+ ty_own_val_sidecond π r v : ty_own_val π r v -∗ ty_sidecond;
+
+ ty_shr_persistent κ π l r : Persistent (ty_shr κ π r l);
+ ty_shr_aligned κ π l r :
+ ty_shr κ Ï€ r l -∗ ∃ ly : layout, ⌜l `has_layout_loc` ly⌠∗ ⌜syn_type_has_layout ty_syn_type lyâŒ;
+
+ (* TODO possibly add a sidecondition on the refinement that the type is allowed to specify for sharing.
+ In particular, PlaceGhost is interesting. *)
+ (* TODO potentially require an interpretation for ty_wf_E as part of sharing? Then we could define ty_lfts similar to lambdarust for references, instead of also including all the nested lifetimes.
+ On the other hand, that would require establishing all these inclusions when initiating sharing.
+ *)
+ ty_share E κ l ly π r q:
+ lftE ⊆ E →
+ rrust_ctx -∗
+ (* We get a token not only for κ, but for all that we might need to recursively use to initiate sharing *)
+ let κ' := lft_intersect_list (ty_lfts) in
+ q.[κ ⊓ κ'] -∗
+ (* [l] needs to be well-layouted *)
+ ⌜syn_type_has_layout ty_syn_type ly⌠-∗
+ ⌜l `has_layout_loc` ly⌠-∗
+ loc_in_bounds l 0 (ly_size ly) -∗
+ &{κ} (∃ v, l ↦ v ∗ ty_own_val π r v) -∗
+ (* after a logical step, we can initiate sharing *)
+ logical_step E (ty_shr κ π r l ∗ q.[κ ⊓ κ']);
+
+ ty_shr_mono κ κ' tid r l :
+ κ' ⊑ κ -∗ ty_shr κ tid r l -∗ ty_shr κ' tid r l;
+
+ ty_own_ghost_drop π r v F :
+ lftE ⊆ F → ty_own_val π r v -∗ logical_step F (ty_ghost_drop π r);
+
+ (* we can transport value ownership over memcasts according to the specification by [ty_has_op_type] *)
+ ty_memcast_compat ot mt st π r v :
+ ty_has_op_type ot mt →
+ ty_own_val π r v -∗
+ match mt with
+ | MCNone => True
+ | MCCopy => ty_own_val π r (mem_cast v ot st)
+ | MCId => ⌜mem_cast_id v otâŒ
+ end;
+
+ (* TODO this would be a good property to have, but currently uninit doesn't satisfy it. *)
+ (* we require that ops at least as given by the "canonical" optype obtained by [use_op_alg] are allowed *)
+ (*ty_has_op_type_compat ot mt : *)
+ (*use_op_alg ty_syn_type = Some ot →*)
+ (*mt ≠MCId →*)
+ (*ty_has_op_type ot mt;*)
+
+ ty_sidecond_timeless : Timeless ty_sidecond;
+ ty_sidecond_persistent : Persistent ty_sidecond;
+
+}.
+Arguments ty_own_val : simpl never.
+Arguments ty_shr : simpl never.
+#[export] Existing Instance ty_shr_persistent.
+#[export] Existing Instance ty_sidecond_timeless.
+#[export] Existing Instance ty_sidecond_persistent.
+
+Arguments ty_own_val {_ _ _}.
+Arguments ty_sidecond {_ _ _}.
+Arguments ty_has_op_type {_ _ _}.
+Arguments ty_syn_type {_ _ _}.
+(*Arguments ty_layout {_ _ _}.*)
+Arguments ty_shr {_ _ _}.
+Arguments ty_ghost_drop {_ _ _}.
+Arguments ty_lfts {_ _ _} _.
+Arguments ty_wf_E {_ _ _} _.
+Arguments ty_share {_ _ _}.
+Arguments ty_own_ghost_drop {_ _ _}.
+Arguments ty_op_type_stable {_ _ _} [_ _ _].
+(*Arguments ty_has_op_type_compat {_ _ _} [_ _ _].*)
+(*Existing Instance ty_ghost_drop_timeless.*)
+
+Definition rt_of `{!typeGS Σ} {rt} (ty : type rt) : Type := rt.
+Definition st_of `{!typeGS Σ} {rt} (ty : type rt) : syn_type := ty_syn_type ty.
+
+Lemma ty_own_val_has_layout `{!typeGS Σ} {rt} (ty : type rt) ly π r v :
+ syn_type_has_layout ty.(ty_syn_type) ly →
+ ty.(ty_own_val) π r v -∗
+ ⌜v `has_layout_val` lyâŒ.
+Proof.
+ iIntros (Hly) "Hval". iPoseProof (ty_has_layout with "Hval") as (ly') "(%Hst & %Hly')".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. subst ly'. done.
+Qed.
+
+Lemma ty_shr_has_layout `{!typeGS Σ} {rt} (ty : type rt) ly κ π r l :
+ syn_type_has_layout ty.(ty_syn_type) ly →
+ ty.(ty_shr) κ π r l -∗
+ ⌜l `has_layout_loc` lyâŒ.
+Proof.
+ iIntros (Hly) "Hshr". iPoseProof (ty_shr_aligned with "Hshr") as (ly') "(%Hst & %Hly')".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. subst ly'. done.
+Qed.
+
+Definition ty_allows_writes `{!typeGS Σ} {rt} (ty : type rt) :=
+ ty.(ty_has_op_type) (use_op_alg' ty.(ty_syn_type)) MCNone.
+Definition ty_allows_reads `{!typeGS Σ} {rt} (ty : type rt) :=
+ ty.(ty_has_op_type) (use_op_alg' ty.(ty_syn_type)) MCCopy.
+
+Record rtype `{!typeGS Σ} `{!LayoutAlg} := mk_rtype {
+ rt_rty : Type;
+ rt_ty : type rt_rty;
+}.
+Global Arguments mk_rtype {_ _ _ _}.
+
+(** Well-formedness of a type with respect to lifetimes. *)
+(* Generate a constraint that a type outlives κ. *)
+Definition lfts_outlives_E `{!typeGS Σ} (κs : list lft) (κ : lft) : elctx :=
+ (λ α, (κ, α)) <$> κs.
+Arguments lfts_outlives_E : simpl never.
+Definition ty_outlives_E `{!typeGS Σ} {rt} (ty : type rt) (κ : lft) : elctx :=
+ lfts_outlives_E ty.(ty_lfts) κ.
+
+(* TODO this can probably not uphold the invariant that our elctx should be keyed by the LHS of ⊑ₑ *)
+Fixpoint tyl_lfts `{!typeGS Σ} tyl : list lft :=
+ match tyl with
+ | [] => []
+ | [ty] => ty.(rt_ty).(ty_lfts)
+ | ty :: tyl => ty.(rt_ty).(ty_lfts) ++ tyl.(tyl_lfts)
+ end.
+
+Fixpoint tyl_wf_E `{!typeGS Σ} tyl : elctx :=
+ match tyl with
+ | [] => []
+ | [ty] => ty.(rt_ty).(ty_wf_E)
+ | ty :: tyl => ty.(rt_ty).(ty_wf_E) ++ tyl.(tyl_wf_E)
+ end.
+
+Fixpoint tyl_outlives_E `{!typeGS Σ} tyl (κ : lft) : elctx :=
+ match tyl with
+ | [] => []
+ | [ty] => ty_outlives_E ty.(rt_ty) κ
+ | ty :: tyl => ty_outlives_E ty.(rt_ty) κ ++ tyl.(tyl_outlives_E) κ
+ end.
+
+Section memcast.
+ Context `{!typeGS Σ}.
+ Lemma ty_memcast_compat_copy {rt} π r v ot (ty : type rt) st :
+ ty.(ty_has_op_type) ot MCCopy →
+ ty.(ty_own_val) π r v -∗ ty.(ty_own_val) π r (mem_cast v ot st).
+ Proof. move => ?. by apply: (ty_memcast_compat _ _ _ MCCopy). Qed.
+
+ Lemma ty_memcast_compat_id {rt} π r v ot (ty : type rt) :
+ ty.(ty_has_op_type) ot MCId →
+ ty.(ty_own_val) Ï€ r v -∗ ⌜mem_cast_id v otâŒ.
+ Proof. move => ?. by apply: (ty_memcast_compat _ _ _ MCId inhabitant). Qed.
+End memcast.
+
+(** simple types *)
+(* Simple types are copy, have a simple sharing predicate, and do not nest. *)
+Record simple_type `{!typeGS Σ} (rt : Type) :=
+ { st_own : thread_id → rt → val → iProp Σ;
+ st_syn_type : syn_type;
+ st_has_op_type : op_type → memcast_compat_type → Prop;
+ st_has_layout π r v :
+ st_own Ï€ r v -∗ ∃ ly, ⌜syn_type_has_layout st_syn_type ly⌠∗ ⌜v `has_layout_val` lyâŒ;
+ st_op_type_stable ot mt : st_has_op_type ot mt → syn_type_has_layout st_syn_type (ot_layout ot);
+ st_own_persistent π r v : Persistent (st_own π r v);
+
+ st_memcast_compat ot mt st π r v :
+ st_has_op_type ot mt →
+ st_own π r v -∗
+ match mt with
+ | MCNone => True
+ | MCCopy => st_own π r (mem_cast v ot st)
+ | MCId => ⌜mem_cast_id v otâŒ
+ end;
+ (*st_has_op_type_compat ot mt :*)
+ (*use_op_alg st_syn_type = Some ot →*)
+ (*mt ≠MCId →*)
+ (*st_has_op_type ot mt;*)
+ }.
+#[export] Existing Instance st_own_persistent.
+#[export] Instance: Params (@st_own) 4 := {}.
+Arguments st_own {_ _ _}.
+Arguments st_has_op_type {_ _ _}.
+Arguments st_syn_type {_ _ _}.
+
+Lemma st_own_has_layout `{!typeGS Σ} {rt} (ty : simple_type rt) ly π r v :
+ syn_type_has_layout ty.(st_syn_type) ly →
+ ty.(st_own) π r v -∗
+ ⌜v `has_layout_val` lyâŒ.
+Proof.
+ iIntros (Hly) "Hval". iPoseProof (st_has_layout with "Hval") as (ly') "(%Hst & %Hly')".
+ have ?: ly' = ly by eapply syn_type_has_layout_inj. subst ly'. done.
+Qed.
+
+
+Program Definition ty_of_st `{!typeGS Σ} rt (st : simple_type rt) : type rt :=
+ {| ty_own_val tid r v := (st.(st_own) tid r v)%I;
+ ty_has_op_type := st.(st_has_op_type);
+ ty_syn_type := st.(st_syn_type);
+ ty_sidecond := True;
+ ty_shr κ tid r l :=
+ (∃ vl ly, &frac{κ} (λ q, l ↦{q} vl) ∗
+ (* later for contractiveness *)
+ ▷ st.(st_own) tid r vl ∗
+ ⌜syn_type_has_layout st.(st_syn_type) ly⌠∗
+ ⌜l `has_layout_loc` lyâŒ)%I;
+ ty_ghost_drop _ _ := True%I;
+ ty_lfts := [];
+ ty_wf_E := [];
+ |}.
+Next Obligation.
+ iIntros (???????) "Hown".
+ iApply (st_has_layout with "Hown").
+Qed.
+Next Obligation.
+ iIntros (??? st ot mt Hot). by eapply st_op_type_stable.
+Qed.
+Next Obligation.
+ iIntros (???????) "Hown". done.
+Qed.
+Next Obligation.
+ iIntros (??? st κ π l r). simpl.
+ iIntros "(%vl & %ly & _ & _ & %Hst & %Hly)". eauto.
+Qed.
+Next Obligation.
+ iIntros (??? st E κ l ly π r ? ?) "#(LFT & TIME) Hκ Hst Hly Hlb Hmt".
+ simpl. rewrite right_id.
+ iApply fupd_logical_step.
+ iMod (bor_exists with "LFT Hmt") as (vl) "Hmt"; first solve_ndisj.
+ iMod (bor_sep with "LFT Hmt") as "[Hmt Hown]"; first solve_ndisj.
+ iMod (bor_persistent with "LFT Hown Hκ") as "[Hown Hκ]"; first solve_ndisj.
+ iMod (bor_fracture (λ q, l ↦{q} vl)%I with "LFT Hmt") as "Hfrac"; [eauto with iFrame.. |].
+ iApply logical_step_intro. eauto 8 with iFrame.
+Qed.
+Next Obligation.
+ iIntros (??? st κ κ' π r l) "#Hord H".
+ iDestruct "H" as (vl ly) "(#Hf & #Hown)".
+ iExists vl, ly. iFrame "Hown". by iApply (frac_bor_shorten with "Hord").
+Qed.
+Next Obligation.
+ simpl. iIntros (??? st π r v ? ?) "_".
+ by iApply logical_step_intro.
+Qed.
+Next Obligation.
+ intros. by iApply st_memcast_compat.
+Qed.
+(*Next Obligation.*)
+ (*intros. apply st_has_op_type_compat; done.*)
+(*Qed.*)
+
+Coercion ty_of_st : simple_type >-> type.
+
+Lemma simple_type_shr_equiv `{!typeGS Σ} {rt} (ty : simple_type rt) l π κ r :
+ (ty_shr ty κ π r l) ≡
+ (∃ (v : val) (ly : layout),
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗ ⌜l `has_layout_loc` ly⌠∗
+ &frac{κ} (λ q : Qp, l ↦{q} v) ∗
+ ▷ ty.(ty_own_val) π r v)%I.
+Proof.
+ iSplit.
+ - iIntros "(%v & %ly & ? & ? & ?)"; eauto with iFrame.
+ - iIntros "(%v & %ly & ? & ? & ?)"; iExists _, _; eauto with iFrame.
+Qed.
+
+(** Copy types *)
+Fixpoint shr_locsE (l : loc) (n : nat) : coPset :=
+ match n with
+ | 0%nat => ∅
+ | S n => ↑shrN.@l ∪ shr_locsE (l +ₗ 1%nat) n
+ end.
+
+Class Copyable `{!typeGS Σ} {rt} (ty : type rt) := {
+ copy_own_persistent π r v : Persistent (ty.(ty_own_val) π r v);
+ (* sharing predicates of copyable types should actually allow us to get a Copy out from below the reference *)
+ copy_shr_acc κ π E F l ly r q :
+ lftE ∪ ↑shrN ⊆ E →
+ syn_type_has_layout ty.(ty_syn_type) ly →
+ shr_locsE l (ly.(ly_size) + 1) ⊆ F →
+ rrust_ctx -∗
+ ty.(ty_shr) κ π r l -∗
+ na_own π F -∗ q.[κ] ={E}=∗
+ ▷ ⌜l `has_layout_loc` ly⌠∗
+ ∃ q', na_own π (F ∖ shr_locsE l ly.(ly_size)) ∗
+ ▷ (l ↦{q'}: ty.(ty_own_val) π r) ∗
+ (na_own π (F ∖ shr_locsE l ly.(ly_size)) -∗ ▷l ↦{q'}: ty.(ty_own_val) π r ={E}=∗ na_own π F ∗ q.[κ])
+}.
+#[export] Hint Mode Copyable - - + + : typeclass_instances.
+#[export] Existing Instance copy_own_persistent.
+
+#[export] Program Instance simple_type_copyable `{typeGS Σ} {rt} (st : simple_type rt) : Copyable st.
+Next Obligation.
+ iIntros (??? st κ π E F l ly r ? Hst ?). iIntros (?) "#(LFT & TIME & LLCTX) (%v & %ly' & Hf & #Hown & %Hst' & Hly) Htok Hlft".
+ have: (ly' = ly); first by eapply syn_type_has_layout_inj. move => ?; subst ly'.
+ iDestruct (na_own_acc with "Htok") as "[$ Htok]"; first solve_ndisj.
+ iMod (frac_bor_acc with "LFT Hf Hlft") as (q') "[Hmt Hclose]"; first solve_ndisj.
+ iModIntro. iFrame "Hly". iExists _. iDestruct "Hmt" as "[Hmt1 Hmt2]".
+ iSplitL "Hmt1"; first by auto with iFrame.
+ iIntros "Htok2 Hmt1". iDestruct "Hmt1" as (vl') "[Hmt1 #Hown']".
+ iDestruct ("Htok" with "Htok2") as "$".
+ iAssert (â–· ⌜length v = length vl'âŒ)%I as ">%".
+ { iNext.
+ iDestruct (ty_own_val_has_layout with "Hown'") as %->; first done.
+ iDestruct (st_own_has_layout with "Hown") as %->; done. }
+ iApply "Hclose". iModIntro. rewrite -{3}(Qp.div_2 q').
+ iPoseProof (heap_mapsto_agree with "Hmt1 Hmt2") as "%Heq"; first done.
+ subst vl'. rewrite heap_mapsto_fractional. iFrame.
+Qed.
+Bind Scope bi_scope with type.
+
+Notation "l â—â‚—{ Ï€ , κ } r @ ty" := (ty_shr ty κ Ï€ r l) (at level 15, format "l â—â‚—{ Ï€ , κ } r @ ty") : bi_scope.
+Notation "v â—áµ¥{ Ï€ } r @ ty" := (ty_own_val ty Ï€ r v) (at level 15) : bi_scope.
+Notation "l â—â‚—{ Ï€ , κ } .@ ty" := (ty_shr ty κ Ï€ () l) (at level 15, format "l â—â‚—{ Ï€ , κ } .@ ty") : bi_scope.
+Notation "v â—áµ¥{ Ï€ } .@ ty" := (ty_own_val ty Ï€ () v) (at level 15) : bi_scope.
+
+(*** Cofe and Ofe *)
+Section ofe.
+ Context `{!typeGS Σ}.
+ Context {rt : Type}.
+
+ Inductive type_equiv' (ty1 ty2 : type rt) : Prop :=
+ Type_equiv :
+ (∀ ot mt, ty1.(ty_has_op_type) ot mt ↔ ty2.(ty_has_op_type) ot mt) →
+ (∀ π r v, ty1.(ty_own_val) π r v ≡ ty2.(ty_own_val) π r v) →
+ (∀ κ π r l, ty1.(ty_shr) κ π r l ≡ ty2.(ty_shr) κ π r l) →
+ (ty1.(ty_syn_type) = ty2.(ty_syn_type)) →
+ (ty1.(ty_sidecond) ≡ ty2.(ty_sidecond)) →
+ (∀ π r, ty1.(ty_ghost_drop) π r ≡ ty2.(ty_ghost_drop) π r) →
+ (ty1.(ty_lfts) = ty2.(ty_lfts)) →
+ (ty1.(ty_wf_E) = ty2.(ty_wf_E)) →
+ type_equiv' ty1 ty2.
+ Instance type_equiv : Equiv (type rt) := type_equiv'.
+ Inductive type_dist' (n : nat) (ty1 ty2 : type rt) : Prop :=
+ Type_dist :
+ (∀ ot mt, ty1.(ty_has_op_type) ot mt ↔ ty2.(ty_has_op_type) ot mt) →
+ (∀ π r v, ty1.(ty_own_val) π r v ≡{n}≡ ty2.(ty_own_val) π r v) →
+ (∀ κ π r v, ty1.(ty_shr) κ π r v ≡{n}≡ ty2.(ty_shr) κ π r v) →
+ (ty1.(ty_syn_type) = ty2.(ty_syn_type)) →
+ (ty1.(ty_sidecond) ≡{n}≡ ty2.(ty_sidecond)) →
+ (∀ π r, ty1.(ty_ghost_drop) π r ≡{n}≡ ty2.(ty_ghost_drop) π r) →
+ (ty1.(ty_lfts) = ty2.(ty_lfts)) →
+ (ty1.(ty_wf_E) = ty2.(ty_wf_E)) →
+ type_dist' n ty1 ty2.
+ Instance type_dist : Dist (type rt) := type_dist'.
+
+ (* type rt is isomorphic to { x : T | P x } *)
+ Let T :=
+ prodO (prodO (prodO (prodO (prodO (prodO (prodO
+ (thread_id -d> rt -d> val -d> iPropO Σ)
+ (lft -d> thread_id -d> rt -d> loc -d> iPropO Σ))
+ (syn_typeO))
+ (op_type -d> leibnizO memcast_compat_type -d> PropO))
+ (iPropO Σ))
+ (thread_id -d> rt -d> iPropO Σ))
+ (leibnizO (list lft)))
+ (leibnizO elctx).
+ Let P (x : T) : Prop :=
+ (*let '(T_own_val, T_shr, T_syn_type, T_depth, T_ot, T_sidecond, T_drop, T_lfts, T_wf_E) := x in*)
+ (* ty_has_layout *)
+ (∀ Ï€ r v, x.1.1.1.1.1.1.1 Ï€ r v -∗ ∃ ly : layout, ⌜syn_type_has_layout x.1.1.1.1.1.2 ly⌠∗ ⌜v `has_layout_val` lyâŒ) ∧
+ (* ty_op_type_stable *)
+ (∀ ot mt, x.1.1.1.1.2 ot mt → syn_type_has_layout x.1.1.1.1.1.2 (ot_layout ot)) ∧
+ (* ty_own_val_sidecond *)
+ (∀ π r v, x.1.1.1.1.1.1.1 π r v -∗ x.1.1.1.2) ∧
+ (* ty_shr_persistent *)
+ (∀ κ π r l, Persistent (x.1.1.1.1.1.1.2 κ π r l)) ∧
+ (* ty_shr_aligned *)
+ (∀ κ Ï€ l r, x.1.1.1.1.1.1.2 κ Ï€ r l -∗ ∃ ly : layout, ⌜l `has_layout_loc` ly⌠∗ ⌜syn_type_has_layout x.1.1.1.1.1.2 lyâŒ) ∧
+ (* ty_share *)
+ (∀ E κ l ly π r q, lftE ⊆ E → rrust_ctx -∗
+ let κ' := lft_intersect_list x.1.2 in
+ q.[κ ⊓ κ'] -∗
+ ⌜syn_type_has_layout x.1.1.1.1.1.2 ly⌠-∗
+ ⌜l `has_layout_loc` ly⌠-∗
+ loc_in_bounds l 0 (ly_size ly) -∗
+ &{κ} (∃ v, l ↦ v ∗ x.1.1.1.1.1.1.1 π r v) -∗ logical_step E (x.1.1.1.1.1.1.2 κ π r l ∗ q.[κ ⊓ κ'])) ∧
+ (* ty_shr_mono *)
+ (∀ κ κ' π r (l : loc), κ' ⊑ κ -∗ x.1.1.1.1.1.1.2 κ π r l -∗ x.1.1.1.1.1.1.2 κ' π r l) ∧
+ (* ty_own_ghost_drop *)
+ (∀ π r v F, lftE ⊆ F → x.1.1.1.1.1.1.1 π r v -∗ logical_step F (x.1.1.2 π r)) ∧
+ (* ty_memcast_compat *)
+ (∀ ot mt st π r v, x.1.1.1.1.2 ot mt → x.1.1.1.1.1.1.1 π r v -∗
+ match mt with | MCNone => True | MCCopy => x.1.1.1.1.1.1.1 π r (mem_cast v ot st) | MCId => ⌜mem_cast_id v ot⌠end) ∧
+ (* ty_has_op_type_compat *)
+ (*(∀ ot mt, use_op_alg x.1.1.1.1.1.2 = Some ot → mt ≠MCId → x.1.1.1.1.2 ot mt) ∧*)
+ (* ty_sidecond_timeless *)
+ (Timeless (x.1.1.1.2)) ∧
+ (* ty_sidecond_persistent *)
+ (Persistent (x.1.1.1.2)).
+
+ (* to handle the let destruct in an acceptable way *)
+ Local Set Program Cases.
+
+ Definition type_unpack (ty : type rt) : T :=
+ (ty.(ty_own_val),
+ ty.(ty_shr),
+ ty.(ty_syn_type),
+ ty.(ty_has_op_type),
+ ty.(ty_sidecond),
+ ty.(ty_ghost_drop),
+ ty.(ty_lfts),
+ ty.(ty_wf_E)).
+ Program Definition type_pack (x : T) (H : P x) : type rt :=
+ let '(T_own_val, T_shr, T_syn_type, T_ot, T_sidecond, T_drop, T_lfts, T_wf_E) := x in
+ {|
+ ty_own_val := T_own_val;
+ ty_has_op_type := T_ot;
+ ty_syn_type := T_syn_type;
+ ty_shr := T_shr;
+ ty_sidecond := T_sidecond;
+ ty_ghost_drop := T_drop;
+ ty_lfts := T_lfts;
+ ty_wf_E := T_wf_E;
+ |}.
+ Solve Obligations with
+ intros [[[[[[[T_own_val T_shr] T_syn_type] T_ot] T_sidecond] T_drop] T_lfts] T_wf_E];
+ intros (? & ? & ? & ? & ? & ? & ? & ? & ? & ? & ?);
+ intros ???????? Heq; injection Heq; intros -> -> -> -> -> -> -> ->;
+ done.
+
+ Definition type_ofe_mixin : OfeMixin (type rt).
+ Proof.
+ apply (iso_ofe_mixin type_unpack).
+ - intros t1 t2. split.
+ + destruct 1; done.
+ + intros [[[[[[[]]]]]]]; simpl in *.
+ by constructor.
+ - intros t1 t2. split.
+ + destruct 1; done.
+ + intros [[[[[[[]]]]]]]; simpl in *.
+ by constructor.
+ Qed.
+ Canonical Structure typeO : ofe := Ofe (type rt) type_ofe_mixin.
+
+ Global Instance ty_own_val_ne n:
+ Proper (dist n ==> eq ==> eq ==> eq ==> dist n) ty_own_val.
+ Proof. intros ?? EQ ??-> ??-> ??->. apply EQ. Qed.
+ Global Instance ty_own_val_proper : Proper ((≡) ==> eq ==> eq ==> eq ==> (≡)) ty_own_val.
+ Proof. intros ?? EQ ??-> ??-> ??->. apply EQ. Qed.
+ Lemma ty_own_val_entails `{!typeGS Σ} ty1 ty2 π r v:
+ ty1 ≡@{type rt} ty2 →
+ ty_own_val ty1 π r v -∗
+ ty_own_val ty2 π r v.
+ Proof. intros [_ -> _]; eauto. Qed.
+
+ Global Instance ty_shr_ne n:
+ Proper (dist n ==> eq ==> eq ==> eq ==> eq ==> dist n) ty_shr.
+ Proof. intros ?? EQ ??-> ?? -> ??-> ??->. apply EQ. Qed.
+ Global Instance ty_shr_proper : Proper ((≡) ==> eq ==> eq ==> eq ==> eq ==> (≡)) ty_shr.
+ Proof. intros ?? EQ ??-> ?? -> ??-> ??->. apply EQ. Qed.
+ Lemma ty_shr_entails `{!typeGS Σ} ty1 ty2 κ π r l:
+ ty1 ≡@{type rt} ty2 →
+ ty_shr ty1 κ π r l -∗
+ ty_shr ty2 κ π r l.
+ Proof. intros [_ _ -> _]; eauto. Qed.
+
+ Local Ltac intro_T :=
+ intros [[[[[[[T_own_val T_shr ] T_syn_type] T_ot] T_sidecond] T_drop] T_lfts] T_wf_E].
+ Global Instance type_cofe : Cofe typeO.
+ Proof.
+ apply (iso_cofe_subtype' P type_pack type_unpack).
+ - by intros [].
+ - split; [by destruct 1|].
+ by intros [[[[[[[]]]]]]]; constructor.
+ - intros [[[[[[[]]]]]]] Hx; done.
+ - repeat apply limit_preserving_and; repeat (apply limit_preserving_forall; intros ?).
+ + apply bi.limit_preserving_emp_valid => n ty1 ty2. intro_T; f_equiv;
+ [ apply T_own_val | f_equiv; rewrite T_syn_type; done].
+ + apply limit_preserving_impl.
+ { intros ty1 ty2; intro_T. intros ?. by apply T_ot. }
+ { apply limit_preserving_discrete. intros ty1 ty2; intro_T. by rewrite T_syn_type. }
+ + apply bi.limit_preserving_emp_valid => n ty1 ty2; intro_T; f_equiv; last done. apply T_own_val.
+ + apply bi.limit_preserving_Persistent => n ty1 ty2; intro_T. apply T_shr.
+ + apply bi.limit_preserving_emp_valid => n ty1 ty2; intro_T; f_equiv.
+ { apply T_shr. }
+ { f_equiv. by rewrite T_syn_type. }
+ + apply bi.limit_preserving_emp_valid => n ty1 ty2.
+ intro_T. f_equiv. simpl. f_equiv. { rewrite T_lfts. done. }
+ f_equiv. { by rewrite T_syn_type. }
+ f_equiv. f_equiv. f_equiv. { repeat f_equiv; apply T_own_val. }
+
+ apply logical_step_ne.
+ f_equiv; first apply T_shr.
+ rewrite T_lfts. done.
+ + apply bi.limit_preserving_emp_valid => n ty1 ty2; simpl.
+ intro_T. f_equiv. f_equiv; apply T_shr.
+ + apply bi.limit_preserving_emp_valid => n ty1 ty2; intro_T; f_equiv.
+ { apply T_own_val. }
+ apply logical_step_ne. apply T_drop.
+ + apply limit_preserving_impl.
+ { intros ty1 ty2. intro_T. intros ?. by apply T_ot. }
+ destruct y0.
+ * apply bi.limit_preserving_emp_valid => n ty1 ty2. intro_T. f_equiv.
+ apply T_own_val.
+ * apply bi.limit_preserving_emp_valid => n ty1 ty2; intro_T; f_equiv;
+ apply T_own_val.
+ * apply bi.limit_preserving_emp_valid => n ty1 ty2; intro_T; f_equiv;
+ apply T_own_val.
+ (*
+ + apply limit_preserving_impl.
+ { intros ty1 ty2; intro_T. intros ?. by rewrite -T_syn_type. }
+ apply limit_preserving_impl.
+ { intros ? ?; intro_T. done. }
+ apply limit_preserving_discrete. intros ty1 ty2; intro_T.
+ intros ?. by apply T_ot.
+ *)
+ + apply bi.limit_preserving_entails => n ty1 ty2; intro_T; f_equiv; done.
+ + apply bi.limit_preserving_Persistent => n ty1 ty2; intro_T. apply T_sidecond.
+ Qed.
+End ofe.
+
+(** ** Subtyping etc. *)
+Definition type_incl `{!typeGS Σ} {rt1 rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) : iProp Σ :=
+ (⌜ty1.(ty_syn_type) = ty2.(ty_syn_type)⌠∗
+ (□ (ty1.(ty_sidecond) -∗ ty2.(ty_sidecond))) ∗
+ (□ ∀ π v, ty1.(ty_own_val) π r1 v -∗ ty2.(ty_own_val) π r2 v) ∗
+ (□ ∀ κ π l, ty1.(ty_shr) κ π r1 l -∗ ty2.(ty_shr) κ π r2 l))%I.
+#[export] Instance: Params (@type_incl) 4 := {}.
+
+(* Heterogeneous subtyping *)
+Definition subtype `{!typeGS Σ} (E : elctx) (L : llctx) {rt1 rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) : Prop :=
+ ∀ qL, llctx_interp_noend L qL -∗ (elctx_interp E -∗ type_incl r1 r2 ty1 ty2).
+#[export] Instance: Params (@subtype) 6 := {}.
+
+(* Homogeneous subtyping independently of the refinement *)
+Definition full_subtype `{!typeGS Σ} (E : elctx) (L : llctx) {rt} (ty1 ty2 : type rt) : Prop :=
+ ∀ r, subtype E L r r ty1 ty2.
+#[export] Instance: Params (@full_subtype) 5 := {}.
+
+(* Heterogeneous type equality *)
+Definition eqtype `{!typeGS Σ} (E : elctx) (L : llctx) {rt1} {rt2} (r1 : rt1) (r2 : rt2) (ty1 : type rt1) (ty2 : type rt2) : Prop :=
+ subtype E L r1 r2 ty1 ty2 ∧ subtype E L r2 r1 ty2 ty1.
+#[export] Instance: Params (@eqtype) 6 := {}.
+
+Definition full_eqtype `{!typeGS Σ} (E : elctx) (L : llctx) {rt} (ty1 ty2 : type rt) : Prop :=
+ ∀ r, eqtype E L r r ty1 ty2.
+#[export] Instance: Params (@full_eqtype) 5 := {}.
+
+Section subtyping.
+ Context `{!typeGS Σ}.
+
+ (** *** [type_incl] *)
+ Global Instance type_incl_ne {rt1 rt2} r1 r2 : NonExpansive2 (type_incl (rt1 := rt1) (rt2 := rt2) r1 r2).
+ Proof.
+ iIntros (n ty1 ty1' Heq ty2 ty2' Heq2).
+ unfold type_incl. f_equiv.
+ { f_equiv. f_equiv; by destruct Heq, Heq2. }
+ f_equiv.
+ { f_equiv. f_equiv; by destruct Heq, Heq2. }
+ do 2 f_equiv.
+ { do 6 f_equiv; by destruct Heq, Heq2. }
+ do 8 f_equiv; by destruct Heq, Heq2.
+ Qed.
+ Global Instance type_incl_proper {rt1 rt2} r1 r2 : Proper ((≡) ==> (≡) ==> (≡)) (type_incl (rt1 := rt1) (rt2 := rt2) r1 r2).
+ Proof.
+ iIntros (ty1 ty1' Heq ty2 ty2' Heq2).
+ apply equiv_dist => n. apply type_incl_ne; by apply equiv_dist.
+ Qed.
+
+ Global Instance type_incl_persistent {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) : Persistent (type_incl r1 r2 ty1 ty2) := _.
+
+ Lemma type_incl_refl {rt} (r : rt) (ty : type rt) : ⊢ type_incl r r ty ty.
+ Proof.
+ iSplit; first done.
+ iSplitR. { iModIntro; iIntros "$". }
+ iSplit; iModIntro; iIntros; done.
+ Qed.
+
+ Lemma type_incl_trans {rt1 rt2 rt3} r1 r2 r3 (ty1 : type rt1) (ty2 : type rt2) (ty3 : type rt3) :
+ type_incl r1 r2 ty1 ty2 -∗ type_incl r2 r3 ty2 ty3 -∗ type_incl r1 r3 ty1 ty3.
+ Proof.
+ iIntros "(% & #Hsc12 & #Ho12 & #Hs12) (% & #Hsc23 & #Ho23 & #Hs23)".
+ iSplit; first (iPureIntro; etrans; done).
+ iSplitR. { iModIntro. iIntros "H1". iApply "Hsc23". by iApply "Hsc12". }
+ iSplit; iModIntro; iIntros.
+ - iApply "Ho23". iApply "Ho12". done.
+ - iApply "Hs23". iApply "Hs12". done.
+ Qed.
+
+ (** *** [subtype] *)
+ Lemma subtype_refl E L {rt} r (ty : type rt) : subtype E L r r ty ty.
+ Proof. iIntros (?) "_ _". iApply type_incl_refl. Qed.
+ Lemma subtype_trans E L {rt1 rt2 rt3} r1 r2 r3 (ty1 : type rt1) (ty2 : type rt2) (ty3 : type rt3) :
+ subtype E L r1 r2 ty1 ty2 → subtype E L r2 r3 ty2 ty3 → subtype E L r1 r3 ty1 ty3.
+ Proof.
+ intros H12 H23. iIntros (?) "HL #HE".
+ iDestruct (H12 with "HL HE") as "#H12".
+ iDestruct (H23 with "HL HE") as "#H23".
+ iApply (type_incl_trans with "[#]"); [by iApply "H12" | by iApply "H23"].
+ Qed.
+
+ (* For the homogenous case, we get an instance *)
+ #[export] Instance full_subtype_preorder E L {rt} :
+ PreOrder (full_subtype E L (rt:=rt)).
+ Proof.
+ split; first (intros ??; apply subtype_refl).
+ intros ??????. by eapply subtype_trans.
+ Qed.
+
+ (*
+ Lemma full_subtype_Forall2_llctx E L {rt} (tys1 tys2 : list (type rt)) qL :
+ Forall2 (full_subtype E L) tys1 tys2 →
+ llctx_interp_noend L qL -∗ (elctx_interp E -∗
+ [∗ list] tys ∈ (zip tys1 tys2), ∀ r, type_incl r r (tys.1) (tys.2)).
+ Proof.
+ iIntros (Htys) "HL #HE".
+ iAssert ([∗ list] tys ∈ zip tys1 tys2,
+ □ (llctx_interp_noend L qL -∗ ∀ r, type_incl r r (tys.1) (tys.2)))%I as "#Htys".
+ { iApply big_sepL_forall. iIntros (k [ty1 ty2] Hlookup).
+ move:Htys => /Forall2_Forall /Forall_forall=>Htys.
+ iIntros "!> HL" (r).
+ iApply (Htys (ty1, ty2) with "HL"); first by exact: elem_of_list_lookup_2. done. }
+ Qed.
+ *)
+
+ Lemma equiv_full_subtype E L {rt} (ty1 ty2 : type rt) : ty1 ≡ ty2 → full_subtype E L ty1 ty2.
+ Proof. unfold subtype=>EQ ? ?. setoid_rewrite EQ. apply subtype_refl. Qed.
+
+ Lemma eqtype_unfold E L {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) :
+ eqtype E L r1 r2 ty1 ty2 ↔
+ (∀ qL, llctx_interp_noend L qL -∗ (elctx_interp E -∗
+ (⌜ty1.(ty_syn_type) = ty2.(ty_syn_type)⌠∗
+ (□ (ty1.(ty_sidecond) ↔ ty2.(ty_sidecond))) ∗
+ (□ ∀ π v, ty1.(ty_own_val) π r1 v ↔ ty2.(ty_own_val) π r2 v) ∗
+ (□ ∀ κ π l, ty1.(ty_shr) κ π r1 l ↔ ty2.(ty_shr) κ π r2 l)))%I).
+ Proof.
+ split.
+ - iIntros ([EQ1 EQ2] qL) "HL HE".
+ iDestruct (EQ1 with "HL HE") as "#EQ1".
+ iDestruct (EQ2 with "HL HE") as "#EQ2".
+ iDestruct ("EQ1") as "(% & #Hsc1 & #H1own & #H1shr)".
+ iDestruct ("EQ2") as "(_ & #Hsc2 & #H2own & #H2shr)".
+ iSplitR; first done. iSplit; last iSplit.
+ + iModIntro. iSplit; iIntros "?"; [iApply "Hsc1" | iApply "Hsc2"]; done.
+ + by iIntros "!#*"; iSplit; iIntros "H"; [iApply "H1own"|iApply "H2own"].
+ + by iIntros "!#*"; iSplit; iIntros "H"; [iApply "H1shr"|iApply "H2shr"].
+ - intros EQ. split; (iIntros (qL) "HL HE";
+ iDestruct (EQ with "HL HE") as "#EQ";
+ iDestruct ("EQ") as "(% & #Hsc & #Hown & #Hshr)"; iSplitR; [done | ]; iSplit; [ | iSplit ]).
+ + iIntros "!> H". by iApply "Hsc".
+ + iIntros "!> * H". by iApply "Hown".
+ + iIntros "!> * H". by iApply "Hshr".
+ + iIntros "!> H". by iApply "Hsc".
+ + iIntros "!> * H". by iApply "Hown".
+ + iIntros "!> * H". by iApply "Hshr".
+ Qed.
+
+ Lemma eqtype_refl E L {rt} r (ty : type rt) : eqtype E L r r ty ty.
+ Proof. split; apply subtype_refl. Qed.
+
+ Lemma equiv_full_eqtype E L {rt} (ty1 ty2 : type rt) : ty1 ≡ ty2 → full_eqtype E L ty1 ty2.
+ Proof. by intros ??; split; apply equiv_full_subtype. Qed.
+
+ Global Instance subtype_proper E L {rt1 rt2} r1 r2 :
+ Proper (eqtype E L (rt1:=rt1) (rt2:=rt1) r1 r1 ==> eqtype E L (rt1:=rt2)(rt2:=rt2) r2 r2 ==> iff) (subtype E L (rt1 := rt1) (rt2 := rt2) r1 r2).
+ Proof.
+ intros ??[H1 H2] ??[H3 H4]. split; intros H.
+ - eapply subtype_trans; last eapply subtype_trans; [ apply H2 | apply H | apply H3].
+ - eapply subtype_trans; last eapply subtype_trans; [ apply H1 | apply H | apply H4].
+ Qed.
+
+ #[export] Instance full_eqtype_equivalence E L {rt} : Equivalence (full_eqtype E L (rt:=rt)).
+ Proof.
+ split.
+ - split; apply subtype_refl.
+ - intros ?? Heq; split; apply Heq.
+ - intros ??? H1 H2. split; eapply subtype_trans; (apply H1 || apply H2).
+ Qed.
+
+ Lemma type_incl_simple_type {rt1} {rt2} r1 r2 (st1 : simple_type rt1) (st2 : simple_type rt2) :
+ □ (∀ tid v, st1.(st_own) tid r1 v -∗ st2.(st_own) tid r2 v) -∗
+ ⌜st1.(st_syn_type) = st2.(st_syn_type)⌠-∗
+ type_incl r1 r2 st1 st2.
+ Proof.
+ iIntros "#Hst %Hly". iSplit; first done. iSplitR; first done. iSplit; iModIntro.
+ - simpl. eauto.
+ - iIntros (???).
+ iDestruct 1 as (vl ly) "(Hf & Hown & %Hst & %Hly')". iExists vl, ly. iFrame "Hf".
+ iSplitL. { by iApply "Hst". } rewrite -Hly. done.
+ Qed.
+
+ Lemma subtype_simple_type E L {rt1 rt2} r1 r2 (st1 : simple_type rt1) (st2 : simple_type rt2):
+ (∀ qL, llctx_interp_noend L qL -∗ (elctx_interp E -∗
+ (□ ∀ tid v, st1.(st_own) tid r1 v -∗ st2.(st_own) tid r2 v) ∗
+ ⌜st1.(st_syn_type) = st2.(st_syn_type)âŒ)) →
+ subtype E L r1 r2 st1 st2.
+ Proof.
+ intros Hst. iIntros (qL) "HL HE". iDestruct (Hst with "HL HE") as "#Hst".
+ iClear "∗". iDestruct ("Hst") as "[Hst' %Hly]".
+ iApply type_incl_simple_type.
+ - iIntros "!#" (??) "?". by iApply "Hst'".
+ - done.
+ Qed.
+
+ Lemma subtype_weaken E1 E2 L1 L2 {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) :
+ E1 ⊆+ E2 → L1 ⊆+ L2 →
+ subtype E1 L1 r1 r2 ty1 ty2 → subtype E2 L2 r1 r2 ty1 ty2.
+ Proof.
+ iIntros (HE12 ? Hsub qL) "HL HE". iDestruct (Hsub with "[HL] [HE]") as "#Hsub".
+ { rewrite /llctx_interp. by iApply big_sepL_submseteq. }
+ { rewrite /elctx_interp. by iApply big_sepL_submseteq. }
+ iApply "Hsub".
+ Qed.
+
+ Lemma subtype_eqtype E L {rt1 rt2} r1 r2 (ty1 : type rt1) (ty2 : type rt2) :
+ subtype E L r1 r2 ty1 ty2 →
+ subtype E L r2 r1 ty2 ty1 →
+ eqtype E L r1 r2 ty1 ty2.
+ Proof. intros; split; done. Qed.
+
+ Lemma all_subtype_alt E L {rt} (ty1 ty2 : type rt) :
+ (∀ r, subtype E L r r ty1 ty2) ↔
+ (∀ qL, llctx_interp_noend L qL -∗ (elctx_interp E -∗ ∀ r, type_incl r r ty1 ty2)).
+ Proof.
+ split.
+ - intros Ha qL. iIntros "HL HE" (r).
+ by iPoseProof (Ha r with "HL HE") as "Ha".
+ - intros Ha r. iIntros (qL) "HL HE".
+ iApply (Ha with "HL HE").
+ Qed.
+ Lemma all_eqtype_alt E L {rt} (ty1 ty2 : type rt) :
+ (∀ r, eqtype E L r r ty1 ty2) ↔
+ ((∀ qL, llctx_interp_noend L qL -∗ elctx_interp E -∗ ∀ r, type_incl r r ty1 ty2) ∧
+ (∀ qL, llctx_interp_noend L qL -∗ elctx_interp E -∗ ∀ r, type_incl r r ty2 ty1)).
+ Proof.
+ rewrite forall_and_distr !all_subtype_alt //.
+ Qed.
+
+ Lemma full_subtype_eqtype E L {rt} (ty1 ty2 : type rt) :
+ full_subtype E L ty1 ty2 →
+ full_subtype E L ty2 ty1 →
+ full_eqtype E L ty1 ty2.
+ Proof.
+ intros Hsub1 Hsub2 r. split; done.
+ Qed.
+
+ Lemma full_eqtype_subtype_l E L {rt} (ty1 ty2 : type rt) :
+ full_eqtype E L ty1 ty2 → full_subtype E L ty1 ty2.
+ Proof.
+ iIntros (Heq r). destruct (Heq r) as [Ha Hb]. done.
+ Qed.
+ Lemma full_eqtype_subtype_r E L {rt} (ty1 ty2 : type rt) :
+ full_eqtype E L ty1 ty2 → full_subtype E L ty2 ty1.
+ Proof.
+ iIntros (Heq r). destruct (Heq r) as [Ha Hb]. done.
+ Qed.
+End subtyping.
diff --git a/theories/rust_typing/typing.v b/theories/rust_typing/typing.v
new file mode 100644
index 0000000000000000000000000000000000000000..ac01db6588e335a2042bf6dd75b17d39477869fb
--- /dev/null
+++ b/theories/rust_typing/typing.v
@@ -0,0 +1,6 @@
+From refinedrust Require Export type int int_rules products references functions uninit box programs enum maybe_uninit alias_ptr existentials arrays value.
+From refinedrust Require Export automation.
+
+Global Open Scope Z_scope.
+
+Notation Obs := gvar_pobs.
diff --git a/theories/rust_typing/uninit.v b/theories/rust_typing/uninit.v
new file mode 100644
index 0000000000000000000000000000000000000000..4551538f6b1ea3106b033b9cc2ec39f28e8b54ca
--- /dev/null
+++ b/theories/rust_typing/uninit.v
@@ -0,0 +1,337 @@
+From refinedrust Require Export type uninit_def.
+From refinedrust Require Import programs ltype_rules.
+Set Default Proof Using "Type".
+
+Section typing.
+ Context `{!typeGS Σ}.
+
+ (** ** Instances for deinitializing a type *)
+
+ (* Two low-priority instances that trigger as a fallback for ltypes foldable to a ty (no borrows below) *)
+ Lemma owned_subltype_step_ofty_uninit π E L {rt} (lt : ltype rt) r st T :
+ cast_ltype_to_type E L lt (λ ty,
+ li_tactic (compute_layout_goal (ty_syn_type ty)) (λ ly1,
+ li_tactic (compute_layout_goal st) (λ ly2,
+ ⌜ly1 = ly2⌠∗ T L (ty_ghost_drop ty π r))))
+ ⊢ owned_subltype_step π E L #r #() lt (◠uninit st) T.
+ Proof.
+ iDestruct 1 as "(%ty & %Heqt & HT)".
+ rewrite /compute_layout_goal.
+ iDestruct "HT" as "(%ly1 & %Hst1 & %ly2 & %Hst2 & <- & HT)".
+ iIntros (???) "CTX HE HL Hl". simp_ltypes; simpl.
+ iPoseProof (full_eqltype_acc with "CTX HE HL") as "#Hincl"; first apply Heqt.
+ iSpecialize ("Hincl" $! (Owned false) (#r)).
+ iDestruct "Hincl" as "(Hincl & _)". iDestruct "Hincl" as "(%Hst & Hincl & _)".
+ iMod (ltype_incl'_use with "Hincl Hl") as "Hl"; first done.
+ iExists _, _. iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hsc & Hlb & _ & %r' & <- & Hb)".
+ assert (ly1 = ly) as -> by by eapply (syn_type_has_layout_inj (ty_syn_type ty)).
+ iMod (fupd_mask_mono with "Hb") as "(%v & Hl & Hv)"; first done.
+ iModIntro. iSplitL.
+ { iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ iPoseProof (ty_own_ghost_drop with "Hv") as "Hb"; first done.
+ iApply (logical_step_wand with "Hb"). iIntros "$".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists _. iR. iR. simpl. iR. iFrame. iR.
+ iExists _. iR. iModIntro. iExists _. iFrame.
+ rewrite uninit_own_spec. eauto. }
+ iPureIntro.
+ iIntros (ly1' ly2' Hst1' Hst2').
+ rewrite Hst in Hst1'. simp_ltypes in Hst1'.
+ assert (ly1' = ly) as -> by by eapply syn_type_has_layout_inj.
+ assert (ly2' = ly) as -> by by eapply syn_type_has_layout_inj.
+ done.
+ Qed.
+ Global Instance owned_subltype_step_ofty_uninit_inst π E L {rt} (lt : ltype rt) r st :
+ OwnedSubltypeStep π E L #r #() lt (◠uninit st)%I | 101:=
+ λ T, i2p (owned_subltype_step_ofty_uninit π E L lt r st T).
+
+ (* Higher-priority instacne for the special case that we go to Untyped *)
+ Lemma owned_subltype_step_ofty_uninit_untyped π E L {rt} (lt : ltype rt) r ly T :
+ cast_ltype_to_type E L lt (λ ty,
+ ⌜syn_type_has_layout (ty_syn_type ty) ly⌠∗ T L (ty_ghost_drop ty π r))
+ ⊢ owned_subltype_step π E L #r #() lt (◠uninit (UntypedSynType ly)) T.
+ Proof.
+ iDestruct 1 as "(%ty & %Heqt & HT)".
+ iDestruct "HT" as "(%Hst & HT)".
+ iApply owned_subltype_step_ofty_uninit.
+ iExists ty. iR.
+ iExists ly. iR. iExists ly.
+ iSplitR. { iPureIntro. by eapply syn_type_has_layout_make_untyped. }
+ iR. done.
+ Qed.
+ Global Instance owned_subltype_step_ofty_uninit_untyped_inst π E L {rt} (lt : ltype rt) r ly :
+ OwnedSubltypeStep π E L #r #() lt (◠uninit (UntypedSynType ly))%I | 100 :=
+ λ T, i2p (owned_subltype_step_ofty_uninit_untyped π E L lt r ly T).
+
+ (* More specific instances *)
+ Lemma owned_subltype_step_shrltype_uninit π E L {rt} (lt : ltype rt) r st κ T :
+ ⌜syn_type_compat PtrSynType st⌠∗ T L True%I
+ ⊢ owned_subltype_step π E L r #() (ShrLtype lt κ) (◠uninit st) T.
+ Proof.
+ iIntros "(%Hstcomp & HT)".
+ iIntros (???) "CTX HE HL Hl". simp_ltypes; simpl.
+ iMod (ltype_deinit_shr with "Hl") as "Hl"; [done.. | ].
+ iExists _, _. iFrame.
+ iSplitL. { iApply logical_step_intro. by iFrame. }
+ iModIntro. iPureIntro. intros ?? Hst1 Hst2.
+ destruct Hstcomp as [<- | (ly1' & Hst' & ->)]; first by eapply syn_type_has_layout_inj.
+ eapply syn_type_has_layout_untyped_inv in Hst2 as (<- & _).
+ by eapply syn_type_has_layout_inj.
+ Qed.
+ Global Instance owned_subltype_step_shrltype_uninit_inst π E L {rt} (lt : ltype rt) r st κ :
+ OwnedSubltypeStep π E L (r) #() (ShrLtype lt κ) (◠uninit st)%I | 20 :=
+ λ T, i2p (owned_subltype_step_shrltype_uninit π E L lt r st κ T).
+
+ Lemma owned_subltype_step_mutltype_uninit π E L {rt} (lt : ltype rt) r γ st κ T :
+ match ltype_uniq_extractable lt with
+ | None => False
+ | Some κm =>
+ ⌜syn_type_compat PtrSynType st⌠∗ T L (MaybeInherit κm InheritGhost (place_rfn_interp_mut_extracted r γ))
+ end
+ ⊢ owned_subltype_step π E L #(r, γ) #() (MutLtype lt κ) (◠uninit st) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "CTX HE HL Hl". simp_ltypes; simpl.
+ destruct (ltype_uniq_extractable lt) eqn:Hextract; last done.
+ iDestruct "HT" as "(%Hstcomp & HT)".
+ iExists _, _. iFrame.
+ iMod (ltype_uniq_extractable_deinit_mut with "Hl") as "(Hl & Hf)"; [done.. | ].
+ iPoseProof (MaybeInherit_update (place_rfn_interp_mut_extracted r γ) with "[] Hf") as "Hf".
+ { iIntros (?) "Hrfn". iMod (place_rfn_interp_mut_extract with "Hrfn") as "?". done. }
+ iModIntro. iSplitL. { iApply logical_step_intro. iFrame. }
+ iPureIntro. iIntros (ly1 ly2 Halg1 Halg2).
+ specialize (syn_type_compat_layout_trans _ _ _ Hstcomp Halg2) as ?.
+ by eapply syn_type_has_layout_inj.
+ Qed.
+ Global Instance owned_subltype_step_mutltype_uninit_inst π E L {rt} (lt : ltype rt) r γ st κ :
+ OwnedSubltypeStep π E L #(r, γ) #() (MutLtype lt κ) (◠uninit st)%I | 20 :=
+ λ T, i2p (owned_subltype_step_mutltype_uninit π E L lt r γ st κ T).
+
+ (*Lemma owned_subltype_step_cast_to_type_uninit : *)
+ (*cast_ltype_to_type E L lt (λ ty, *)
+ (*⌜syn_type_compat (ty_syn_type ty) st⌠∗ T L (ty_ghost_drop ty)) -∗*)
+ (*owned_subltype_step π E L r #() lt (◠uninit st) T.*)
+
+ (* TODO have fallback instance that uses cast_ltype *)
+
+ (* TODO more instances for other ltypes under which borrows can happen, e.g. for structs *)
+
+ (* Fallback without a logical step -- here, we cannot ghost_drop *)
+ (* TODO: maybe restrict this instance more for earlier failure *)
+ Lemma uninit_mono E L l {rt} (ty : type rt) r π st T :
+ (li_tactic (compute_layout_goal st) (λ ly, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗ (∀ v, v â—áµ¥{Ï€} r @ ty -∗ T L True%I)))
+ ⊢ subsume_full E L false (l â—â‚—[Ï€, Owned false] #r @ (â— ty)) (l â—â‚—[Ï€, Owned false] .@ (â— (uninit st))) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly & %Halg1 & %Halg2 & HT)".
+ iIntros (???) "#CTX #HE HL Hl".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own. simpl.
+ iDestruct "Hl" as "(%ly' & %Halg & %Hly & Hsc & ? & ? & %r' & <- & Hv)".
+ iMod (fupd_mask_mono with "Hv") as "(%v & Hl & Hv)"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%"; first done.
+ iExists L, True%I. iPoseProof ("HT" with "Hv") as "$". iFrame "HL".
+ rewrite right_id. assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own. simpl.
+ iExists ly. iSplitR; first done. iSplitR; first done.
+ iSplitR; first done. iFrame. iExists _. iSplitR; first done.
+ iModIntro. iModIntro. iExists v. iFrame.
+ iExists ly. iSplitR; first done. iSplitR; first done.
+ iPureIntro. rewrite Forall_forall. done.
+ Qed.
+ Global Instance uninit_mono_inst π E L l {rt} (ty : type rt) (r : rt) st :
+ SubsumeFull E L false (l â—â‚—[Ï€, Owned false] PlaceIn r @ (â— ty))%I (l â—â‚—[Ï€, Owned false] .@ â— (uninit st))%I | 40 :=
+ λ T, i2p (uninit_mono E L l ty r π st T).
+
+ (* TODO move *)
+ Lemma ofty_owned_subtype_aligned π {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 ly2 l :
+ (* location needs to be suitably aligned for ty2 *)
+ syn_type_has_layout (ty_syn_type ty2) ly2 →
+ l `has_layout_loc` ly2 →
+ owned_type_incl π r1 r2 ty1 ty2
+ ⊢ (l â—â‚—[Ï€, Owned false] #r1 @ â— ty1) -∗ (l â—â‚—[Ï€, Owned false] #r2 @ â— ty2).
+ Proof.
+ iIntros (Hst2 Hly2) "Hincl Hl".
+ rewrite !ltype_own_ofty_unfold/lty_of_ty_own.
+ iDestruct "Hl" as "(%ly' & %Halg' & %Hlyl & Hsc1 & Hlb & _ & % & -> & Hl)".
+ iExists ly2. iR. iR.
+ iDestruct "Hincl" as "(%Hszeq & Hsc & Hvi)".
+ assert (ly_size ly' = ly_size ly2) as Hszeq'. { apply Hszeq; done. }
+ iSplitL "Hsc Hsc1". { by iApply "Hsc". }
+ rewrite -Hszeq'. iFrame. iR.
+ iExists _. iR. iMod "Hl" as "(%v & Hl & Hv)".
+ iModIntro. iExists _. iFrame.
+ by iApply "Hvi".
+ Qed.
+ Lemma ofty_owned_subtype_aligned' π {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 ly2 l :
+ (* location needs to be suitably aligned for ty2 *)
+ syn_type_has_layout (ty_syn_type ty2) ly2 →
+ l `has_layout_loc` ly2 →
+ (∀ r1, owned_type_incl π r1 r2 ty1 ty2)
+ ⊢ (l â—â‚—[Ï€, Owned false] r1 @ â— ty1) -∗ (l â—â‚—[Ï€, Owned false] #r2 @ â— ty2).
+ Proof.
+ iIntros (Hst2 Hly2) "Hincl Hl".
+ rewrite !ltype_own_ofty_unfold/lty_of_ty_own.
+ iDestruct "Hl" as "(%ly' & %Halg' & %Hlyl & Hsc1 & Hlb & _ & % & Hrfn & Hl)".
+ iExists ly2. iR. iR.
+ iDestruct ("Hincl" $! r') as "(%Hszeq & Hsc & Hvi)".
+ assert (ly_size ly' = ly_size ly2) as Hszeq'. { apply Hszeq; done. }
+ iSplitL "Hsc Hsc1". { by iApply "Hsc". }
+ rewrite -Hszeq'. iFrame. iR.
+ iExists r2. iR. iMod "Hl" as "(%v & Hl & Hv)".
+ iModIntro. iExists _. iFrame.
+ by iApply "Hvi".
+ Qed.
+
+ Lemma owned_type_incl_uninit π {rt1} (r1 : rt1) r2 (ty1 : type rt1) st :
+ st = ty_syn_type ty1 →
+ ⊢ owned_type_incl π r1 r2 ty1 (uninit st).
+ Proof.
+ iIntros (Hst). iSplitR; last iSplitR.
+ - iPureIntro. iIntros (?? Hst1 Hst2). subst st. simpl in *.
+ f_equiv. by eapply syn_type_has_layout_inj.
+ - simpl. eauto.
+ - iIntros (v) "Hv". iEval (rewrite /ty_own_val/=).
+ iPoseProof (ty_has_layout with "Hv") as "(%ly & %Hst' & %Hly)".
+ iExists ly. subst st. iR. iR. iPureIntro.
+ eapply Forall_forall. eauto.
+ Qed.
+
+ (** We have this instance because it even works when [r1 = PlaceGhost ..] *)
+ Lemma weak_subltype_deinit E L {rt1} (r1 : place_rfn rt1) r2 (ty : type rt1) st T :
+ ⌜ty_syn_type ty = st⌠∗ T
+ ⊢ weak_subltype E L (Owned false) r1 #r2 (◠ty) (◠uninit st) T.
+ Proof.
+ iIntros "(%Hst & HT)".
+ iIntros (??) "#CTX #HE HL". iFrame.
+ iModIntro. iModIntro. simp_ltypes. iR.
+ rewrite -bi.persistent_sep_dup.
+ iModIntro. iIntros (??) "Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Hst' & %Hly)".
+ iModIntro. iApply (ofty_owned_subtype_aligned' with "[] Hl").
+ { simp_ltypes in Hst'. simpl. subst st. apply Hst'. }
+ { done. }
+ iIntros. iApply owned_type_incl_uninit. done.
+ Qed.
+ Global Instance weak_subltype_deinit_inst E L {rt1} (r1 : place_rfn rt1) r2 (ty : type rt1) st :
+ SubLtype E L (Owned false) r1 #r2 (◠ty)%I (◠uninit st)%I := λ T, i2p (weak_subltype_deinit E L r1 r2 ty st T).
+
+ (** ** Subsumption with uninit on the LHS (for initializing) *)
+ (* TODO consider: we could also support the case where ty just takes a prefix of the chunk. *)
+ Lemma subsume_full_ofty_owned_subtype π E L step l {rt1 rt2} (ty1 : type rt1) (ty2 : type rt2) r1 r2 T :
+ li_tactic (compute_layout_goal (ty_syn_type ty1)) (λ ly1,
+ (* augment context *) ⌜syn_type_has_layout (ty_syn_type ty1) ly1⌠-∗
+ li_tactic (compute_layout_goal (ty_syn_type ty2)) (λ ly2,
+ (* augment context *) ⌜syn_type_has_layout (ty_syn_type ty2) ly2⌠-∗
+ ⌜l `has_layout_loc` ly1⌠-∗ ⌜l `has_layout_loc` ly2⌠∗ owned_subtype π E L false r1 r2 ty1 ty2 (λ L', T L' True%I)))
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] #r1 @ â— ty1) (l â—â‚—[Ï€, Owned false] #r2 @ â— ty2) T.
+ Proof.
+ rewrite /compute_layout_goal. iIntros "(%ly1 & %Halg1 & HT)".
+ iDestruct ("HT" with "[//]") as "(%ly2 & %Halg2 & HT)".
+ iIntros (???) "#CTX #HE HL Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly1' & %Halg1' & %Hlyl)".
+ assert (ly1' = ly1) as -> by by eapply syn_type_has_layout_inj.
+ iDestruct ("HT" with "[//] [//]") as "(%Hl_ly2 & Hsubt)".
+ iMod ("Hsubt" with "[//] [//] CTX HE HL") as "(%L' & Hv & ? & ?)".
+ iExists L', True%I. iFrame.
+ iApply maybe_logical_step_intro. rewrite right_id.
+ iApply (ofty_owned_subtype_aligned with "Hv Hl"); done.
+ Qed.
+ (** We only declare an instance for this where the LHS is uninit -- generally, we'd rather want to go via the "full subtyping" judgments,
+ because the alignment sidecondition here may be hard to prove explicitly. *)
+ Global Instance subsume_full_ofty_uninit_owned_subtype_inst π E L step l {rt2} (ty2 : type rt2) r2 st :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] .@ â— (uninit st))%I (l â—â‚—[Ï€, Owned false] #r2 @ â— ty2)%I | 30 :=
+ λ T, i2p (subsume_full_ofty_owned_subtype π E L step l (uninit st) ty2 () r2 T).
+
+ Lemma owned_subtype_to_uninit π E L pers {rt} (ty1 : type rt) r st2 T :
+ li_tactic (compute_layout_goal (ty_syn_type ty1)) (λ ly1,
+ (* augment context *) ⌜syn_type_has_layout (ty_syn_type ty1) ly1⌠-∗
+ li_tactic (compute_layout_goal st2) (λ ly2,
+ (* augment context *) ⌜syn_type_has_layout st2 ly2⌠-∗ ⌜ly_size ly1 = ly_size ly2⌠∗ T L))
+ ⊢ owned_subtype π E L pers r () (ty1) (uninit st2) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly1 & %Hst1 & HT)".
+ iDestruct ("HT" with "[//]") as "(%ly2 & %Hst2 & HT)".
+ iDestruct ("HT" with "[//]") as "(%Hsz & HT)".
+ iIntros (???) "#CTX #HE HL".
+ iModIntro. iExists _. iFrame. iApply bi.intuitionistically_intuitionistically_if.
+ iModIntro.
+ iSplit; last iSplitR.
+ - iPureIntro. simpl. iIntros (ly1' ly2' Hst1' Hst2').
+ assert (ly1' = ly1) as -> by by eapply syn_type_has_layout_inj.
+ assert (ly2' = ly2) as -> by by eapply syn_type_has_layout_inj.
+ done.
+ - simpl. eauto.
+ - iIntros (v) "Hv".
+ rewrite {2}/ty_own_val/=.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hv"; first done.
+ (*iIntros "(%ly & %Hst & %Hly & Hv)".*)
+ iExists _. iR. iSplitL.
+ + iPureIntro. move: Hv. rewrite /has_layout_val Hsz//.
+ + iPureIntro. apply Forall_forall. eauto.
+ Qed.
+ Global Instance owned_subtype_to_uninit_inst π E L pers {rt} (ty : type rt) r st2 :
+ OwnedSubtype π E L pers r () (ty) (uninit st2) :=
+ λ T, i2p (owned_subtype_to_uninit π E L pers ty r st2 T).
+
+
+ (** ** Evar instantiation *)
+ Lemma uninit_mono_untyped_evar π E L step l ly1 ly2 T `{!IsProtected ly2} :
+ ⌜ly1 = ly2⌠∗ T L True%I
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly1))) (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly2))) T.
+ Proof. iIntros "(-> & HT)". iApply subsume_full_subsume. iFrame. eauto. Qed.
+ Global Instance uninit_mono_untyped_evar_inst π E L step l ly1 ly2 `{!IsProtected ly2} :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly1)))%I (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly2)))%I | 10 :=
+ λ T, i2p (uninit_mono_untyped_evar π E L step l ly1 ly2 T).
+
+ Lemma uninit_mono_untyped_id E L π step l (ly1 ly2 : layout) T `{TCDone (ly1 = ly2)}:
+ T L True%I
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly1))) (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly2))) T.
+ Proof.
+ match goal with
+ | H : TCDone _ |- _ => rename H into Heq
+ end.
+ rewrite /TCDone in Heq. subst. iIntros "HL".
+ iApply subsume_full_subsume. iFrame. eauto.
+ Qed.
+ Global Instance uninit_mono_untyped_id_inst E L step π l (ly1 ly2 : layout) `{!TCDone (ly1 = ly2)} :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly1)))%I (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly2)))%I | 11 :=
+ λ T, i2p (uninit_mono_untyped_id E L π step l ly1 ly2 T).
+
+ (*
+ (* TODO: ideally generalize this to non-arrays too ; e.g. consider doing some copying into a repr(C) struct *)
+ TODO: first develop more principled theory for splitting up memory structures into multiple chunks.
+ Lemma uninit_mono_untyped_strong E L π step l (ly1 ly2 : layout) T :
+ (⌜ly_size ly2 ≤ ly_size ly1⌠∗
+ ⌜l +ₗ(ly_size ly2) `has_layout_loc` (ly_offset ly1 (ly_size ly2))⌠∗
+ ⌜l `has_layout_loc` ly2⌠∗
+ ((l +â‚—(ly_size ly2)) â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (ly_offset ly1 (ly_size ly2)))) -∗ T L True%I)) -∗
+ subsume_full E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly1))) (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly2))) T.
+ Proof.
+ (* split up the uninit value *)
+ Admitted.
+ Global Instance uninit_mono_untyped_strong_inst E L π step l (ly1 ly2 : layout) :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly1)))%I (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType ly2)))%I | 21 :=
+ λ T, i2p (uninit_mono_untyped_strong E L π step l ly1 ly2 T).
+
+ Lemma uninit_mono_untyped_array E L π step l (ly1' ly2' : layout) sz1 sz2 T :
+ (⌜ly1' = ly2'⌠∗
+ ⌜sz1 ≤ sz2⌠∗
+ ((l offset{ly1'}â‚— sz1) â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout ly1' (sz1 - sz2)))) -∗ T L True%I)) -∗
+ subsume_full E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout ly1' sz1)))) (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout ly2' sz2)))) T.
+ Proof.
+ iIntros "(<- & %Hle & HT)" (???) "#CTX #HE HL Hl".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own. simpl.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & _ & ? & _ & %r' & <- & Hv)".
+ iMod (fupd_mask_mono with "Hv") as "(%v & Hl & Hv)"; first done.
+ (* split up the uninit value *)
+ Admitted.
+ Global Instance uninit_mono_untyped_array_inst E L π step l (ly1' ly2' : layout) sz1 sz2 :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout ly1' sz1))))%I (l â—â‚—[Ï€, Owned false] .@ (â— uninit (UntypedSynType (mk_array_layout ly2' sz2))))%I | 20 :=
+ λ T, i2p (uninit_mono_untyped_array E L π step l ly1' ly2' sz1 sz2 T).
+ *)
+
+
+End typing.
diff --git a/theories/rust_typing/uninit_def.v b/theories/rust_typing/uninit_def.v
new file mode 100644
index 0000000000000000000000000000000000000000..d501af498dca424cba26505eb0e3eb95f2281b41
--- /dev/null
+++ b/theories/rust_typing/uninit_def.v
@@ -0,0 +1,136 @@
+From refinedrust Require Export type.
+From iris Require Import options.
+Set Default Proof Using "Type".
+
+(** This file just contains the uninit type definition (without rules), because we need it for the struct ltype definition. *)
+
+(** The [bytewise] type allows to give a predicate that needs to hold for all bytes
+ owned by the type. *)
+Section bytewise.
+ Context `{!typeGS Σ}.
+ Implicit Types P : mbyte → Prop.
+
+ Program Definition bytewise (P : mbyte → Prop) (st : syn_type) : type unit := {|
+ st_own π _ v :=
+ (∃ ly, ⌜syn_type_has_layout st ly⌠∗
+ ⌜v `has_layout_val` ly⌠∗
+ ⌜Forall P vâŒ)%I;
+ st_has_op_type ot mt :=
+ ∃ ly, syn_type_has_layout st ly ∧ ot = UntypedOp ly;
+ st_syn_type := st;
+ |}.
+ Next Obligation.
+ intros. simpl. iIntros "(%ly & ? & ? & ?)"; eauto.
+ Qed.
+ Next Obligation.
+ intros ? st ot mt (ly & Hst & ->). done.
+ Qed.
+ Next Obligation.
+ simpl. iIntros (P st ot mt ? π ? v (ly & ? & ->)) "(%ly' & % & % & %)".
+ assert (ly' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ destruct mt.
+ - done.
+ - iExists ly. done.
+ - done.
+ Qed.
+
+ Global Instance bytewise_copy P st : Copyable (bytewise P st).
+ Proof. apply _. Qed.
+
+ Lemma bytewise_weaken v π P1 P2 st :
+ (∀ b, P1 b → P2 b) →
+ v â—áµ¥{Ï€} .@ bytewise P1 st -∗ v â—áµ¥{Ï€} .@ bytewise P2 st.
+ Proof.
+ iIntros (? (ly & Hst & Hly & ?)). iExists ly.
+ iPureIntro. split_and!; [done.. | ].
+ by eapply Forall_impl.
+ Qed.
+
+ Lemma bytewise_weaken_share l π κ P1 P2 st :
+ (∀ b, P1 b → P2 b) →
+ l â—â‚—{Ï€, κ} .@ bytewise P1 st -∗ l â—â‚—{Ï€, κ} .@ bytewise P2 st.
+ Proof.
+ iIntros (?) "(%v & %ly & Hb)". simpl.
+ iDestruct "Hb" as "(Hb & (%ly' & Hc) & Hd)".
+ iExists v, ly. iFrame. iNext. simpl.
+ iDestruct "Hc" as "(% & % & %)".
+ iPureIntro. eexists _. split_and!; [done.. | ].
+ by eapply Forall_impl.
+ Qed.
+
+
+ (*
+ Lemma split_bytewise v n π P ly:
+ (n ≤ ly.(ly_size))%nat →
+ v â—áµ¥{Ï€} .@ bytewise P ly -∗
+ (take n v) â—áµ¥{Ï€} .@ bytewise P (ly_set_size ly n) ∗
+ (drop n v) â—áµ¥{Ï€} .@ bytewise P (ly_offset ly n).
+ Proof.
+ iIntros (?[Hv HP]). iSplitL.
+ - eapply Forall_take in HP; iSplitL; last done.
+ iPureIntro. rewrite /has_layout_val in Hv.
+ by rewrite /has_layout_val take_length min_l // Hv.
+ - eapply Forall_drop in HP; iSplitL; last done.
+ iPureIntro. by rewrite /has_layout_val drop_length Hv.
+ Qed.
+ (* the corresponding lemma for shared ownership does not seem provable currently: how should we split the fractured borrow?*)
+ (* TODO: check if this is a fundamental limitation / why are fractured borrows not covariant in their predicate? *)
+
+ Lemma merge_bytewise v1 v2 π P ly1 ly2:
+ (ly1.(ly_size) ≤ ly2.(ly_size))%nat →
+ (ly_align ly2 ≤ ly_align ly1)%nat →
+ v1 â—áµ¥{Ï€} .@ bytewise P ly1 -∗
+ v2 â—áµ¥{Ï€} .@ (bytewise P (ly_offset ly2 ly1.(ly_size))) -∗
+ (v1 ++ v2) â—áµ¥{Ï€} .@ bytewise P ly2.
+ Proof.
+ iIntros (??) "(%Hv1 & %HP1) (%Hv2 & %HP2)".
+ iSplitL; iPureIntro.
+ - rewrite /has_layout_val app_length Hv1 Hv2.
+ rewrite {2}/ly_size/=. lia.
+ - by apply Forall_app.
+ Qed.
+ *)
+
+ (*
+ ltype Own: essentially l ↦ v st. Forall P v
+
+ if we offset l, then we get:
+ two ltype owns! one for the first part, one for the latter.
+ should pass the type of the latter on to the continuation
+
+ how do we make that compatible with ltypes?
+ -> the predicate/type we give to the continuation should be a predicate on rvalues, fundamentally.
+ (it should handle the addition of two integers which are not stored on the stack/heap, but are just temporary rvalues without an address).
+ so, have a ltype-own to type conversion?
+
+ alternative: directly state the whole typing rule in terms of rvalue stuff, including the ownership of the p.
+ in this case: the owned ptr rvalue.
+
+ then to apply this rule in practice: need a subsumption rule for having
+ l â—â‚—[_, Owned] r @ â— ty and v â—áµ¥ (r, l) @ own ty
+ or rather v â—áµ¥ r @ own (r @ ty) ??
+ *)
+
+End bytewise.
+
+Notation "bytewise< P , st >" := (bytewise P st)
+ (only printing, format "'bytewise<' P ',' st '>'") : printing_sugar.
+
+Global Typeclasses Opaque bytewise.
+
+Notation uninit := (bytewise (λ _, True)).
+
+Section uninit.
+ Context `{!typeGS Σ}.
+
+ Lemma uninit_own_spec π v st :
+ (v â—áµ¥{Ï€} .@ uninit st)%I ≡ (∃ ly, ⌜syn_type_has_layout st ly⌠∗ ⌜v `has_layout_val` lyâŒ)%I.
+ Proof.
+ rewrite /ty_own_val/=; iSplit.
+ - iIntros "(%ly & ? & ? & ?)"; iExists ly. iFrame.
+ - iIntros "(%ly & ? & ?)"; iExists ly. iFrame.
+ rewrite Forall_forall. done.
+ Qed.
+End uninit.
+
+Notation "uninit< st >" := (uninit st) (only printing, format "'uninit<' st '>'") : printing_sugar.
diff --git a/theories/rust_typing/util.v b/theories/rust_typing/util.v
new file mode 100644
index 0000000000000000000000000000000000000000..25ffd2b98feed0adfb641b93e41c94e880311822
--- /dev/null
+++ b/theories/rust_typing/util.v
@@ -0,0 +1,558 @@
+From Coq Require Import Qcanon.
+From iris.bi Require Import fractional.
+From caesium Require Import derived.
+From iris.proofmode Require Import tactics.
+From refinedrust Require Export base.
+From iris.prelude Require Import options.
+Set Default Proof Using "Type".
+
+(** * Random collection of lemmas *)
+(* TODO: probably some of this could be upstreamed *)
+
+(** ** Pure lemmas *)
+Program Definition Qp_total_sub (p q : Qp) : (q < p)%Qp → Qp :=
+ match p, q with
+ | mk_Qp p Hp, mk_Qp q Hq =>
+ λ (Hle : (mk_Qp q Hq < mk_Qp p Hp)%Qp),
+ let pq := (p - q)%Qc in (mk_Qp pq _)
+ end.
+Next Obligation.
+ intros. rewrite -Qclt_minus_iff. apply Hle.
+Qed.
+Lemma Qp_total_sub_eq (q p : Qp) Hlt :
+ (Qp_total_sub p q Hlt + q)%Qp = p.
+Proof.
+ destruct p as [p ], q as [q ].
+ simpl. unfold Qp.add.
+ match goal with
+ | |- mk_Qp ?a ?pr = _ => generalize pr as prf; assert (a = p) as Heq by ring
+ end.
+ revert Heq. generalize (p - q + q)%Qc.
+ intros ? -> ?. f_equal. apply proof_irrel.
+Qed.
+
+Lemma Fractional_fractional_le {Σ} (Φ : Qp → iProp Σ) `{Fractional _ Φ} (q q' : Qp):
+ (q' ≤ q)%Qp →
+ Φ q -∗
+ Φ q' ∗ (Φ q' -∗ Φ q).
+Proof.
+ iIntros (Hle) "HΦ".
+ destruct (decide (q = q')) as [<- | ?].
+ { eauto with iFrame. }
+ assert (q' < q)%Qp as Hlt.
+ { apply Qp.le_lteq in Hle as [ | ]; done. }
+ specialize (Qp_total_sub_eq q' q Hlt) as <-.
+ iPoseProof (fractional with "HΦ") as "[H1 $]".
+ iIntros "H2". iApply fractional; iFrame.
+Qed.
+
+Lemma Fractional_split_big_sepL {Σ} (Φ : Qp → iProp Σ) `{!Fractional Φ} n q :
+ Φ q -∗ ∃ qs, ⌜length qs = n⌠∗
+ ([∗ list] q' ∈ qs, Φ q') ∗
+ (([∗ list] q' ∈ qs, Φ q') -∗ Φ q).
+Proof.
+ iInduction n as [ | n ] "IH" forall (q); simpl.
+ - iIntros "Hp". iExists []. iSplitR; first done. iSplitR; first done. iIntros "_". done.
+ - iIntros "Hp".
+ rewrite -(Qp.div_2 q) {1}fractional. iDestruct "Hp" as "[Hp1 Hp2]".
+ iDestruct ("IH" with "Hp2") as "(%qs & %Hlen & Hown & Hcl)".
+ iExists ((q/2)%Qp :: qs).
+ simpl. rewrite -Hlen. iSplitR; first done.
+ iFrame.
+ iIntros "(Ha & Hown)". iPoseProof ("Hcl" with "Hown") as "Ha2".
+ iCombine "Ha Ha2" as "Ha". rewrite -fractional. done.
+Qed.
+
+
+Lemma list_max_insert (l : list nat) i n :
+ list_max (<[i := n]> l) ≤ Nat.max n (list_max l).
+Proof.
+ induction l as [ | a l IH] in i |-*; simpl.
+ - lia.
+ - destruct i as [ | i]; simpl; first lia.
+ specialize (IH i). lia.
+Qed.
+
+Lemma list_max_le_lookup l i (m n : nat) :
+ l !! i = Some m →
+ n ≤ m →
+ n ≤ list_max l.
+Proof.
+ induction l as [ | k l IH] in i |-*; simpl; first done.
+ destruct i as [ | i]; simpl.
+ - intros [= ->]. lia.
+ - intros Ha ?. eapply IH in Ha; lia.
+Qed.
+
+Lemma lookup_zip {A B} (xs : list A) (ys : list B) i z :
+ zip xs ys !! i = Some z →
+ xs !! i = Some z.1 ∧ ys !! i = Some z.2.
+Proof.
+ induction xs as [ | x xs IH] in ys, i |-*; destruct ys as [ | y ys]; simpl; [ done.. | ].
+ destruct i as [ | i]; simpl.
+ - injection 1 as [= <-]. done.
+ - apply IH.
+Qed.
+
+Lemma elem_of_cons_dec {A} `{!EqDecision A} (l : list A) (x y : A) :
+ x ∈ y :: l ↔ x = y ∨ x ≠y ∧ x ∈ l.
+Proof.
+ rewrite elem_of_cons. destruct (decide (x = y)) as [<- | ?]; naive_solver.
+Qed.
+
+Lemma aligned_to_2_max_l l n1 n2 :
+ l `aligned_to` 2 ^ (max n1 n2) →
+ l `aligned_to` 2 ^ n1.
+Proof.
+ rewrite /aligned_to.
+ assert ((2 ^ n1)%nat | (2 ^ (n1 `max` n2))%nat)%Z.
+ { apply Zdivide_nat_pow. lia. }
+ intros. etrans; last done. done.
+Qed.
+Lemma aligned_to_2_max_r l n1 n2 :
+ l `aligned_to` 2 ^ (max n1 n2) →
+ l `aligned_to` 2 ^ n2.
+Proof. rewrite Nat.max_comm. apply aligned_to_2_max_l. Qed.
+
+Lemma reshape_replicate_elem_length {A} (vs : list A) v n m :
+ length vs = n * m →
+ v ∈ reshape (replicate n m) vs →
+ length v = m.
+Proof.
+ intros Hlen. induction n as [ | n IH] in vs, Hlen |-*; simpl.
+ { rewrite elem_of_nil; done. }
+ rewrite elem_of_cons.
+ intros [-> | Hel].
+ - rewrite take_length. lia.
+ - eapply IH; last apply Hel.
+ rewrite drop_length. lia.
+Qed.
+
+Section Forall.
+ (** Recursive version of Forall, to make it computational and eligible for recursive definitions. *)
+ Context {X} (P : X → Prop).
+ Fixpoint Forall_cb (l : list X) :=
+ match l with
+ | [] => True
+ | x :: l => P x ∧ Forall_cb l
+ end.
+ Lemma Forall_Forall_cb l :
+ Forall P l ↔ Forall_cb l.
+ Proof.
+ induction l as [ | x l IH].
+ - naive_solver.
+ - simpl. split; last naive_solver. inversion 1; naive_solver.
+ Qed.
+End Forall.
+
+Lemma Forall_iff_strong {A} (P Q : A → Prop) (l : list A) :
+ (∀ x, x ∈ l → P x ↔ Q x) →
+ Forall P l ↔ Forall Q l.
+Proof.
+ intros Hequiv. induction l as [ | x l IH]; simpl; first done.
+ split; inversion 1; subst; (constructor; [ apply Hequiv; [ apply elem_of_cons | ] | apply IH]); eauto.
+ all: intros; apply Hequiv; apply elem_of_cons; eauto.
+Qed.
+
+Lemma Forall_impl_strong {A} (P Q : A → Prop) (l : list A) :
+ (∀ x, x ∈ l → P x → Q x) →
+ Forall P l → Forall Q l.
+Proof.
+ intros Himpl. induction l as [ | x l IH]; simpl; first done.
+ inversion 1; subst; (constructor; [ apply Himpl; [ apply elem_of_cons | ] | apply IH]); eauto.
+ intros; apply Himpl; [apply elem_of_cons | ]; eauto.
+Qed.
+
+Lemma Forall_elem_of_iff {X} (P : X → Prop) l :
+ Forall P l ↔ ∀ x, x ∈ l → P x.
+Proof.
+ rewrite Forall_lookup.
+ split.
+ - intros ? ? (i & Hel)%elem_of_list_lookup_1. eauto.
+ - intros Hel i x Hlook%elem_of_list_lookup_2. eauto.
+Qed.
+
+Lemma and_proper (A B C : Prop) :
+ (A → B ↔ C) →
+ (A ∧ B) ↔ (A ∧ C).
+Proof. naive_solver. Qed.
+
+(** ** big_sepL *)
+Lemma big_sepL2_insert {Σ} {A B} (l1 : list A) (l2 : list B) (i : nat) (x1 : A) (x2 : B) (Φ : nat → A → B → iProp Σ) (m : nat) :
+ i < length l1 →
+ i < length l2 →
+ ([∗ list] k ↦ v1; v2 ∈ <[i := x1]> l1; <[i := x2]> l2, Φ (m + k)%nat v1 v2) ⊣⊢ Φ (m + i)%nat x1 x2 ∗
+ ([∗ list] k ↦ v1; v2 ∈ l1; l2, if decide (k = i) then emp else Φ (m + k)%nat v1 v2).
+Proof.
+ iInduction l1 as [ | h1 l1] "IH" forall (m i l2); simpl; iIntros (Hlt1 Hlt2); first lia.
+ destruct l2 as [ | h2 l2]; simpl in *; first lia.
+ destruct i as [ | i]; simpl.
+ - iSplit.
+ + iIntros "($ & Ha)". iSplitR; first done.
+ setoid_rewrite Nat.add_succ_r. done.
+ + iIntros "($ & _ & $)".
+ - assert (Hlt1' : i < length l1) by lia. assert (Hlt2' : i < length l2) by lia.
+ iSplit.
+ + iIntros "($ & Ha)". setoid_rewrite Nat.add_succ_r.
+ iPoseProof ("IH" $! (S m) i _ Hlt1' Hlt2' with "Ha") as "($ & Ha)".
+ iApply (big_sepL2_mono with "Ha").
+ iIntros (?????). case_decide as Heq; case_decide as Heq2; [first [lia | by eauto].. | ].
+ rewrite Nat.add_succ_r. eauto.
+ + iIntros "(Ha & $ & Hb)".
+
+ rewrite Nat.add_succ_r.
+ setoid_rewrite Nat.add_succ_r. iApply ("IH" $! (S m) i _ Hlt1' Hlt2'). iFrame "Ha".
+ iApply (big_sepL2_mono with "Hb").
+ iIntros (?????). case_decide as Heq; case_decide as Heq2; [first [lia | by eauto].. | ].
+ rewrite Nat.add_succ_r. eauto.
+Qed.
+
+Lemma big_sepL_concat_lookup {Σ} {A} (L : list (list A)) (l : list A) (i : nat) (Φ : A → iProp Σ) :
+ L !! i = Some l →
+ ([∗ list] x ∈ concat L, Φ x) -∗
+ [∗ list] x ∈ l, Φ x.
+Proof.
+ iInduction L as [ | l0 L IH] "IH" forall (i); simpl; iIntros (Hlook) "Ha"; first done.
+ destruct i as [ | i]; simpl in *.
+ - injection Hlook as [= ->].
+ rewrite big_sepL_app. iDestruct "Ha" as "($ & _)".
+ - rewrite big_sepL_app. iDestruct "Ha" as "(_ & Ha)".
+ iApply "IH"; done.
+Qed.
+
+(* when we know that the length is equal, we can get a stronger lemma *)
+Lemma big_sepL2_laterN' {Σ} {A B} (Φ : nat → A → B → iProp Σ) (l1 : list A) (l2 : list B) n :
+ length l1 = length l2 →
+ ▷^n ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ⊣⊢
+ ([∗ list] k↦y1;y2 ∈ l1;l2, ▷^n Φ k y1 y2).
+Proof.
+ induction l1 as [ | a l1 IH] in l2, Φ |-*; destruct l2 as [ | b l2]; simpl; [intros; iSplit; eauto.. | ]; intros Hlen.
+ iSplit; (iIntros "($ & Hb)"; iApply IH; [ lia | done]).
+Qed.
+
+Lemma big_sepL2_length_ne {Σ} {A B} (l1 : list A) (l2 : list B) :
+ length l1 ≠length l2 →
+ ∀ (Φ : nat → A → B → iProp Σ), ([∗ list] k ↦ y1; y2 ∈ l1; l2, Φ k y1 y2) ⊣⊢ False.
+Proof.
+ induction l1 as [ | x l1 IH] in l2 |-*; destruct l2 as [ | l2]; simpl; [done.. | ].
+ intros Hneq Φ.
+ rewrite IH; last lia.
+ iSplit; [iIntros "(_ & $)" | iIntros "[]"].
+Qed.
+
+(* Lemma that gives additional [lookup] assumptions for the requirement persistence proof *)
+Local Lemma big_sepL2_persistent_strong' {Σ} {A B} (Φ : nat → A → B → iProp Σ) (l1 : list A) (l2 : list B) :
+ ∀ m,
+ (∀ (k : nat) (x1 : A) (x2 : B), l1 !! k = Some x1 → l2 !! k = Some x2 → Persistent (Φ (m + k) x1 x2)) →
+ Persistent ([∗ list] k ↦ y1; y2 ∈ l1; l2, Φ (m + k) y1 y2).
+Proof.
+ intros m Hpers.
+ induction l1 as [ | y1 l1 IH] in m, Hpers, l2 |-*; destruct l2 as [ | y2 l2]; simpl; [apply _ .. | ].
+ apply bi.sep_persistent.
+ - apply Hpers; done.
+ - setoid_rewrite Nat.add_succ_r. eapply (IH _ (S m)).
+ intros. simpl. rewrite -Nat.add_succ_r. eapply (Hpers); done.
+Qed.
+Lemma big_sepL2_persistent_strong {Σ} {A B} (Φ : nat → A → B → iProp Σ) (l1 : list A) (l2 : list B) :
+ (length l1 = length l2 → ∀ (k : nat) (x1 : A) (x2 : B), l1 !! k = Some x1 → l2 !! k = Some x2 → Persistent (Φ k x1 x2)) →
+ Persistent ([∗ list] k ↦ y1; y2 ∈ l1; l2, Φ k y1 y2).
+Proof.
+ intros Hpers.
+ destruct (decide (length l1 = length l2)).
+ - eapply (big_sepL2_persistent_strong' _ _ _ 0); by apply Hpers.
+ - rewrite big_sepL2_length_ne; first apply _. done.
+Qed.
+
+Local Lemma big_sepL_exists_zip' {Σ} {A X} (Φ : nat → A → X → iProp Σ) (l : list A) k :
+ ([∗ list] i ↦ a ∈ l, ∃ x : X, Φ (k + i) a x) ⊣⊢
+ (∃ xl : list X, ⌜length xl = length l⌠∗ [∗ list] i ↦ p ∈ zip l xl, Φ (k + i) p.1 p.2).
+Proof.
+ induction l as [ | a l IH] in k |-*; simpl.
+ { iSplit; last by eauto. iIntros "_". iExists []. done. }
+ iSplit.
+ - iIntros "([%x Hx] & Hl)". setoid_rewrite Nat.add_succ_r.
+ rewrite (IH (S k)). iDestruct "Hl" as "(%xl & %Hlen & Hl)".
+ iExists (x :: xl). simpl. iFrame. iSplitR. { iPureIntro; lia. }
+ iApply (big_sepL_impl with "Hl").
+ iIntros "!>" (? [] ?). setoid_rewrite Nat.add_succ_r. eauto.
+ - iIntros "(%xl & %Hlen & Hl)".
+ destruct xl as [ | x xl]; simpl; first done.
+ iDestruct "Hl" as "(Hx & Hl)".
+ iSplitL "Hx". { iExists x. done. }
+ setoid_rewrite Nat.add_succ_r. rewrite (IH (S k)).
+ iExists xl. iSplitR. { simpl in Hlen; iPureIntro; lia. }
+ iApply (big_sepL_impl with "Hl").
+ iIntros "!>" (? [] ?). simpl. eauto.
+Qed.
+Lemma big_sepL_exists_zip {Σ} {A X} (Φ : nat → A → X → iProp Σ) (l : list A) :
+ ([∗ list] i ↦ a ∈ l, ∃ x : X, Φ i a x) ⊣⊢
+ (∃ xl : list X, ⌜length xl = length l⌠∗ [∗ list] i ↦ p ∈ zip l xl, Φ i p.1 p.2).
+Proof. apply (big_sepL_exists_zip' _ _ 0). Qed.
+
+Local Lemma big_sepL_exists' {Σ} {A X} (Φ : nat → A → X → iProp Σ) (l : list A) k :
+ ([∗ list] i ↦ a ∈ l, ∃ x : X, Φ (k + i) a x) ⊣⊢
+ (∃ xl : list X, [∗ list] i ↦ a; x ∈ l; xl, Φ (k + i) a x).
+Proof.
+ induction l as [ | a l IH] in k |-*; simpl.
+ { iSplit; last by eauto. iIntros "_". iExists []. done. }
+ iSplit.
+ - iIntros "([%x Hx] & Hl)". setoid_rewrite Nat.add_succ_r.
+ rewrite (IH (S k)). iDestruct "Hl" as "(%xl & Hl)".
+ iExists (x :: xl). simpl. iFrame.
+ setoid_rewrite Nat.add_succ_r. done.
+ - iIntros "(%xl & Hl)".
+ destruct xl as [ | x xl]; simpl; first done.
+ iDestruct "Hl" as "(Hx & Hl)".
+ iSplitL "Hx". { iExists x. done. }
+ setoid_rewrite Nat.add_succ_r. rewrite (IH (S k)).
+ iExists xl. done.
+Qed.
+Lemma big_sepL_exists {Σ} {A X} (Φ : nat → A → X → iProp Σ) (l : list A) :
+ ([∗ list] i ↦ a ∈ l, ∃ x : X, Φ i a x) ⊣⊢
+ (∃ xl : list X, [∗ list] i ↦ a; x ∈ l; xl, Φ i a x).
+Proof. apply (big_sepL_exists' _ _ 0). Qed.
+
+Section big_sepL.
+ Context {Σ: gFunctors}.
+ (** Definition of [big_sepL] that also provides a proof that the elements are really contained in the list,
+ in order to get the recursive definition for the struct ltype through. *)
+ Program Fixpoint big_sepL_P {A : Type} (l : list A) (f : ∀ (i : nat) (a : A), a ∈ l → iProp Σ) : iProp Σ :=
+ match l as l0 return l0 = l → iProp Σ with
+ | [] => λ _, True%I
+ | a :: l' => λ Heq, (f 0%nat a _ ∗ big_sepL_P l' (λ i a Hel, f (S i) a _))%I
+ end eq_refl.
+ Next Obligation.
+ intros. rewrite -Heq. apply elem_of_cons. by left.
+ Qed.
+ Next Obligation.
+ intros. rewrite -Heq. apply elem_of_cons. by right.
+ Qed.
+
+ Lemma big_sepL_P_ext {A : Type} (l : list A) (f1 f2 : ∀ (i : nat) (a : A), a ∈ l → iProp Σ) :
+ (∀ i a H, f1 i a H = f2 i a H) →
+ big_sepL_P l f1 = big_sepL_P l f2.
+ Proof.
+ intros Heq. induction l as [ | a l IH]; simpl; first done.
+ rewrite Heq. f_equiv. apply IH.
+ intros. rewrite Heq. done.
+ Qed.
+
+ Lemma big_sepL_ext {A : Type} (l : list A) (f1 f2 : nat → A → iProp Σ) :
+ (∀ i a, f1 i a = f2 i a) →
+ ([∗ list] i ↦ a ∈ l, f1 i a)%I = ([∗ list] i ↦ a ∈ l, f2 i a)%I.
+ Proof.
+ intros Heq. induction l as [ | a l IH] in f1, f2, Heq |-*; simpl; first done.
+ rewrite Heq. f_equiv. apply IH.
+ intros. rewrite Heq. done.
+ Qed.
+
+ (** We can just erase the extra proof-carrying stuff when the actually relevant term does not depend on the proof. *)
+ Lemma big_sepL_P_eq' {A : Type} (l : list A) (f : nat → A → iProp Σ) n :
+ big_sepL_P l (λ i a _, f (n + i)%nat a) = ([∗ list] i ↦ a ∈ l, f (n + i)%nat a)%I.
+ Proof.
+ induction l as [ | a l IH] in n |-*; simpl.
+ - done.
+ - f_equiv.
+ rewrite (big_sepL_P_ext _ _ (λ i a _, f (S n + i)%nat a)); first last.
+ { by setoid_rewrite Nat.add_succ_r. }
+ rewrite (IH (S n)).
+ apply big_sepL_ext. by setoid_rewrite Nat.add_succ_r.
+ Qed.
+ Lemma big_sepL_P_eq {A : Type} (l : list A) (f : nat → A → iProp Σ) :
+ big_sepL_P l (λ i a _, f i a) = ([∗ list] i ↦ a ∈ l, f i a)%I.
+ Proof. apply (big_sepL_P_eq' _ _ 0). Qed.
+End big_sepL.
+
+Lemma Forall_big_sepL {Σ} {X} (P : X → Prop) (Q : X → iProp Σ) (R : iProp Σ) (l : list X) :
+ Forall P l →
+ R -∗
+ □(∀ x, R -∗ ⌜P x⌠-∗ Q x ∗ R) -∗
+ ([∗ list] x ∈ l, Q x) ∗ R.
+Proof.
+ iIntros (Hf) "HR #HP".
+ iInduction l as [ | x l] "IH"; simpl; first by iFrame.
+ inversion Hf; subst.
+ iPoseProof ("HP" with "HR [//]") as "(Ha & HR)".
+ iPoseProof ("IH" with "[//] HR") as "(Hb & HR)".
+ iFrame.
+Qed.
+
+Lemma Forall2_big_sepL2 {Σ} {X Y} (P : X → Y → Prop) (Q : X → Y → iProp Σ) (R : iProp Σ) (l1 : list X) (l2 : list Y) :
+ Forall2 P l1 l2 →
+ length l1 = length l2 →
+ R -∗
+ □(∀ x y, R -∗ ⌜P x y⌠-∗ Q x y ∗ R) -∗
+ ([∗ list] x;y ∈ l1;l2, Q x y) ∗ R.
+Proof.
+ iIntros (Hf Hlen) "HR #HP".
+ iInduction l1 as [ | x l] "IH" forall (l2 Hlen Hf); destruct l2 as [ | y l2]; simpl; [by iFrame |done | done | ].
+ inversion Hf; subst.
+ iPoseProof ("HP" with "HR [//]") as "(Ha & HR)".
+ iPoseProof ("IH" with "[] [//] HR") as "(Hb & HR)".
+ { simpl in *. iPureIntro. lia. }
+ iFrame.
+Qed.
+
+(** ** General Iris/BI things *)
+Lemma sep_ne_proper {Σ} (A : Prop) (B C : iProp Σ) n :
+ (A → B ≡{n}≡ C) →
+ (⌜A⌠∗ B)%I ≡{n}≡ (⌜A⌠∗ C)%I.
+Proof.
+ (* TODO can we prove this without unsealing? *)
+ intros Heq.
+ uPred.unseal.
+ split.
+ intros n' x ? Hv. split.
+ - intros (x1 & x2 & Heqa & HA & HB).
+ rewrite Heqa. specialize (Heq HA).
+ exists x1, x2. split; first done. split; first done. apply Heq; [done | | done].
+ rewrite Heqa in Hv. by apply cmra_validN_op_r in Hv.
+ - intros (x1 & x2 & Heqa & HA & HC).
+ rewrite Heqa. specialize (Heq HA).
+ exists x1, x2. split; first done. split; first done. apply Heq; [done | | done].
+ rewrite Heqa in Hv. by apply cmra_validN_op_r in Hv.
+Qed.
+Lemma sep_equiv_proper {Σ} (A : Prop) (B C : iProp Σ) :
+ (A → B ≡ C) →
+ (⌜A⌠∗ B)%I ≡ (⌜A⌠∗ C)%I.
+Proof.
+ intros Ha. apply equiv_dist => n.
+ apply sep_ne_proper. intros HA.
+ apply equiv_dist. by apply Ha.
+Qed.
+
+Lemma bi_exist_comm {Σ} (A B : Type) (Φ : A → B → iProp Σ) :
+ (∃ a, ∃ b, Φ a b) ⊣⊢ (∃ b, ∃ a, Φ a b).
+Proof.
+ iSplit.
+ - iIntros "(%a & %b & Ha)". iExists b, a. done.
+ - iIntros "(%b & %a & Ha)". iExists a, b. done.
+Qed.
+
+Lemma bi_sep_persistent_pure_l {Σ} (P : Prop) (Q : iProp Σ) :
+ (P → Persistent Q) →
+ Persistent (⌜P⌠∗ Q).
+Proof.
+ intros Ha.
+ rewrite /Persistent.
+ iIntros "(%HP & HQ)". specialize (Ha HP).
+ iDestruct "HQ" as "#HQ". iModIntro. iFrame "#%".
+Qed.
+Lemma bi_sep_persistent_pure_r {Σ} (P : Prop) (Q : iProp Σ) :
+ (P → Persistent Q) →
+ Persistent (Q ∗ ⌜PâŒ).
+Proof.
+ rewrite bi.sep_comm. apply bi_sep_persistent_pure_l.
+Qed.
+
+
+(** ** Lifetime logic things *)
+Section util.
+Context `{!lftGS Σ lft_userE} `{!refinedcG Σ}.
+
+(** We can shift [P] to [Q] while assuming the additional frame [R],
+ but we also need to prove that we can go back. *)
+Lemma bor_fupd_later_strong F1 F2 κ P Q R q :
+ lftE ⊆ F1 →
+ F2 ⊆ F1 →
+ lft_ctx -∗
+ R -∗
+ ((R ∗ ▷ P) ={F2}▷=∗ (▷ Q) ∗ R) -∗
+ (Q -∗ P) -∗
+ &{κ} (P) -∗ q.[κ] ={F1}▷=∗ &{κ} Q ∗ q.[κ] ∗ R.
+Proof.
+ iIntros (??) "#LFT HR HPQ HQP Hbor Htok".
+ iMod (bor_acc_cons with "LFT Hbor Htok") as "(HP & Hcl)"; first solve_ndisj.
+ iApply step_fupd_fupd.
+ iApply (step_fupd_subseteq _ F2); first done.
+ iApply (step_fupd_wand with "[HPQ HP HR]").
+ { iApply ("HPQ" with "[$HP $HR]"). }
+ iIntros "[HQ $]".
+ iApply ("Hcl" with "[HQP] HQ").
+ iNext. iIntros "HQ !>!>". by iApply "HQP".
+Qed.
+
+Lemma bor_fupd_later F1 F2 κ P q :
+ lftE ⊆ F1 →
+ F2 ⊆ F1 →
+ lft_ctx -∗
+ &{κ} (|={F2}=> P) -∗ q.[κ] ={F1}▷=∗ &{κ} P ∗ q.[κ].
+Proof.
+ iIntros (??) "#LFT Hbor Htok".
+ iMod (bor_acc_cons with "LFT Hbor Htok") as "(HP & Hcl)"; first solve_ndisj.
+ iModIntro. iNext. iMod (fupd_mask_subseteq F2) as "Hcl_F"; first done.
+ iMod "HP" as "HP". iMod "Hcl_F".
+ iMod ("Hcl" $! P with "[] [$HP]") as "($ & $)"; last done.
+ eauto.
+Qed.
+
+Lemma lft_tok_lb q q' κ κ' :
+ q.[κ] -∗ q'.[κ'] -∗ ∃ q'', q''.[κ] ∗ q''.[κ'] ∗ (q''.[κ] -∗ q''.[κ'] -∗ q.[κ] ∗ q'.[κ']).
+Proof.
+ iIntros "Htok1 Htok2".
+ iPoseProof (Fractional_fractional_le (λ q, q.[_])%I _ (Qp.min q q') with "Htok1") as "(Htok1 & Htok1_cl)".
+ { apply Qp.le_min_l. }
+ iPoseProof (Fractional_fractional_le (λ q, q.[_])%I _ (Qp.min q q') with "Htok2") as "(Htok2 & Htok2_cl)".
+ { apply Qp.le_min_r. }
+ iExists (q `min` q')%Qp. iFrame.
+ iIntros "Htok1 Htok2". iPoseProof ("Htok1_cl" with "Htok1") as "$". iPoseProof ("Htok2_cl" with "Htok2") as "$".
+Qed.
+
+Lemma bor_get_persistent (P Q : iProp Σ) E κ q :
+ ↑lftN ⊆ E →
+ lft_ctx -∗
+ (▷ P ={E}=∗ ▷ P ∗ □ Q) -∗
+ &{κ}(P) -∗ q.[κ] ={E}=∗
+ Q ∗ &{κ}(P) ∗ q.[κ].
+Proof.
+ iIntros (?) "#LFT HPQ Hb Htok". iMod (bor_acc_cons with "LFT Hb Htok") as "(Hb & Hcl)"; first done.
+ iMod ("HPQ" with "Hb") as "(HP & #HQ)".
+ iMod ("Hcl" $! P with "[] HP") as "($ & $)". { eauto. }
+ iModIntro. done.
+Qed.
+
+(* Note: from RustHornBelt *)
+Lemma bor_exists_tok {A} (Φ : A → iProp Σ) E κ q :
+ ↑lftN ⊆ E → lft_ctx -∗ &{κ}(∃ x, Φ x) -∗ q.[κ] ={E}=∗ ∃ x, &{κ}(Φ x) ∗ q.[κ].
+Proof.
+ iIntros (?) "#LFT Bor κ". iMod (bor_acc_cons with "LFT Bor κ") as "[Φ Hclose]"; [done|].
+ iMod (bi.later_exist_except_0 with "Φ") as (x) "Φ".
+ iMod ("Hclose" with "[] Φ") as "[?$]"; [iIntros "!>?!>!>"|iModIntro]; by iExists x.
+Qed.
+
+Lemma bor_big_sepL' {X} F κ (Φ : nat → X → iProp Σ) (l : list X) k :
+ lftE ⊆ F →
+ lft_ctx -∗
+ &{κ} ([∗ list] i ↦ x ∈ l, Φ (k + i) x) ={F}=∗
+ [∗ list] i ↦ x ∈ l, &{κ} (Φ (k + i) x).
+Proof.
+ iIntros (?) "#LFT Hb".
+ iInduction l as [ | x l] "IH" forall (k); simpl; first done.
+ iMod (bor_sep with "LFT Hb") as "($ & Hb)"; first done.
+ setoid_rewrite Nat.add_succ_r.
+ iApply ("IH" $! (S k)). done.
+Qed.
+Lemma bor_big_sepL {X} F κ (Φ : nat → X → iProp Σ) (l : list X) :
+ lftE ⊆ F →
+ lft_ctx -∗
+ &{κ} ([∗ list] i ↦ x ∈ l, Φ (i) x) ={F}=∗
+ [∗ list] i ↦ x ∈ l, &{κ} (Φ (i) x).
+Proof.
+ apply (bor_big_sepL' _ _ _ _ 0).
+Qed.
+
+(* TODO maybe find a better place for this *)
+Lemma maybe_use_credit F F1 P n (wl : bool) :
+ F1 ⊆ F →
+ (if wl then £ (S n) ∗ atime 1 else True) -∗
+ (▷?wl |={F1}=> P) -∗
+ |={F}=> ((if wl then £ n else True) ∗ (if wl then atime 1 else True) ∗ P).
+Proof.
+ iIntros (?) "Hcred HP".
+ destruct wl.
+ - iDestruct "Hcred" as "[[Hcred1 Hcred] Hat]".
+ iApply (lc_fupd_add_later with "Hcred1"). iNext. iFrame.
+ iApply (fupd_mask_mono with "HP"); done.
+ - rewrite !left_id. iApply (fupd_mask_mono with "HP"); done.
+Qed.
+End util.
diff --git a/theories/rust_typing/value.v b/theories/rust_typing/value.v
new file mode 100644
index 0000000000000000000000000000000000000000..9479a3279ea8ccfe84b17fc28aecada7b88477a5
--- /dev/null
+++ b/theories/rust_typing/value.v
@@ -0,0 +1,1163 @@
+From refinedrust Require Export type ltypes programs program_rules.
+From refinedrust Require Import memcasts ltype_rules.
+From iris Require Import options.
+
+
+Definition is_value_ot_core (ot : op_type) (ot' : op_type) (mt : memcast_compat_type) : Prop :=
+ match ot' with
+ | UntypedOp ly => ly = ot_layout ot
+ | _ => ot' = ot ∧ mt ≠MCId
+ end.
+Lemma is_value_ot_core_layout ot ot' mt:
+ is_value_ot_core ot ot' mt → ot_layout ot' = ot_layout ot.
+Proof. destruct ot' => //=; naive_solver. Qed.
+Lemma is_value_ot_core_refl ot mt :
+ mt ≠MCId → is_value_ot_core ot ot mt.
+Proof. destruct ot;simpl; done. Qed.
+
+Definition is_value_ot `{!LayoutAlg} (st : syn_type) (ot' : op_type) (mt : memcast_compat_type) : Prop :=
+ ∃ ot, use_op_alg st = Some ot ∧ is_value_ot_core ot ot' mt ∧ syn_type_has_layout st (ot_layout ot).
+
+Lemma is_value_ot_untyped `{!LayoutAlg} st mt ly :
+ syn_type_has_layout st ly →
+ is_value_ot (UntypedSynType ly) (UntypedOp ly) mt.
+Proof.
+ intros Halg. eexists (UntypedOp ly). split_and!.
+ - done.
+ - done.
+ - eapply syn_type_has_layout_make_untyped; done.
+Qed.
+
+Lemma is_value_ot_use_op_alg `{!LayoutAlg} st ly mc :
+ mc ≠MCId →
+ syn_type_has_layout st ly →
+ is_value_ot st (use_op_alg' st) mc.
+Proof.
+ intros ? Ha.
+ specialize (syn_type_has_layout_op_alg _ _ Ha) as (ot & Hot & <-).
+ rewrite /use_op_alg' Hot /=. eexists _. split; first done.
+ split; last done. destruct ot; done.
+Qed.
+
+Section value.
+ Context `{!typeGS Σ}.
+
+ (* Intuitively: want to say that the value is v _up to memcasts_ at ot. *)
+ Program Definition value_t (st : syn_type) : type val := {|
+ st_own π vs v :=
+ (∃ ot,
+ ⌜use_op_alg st = Some ot⌠∗
+ ⌜is_memcast_val vs ot v⌠∗
+ ⌜v `has_layout_val` (ot_layout ot)⌠∗
+ ⌜syn_type_has_layout st (ot_layout ot)âŒ)%I;
+ st_syn_type := st;
+ st_has_op_type ot' mt := is_value_ot st ot' mt;
+ |}.
+ Next Obligation.
+ iIntros (st π vs v) "(%ot & % & % & % & %)". eauto.
+ Qed.
+ Next Obligation.
+ simpl. intros st ot' mt (ot & Halg & Hot & Hst).
+ rewrite (is_value_ot_core_layout _ _ _ Hot). done.
+ Qed.
+ Next Obligation.
+ (* mem-cast *)
+ intros st ot' mt ? π vs v (ot & Halg & Hot & Hst).
+ iIntros "(%ot'' & %Halg' & %Hmc & %Hly & %Hst')".
+ assert (ot'' = ot) as -> by by eapply use_op_alg_inj.
+ destruct mt; first done.
+ - iPureIntro. exists ot. split_and!; [ done | | | done].
+ + destruct ot'; simpl in Hot; try destruct Hot; subst;
+ [by apply is_memcast_val_memcast.. | done ].
+ + by apply has_layout_val_mem_cast.
+ - iPureIntro.
+ destruct ot'; simpl in Hot;
+ try match type of Hot with | _ ∧ _ => destruct Hot end; subst; done.
+ Qed.
+
+ Global Instance value_t_copy st : Copyable (value_t st).
+ Proof. apply _. Qed.
+
+ Lemma value_split π {rt} (ty : type rt) r v st ly :
+ syn_type_has_layout (ty_syn_type ty) ly ∧ syn_type_has_layout st ly →
+ v â—áµ¥{Ï€} r @ ty -∗
+ v â—áµ¥{Ï€} v @ value_t st ∗ v â—áµ¥{Ï€} r @ ty.
+ Proof.
+ iIntros ((Hly & Hly')) "Hv".
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hv"; first done.
+ subst. iFrame.
+ specialize (syn_type_has_layout_op_alg _ _ Hly') as (ot & Hot & <-).
+ iExists ot. iSplitR; first done.
+ iSplitR. { iLeft. done. }
+ done.
+ Qed.
+
+ Lemma value_make_typed π st ly v vs :
+ ⌜syn_type_has_layout st ly⌠-∗
+ v â—áµ¥{Ï€} vs @ value_t (UntypedSynType ly) -∗
+ v â—áµ¥{Ï€} vs @ value_t st.
+ Proof.
+ iIntros "%Halg Hv".
+ rewrite /ty_own_val /=. iDestruct "Hv" as "(%ot & %Heq & %Hmc & %Hlyv & _)".
+ injection Heq as <-.
+ specialize (syn_type_has_layout_op_alg _ _ Halg) as (ot & Hop & <-).
+ iExists ot. iSplitR; first done.
+ iSplitR. { iLeft. apply is_memcast_val_untyped_inv in Hmc. done. }
+ iSplitR; first done. done.
+ Qed.
+
+ (* TODO move *)
+ Lemma ly_size_ly_offset ly n :
+ ly_size (ly_offset ly n) = ly_size ly - n.
+ Proof.
+ rewrite /ly_size /ly_offset. destruct ly; done.
+ Qed.
+ Lemma layout_wf_mono ly1 ly2 :
+ ly_align_log ly2 ≤ ly_align_log ly1 →
+ ly_size ly1 = ly_size ly2 →
+ layout_wf ly1 → layout_wf ly2.
+ Proof.
+ rewrite /layout_wf /ly_align. intros Hle Hsz Hdiv.
+ rewrite -Hsz. eapply Z.divide_trans; last apply Hdiv.
+ eapply Zdivide_nat_pow. done.
+ Qed.
+
+ Lemma value_untyped_mono π v vs ly1 ly2 :
+ ly_size ly1 = ly_size ly2 →
+ (layout_wf ly1 → layout_wf ly2) →
+ (ly_align_in_bounds ly1 → ly_align_in_bounds ly2) →
+ v â—áµ¥{Ï€} vs @ value_t (UntypedSynType ly1) -∗
+ v â—áµ¥{Ï€} vs @ value_t (UntypedSynType ly2).
+ Proof.
+ iIntros (Hsz Hwf Hal) "Hv". rewrite /ty_own_val /=.
+ iDestruct "Hv" as "(%ot & %Heq & %Hmc & %Hly & %Hst)".
+ injection Heq as <-. iExists _. iSplitR; first done.
+ iSplitR. { apply is_memcast_val_untyped_inv in Hmc. by iLeft. }
+ simpl. iSplitR. { rewrite /has_layout_val -Hsz //. }
+ iPureIntro. simpl in Hst. apply syn_type_has_layout_untyped_inv in Hst as (_ & Hwf' & Hsz_le & ?).
+ eapply syn_type_has_layout_untyped.
+ - done.
+ - by apply Hwf.
+ - lia.
+ - by apply Hal.
+ Qed.
+
+ (* TODO move *)
+ Lemma ofty_mono_ly_strong_in π {rt1 rt2} l wl (ty1 : type rt1) (ty2 : type rt2) (r1 : rt1) (r2 : rt2) ly1 ly2 :
+ syn_type_has_layout (ty1.(ty_syn_type)) ly1 →
+ syn_type_has_layout (ty2.(ty_syn_type)) ly2 →
+ (l `has_layout_loc` ly1 → l `has_layout_loc` ly2) →
+ ly_size ly2 = ly_size ly1 →
+ (∀ v, ty1.(ty_own_val) π r1 v -∗ ty2.(ty_own_val) π r2 v) -∗
+ (ty_sidecond ty1 -∗ ty_sidecond ty2) -∗
+ l â—â‚—[Ï€, Owned wl] #r1 @ (â— ty1) -∗
+ l â—â‚—[Ï€, Owned wl] #r2 @ (â— ty2).
+ Proof.
+ intros Halg1 Halg2 Halign Hsz. iIntros "Hvs Hscvs Hl".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly1' & %Halg1' & %Hly & Hsc & Hlb & Hcred & %r' & <- & Hb)".
+ assert (ly1' = ly1) as -> by by eapply syn_type_has_layout_inj.
+ iExists ly2. iSplitR; first done.
+ iSplitR. { iPureIntro. by apply Halign. }
+ iPoseProof ("Hscvs" with "Hsc") as "$".
+ rewrite Hsz. iFrame "Hlb Hcred".
+ iExists r2. iSplitR; first done.
+ iNext. iMod "Hb" as "(%v & Hl & Hv)".
+ iModIntro. iExists v. iFrame. by iApply "Hvs".
+ Qed.
+ Lemma ofty_mono_ly_strong π {rt1} l wl (ty1 : type rt1) (ty2 : type rt1) (r1 : place_rfn rt1) ly1 ly2 :
+ syn_type_has_layout (ty1.(ty_syn_type)) ly1 →
+ syn_type_has_layout (ty2.(ty_syn_type)) ly2 →
+ (l `has_layout_loc` ly1 → l `has_layout_loc` ly2) →
+ ly_size ly2 = ly_size ly1 →
+ (∀ v r, ty1.(ty_own_val) π r v -∗ ty2.(ty_own_val) π r v) -∗
+ (ty_sidecond ty1 -∗ ty_sidecond ty2) -∗
+ l â—â‚—[Ï€, Owned wl] r1 @ (â— ty1) -∗
+ l â—â‚—[Ï€, Owned wl] r1 @ (â— ty2).
+ Proof.
+ intros Halg1 Halg2 Halign Hsz. iIntros "Hvs Hscvs Hl".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly1' & %Halg1' & %Hly & Hsc & Hlb & Hcred & %r' & ? & Hb)".
+ assert (ly1' = ly1) as -> by by eapply syn_type_has_layout_inj.
+ iExists ly2. iSplitR; first done.
+ iSplitR. { iPureIntro. by apply Halign. }
+ iPoseProof ("Hscvs" with "Hsc") as "$".
+ rewrite Hsz. iFrame "Hlb Hcred".
+ iExists _. iFrame.
+ iNext. iMod "Hb" as "(%v & Hl & Hv)".
+ iModIntro. iExists v. iFrame. by iApply "Hvs".
+ Qed.
+
+ Lemma value_split_ofty_untyped π F l {rt} (ty : type rt) r ly :
+ lftE ⊆ F →
+ syn_type_has_layout (ty_syn_type ty) ly →
+ (l â—â‚—[Ï€, Owned false] #r @ â— ty)%I ={F}=∗ ∃ v,
+ v â—áµ¥{Ï€} r @ ty ∗ l â—â‚—[Ï€, Owned false] #v @ â— (value_t (UntypedSynType ly)).
+ Proof.
+ iIntros (? Halg) "Hty".
+ rewrite (ltype_own_ofty_unfold ty) /lty_of_ty_own.
+ iDestruct "Hty" as "(%ly' & % & % & Hsc & Hlb & _ & %r' & <- & Hb)".
+ assert (ly' = ly) as -> by by eapply syn_type_has_layout_inj.
+ iMod (fupd_mask_mono with "Hb") as "(%v & Hl & Hv)"; first done.
+ iPoseProof (value_split _ _ _ _ (UntypedSynType _) with "Hv") as "(Hv' & Hv)".
+ { split; first done. eapply syn_type_has_layout_make_untyped; done. }
+ iExists v. iFrame.
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists _. simpl.
+ iSplitR. { iPureIntro. eapply syn_type_has_layout_make_untyped; done. }
+ iSplitR; first done. iFrame. iSplitR; first done.
+ iExists _. iSplitR; first done. iModIntro.
+ iExists v. by iFrame.
+ Qed.
+
+ Lemma mem_cast_UntypedOp v ly st :
+ mem_cast v (UntypedOp ly) st = v.
+ Proof. done. Qed.
+ Lemma is_memcast_val_untyped_app ly1 ly2 ly3 v1 v2 v1' v2' :
+ ly_size ly3 = ly_size ly1 + ly_size ly2 →
+ is_memcast_val v1 (UntypedOp ly1) v1' →
+ is_memcast_val v2 (UntypedOp ly2) v2' →
+ is_memcast_val (v1 ++ v2) (UntypedOp ly3) (v1' ++ v2').
+ Proof.
+ intros Hsz H1 H2.
+ destruct H1 as [-> | (st1 & ->)]; destruct H2 as [-> | (st2 & ->)]; simpl;
+ try rewrite !mem_cast_UntypedOp; by left.
+ Qed.
+
+ Lemma value_t_app_untyped π v1 v2 r1 r2 ly1 ly2 ly3 :
+ syn_type_has_layout (UntypedSynType ly3) ly3 →
+ ly_size ly3 = ly_size ly1 + ly_size ly2 →
+ v1 â—áµ¥{Ï€} r1 @ value_t (UntypedSynType ly1) -∗
+ v2 â—áµ¥{Ï€} r2 @ value_t (UntypedSynType ly2) -∗
+ (v1 ++ v2) â—áµ¥{Ï€} (r1 ++ r2) @ value_t (UntypedSynType ly3).
+ Proof.
+ iIntros (??) "Hv1 Hv2".
+ rewrite /ty_own_val /=.
+ iDestruct "Hv1" as "(%ot1 & %Heq1 & %Hmc1 & %Hly1 & %Halg1)".
+ iDestruct "Hv2" as "(%ot2 & %Heq2 & %Hmc2 & %Hly2 & %Halg2)".
+ injection Heq1 as <-. injection Heq2 as <-.
+ apply syn_type_has_layout_untyped_inv in Halg1 as (<- & Hwf1 & Hsz1).
+ apply syn_type_has_layout_untyped_inv in Halg2 as (<- & Hwf2 & Hsz2).
+ rewrite /has_layout_val in Hly1. rewrite /has_layout_val in Hly2.
+ simpl in *.
+ iExists _. iR. simpl.
+ iPureIntro. split_and!.
+ - eapply is_memcast_val_untyped_app; [ | done..]. done.
+ - rewrite /has_layout_val. rewrite app_length. lia.
+ - done.
+ Qed.
+
+ Lemma ofty_uninit_to_value_t F π l st :
+ lftE ⊆ F →
+ (l â—â‚—[Ï€, Owned false] .@ â— (uninit st))%I ={F}=∗
+ ∃ v, l â—â‚—[Ï€, Owned false] #v @ (â— value_t st)%I.
+ Proof.
+ iIntros (?) "Hl".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & _ & Hlb & _ & %r' & <- & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "Hb"; first done.
+ iDestruct "Hb" as "(%v & Hl & Hv)".
+ iExists v. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly. iR. iR. iR. iFrame. iR. iExists v. iR.
+ iModIntro. iNext. iModIntro. iExists v. iFrame.
+ rewrite /ty_own_val/=.
+ destruct (syn_type_has_layout_op_alg _ _ Halg) as (ot & Hot & Hly').
+ iExists ot.
+ iR.
+ iDestruct "Hv" as "(%ly'' & %Halg' & %Hlyv & _)".
+ assert (ly'' = ly) as -> by by eapply syn_type_has_layout_inj.
+ iSplitR. { iPureIntro. left. done. }
+ iSplitR. { iPureIntro. rewrite /has_layout_val Hly'//. }
+ iPureIntro. rewrite Hly'. done.
+ Qed.
+
+
+ Lemma ofty_value_t_untyped_reduce_alignment π l vs ly1 ly2 :
+ ly_size ly1 = ly_size ly2 →
+ l `has_layout_loc` ly2 →
+ layout_wf ly2 →
+ (ly_align_in_bounds ly1 → ly_align_in_bounds ly2) →
+ (*ly_align_log ly2 ≤ ly_align_log ly1 →*)
+ (l â—â‚—[Ï€, Owned false] vs @ â— value_t (UntypedSynType ly1)) -∗
+ (l â—â‚—[Ï€, Owned false] vs @ â— value_t (UntypedSynType ly2)).
+ Proof.
+ iIntros (Hsz Halign ? Halmon) "Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Halg & #_)".
+ simp_ltypes in Halg. simpl in Halg.
+ apply syn_type_has_layout_untyped_inv in Halg as (-> & Hwf1 & Hsz_le & Hal).
+ iApply (ofty_mono_ly_strong with "[] [] Hl").
+ + simpl. eapply syn_type_has_layout_untyped; done.
+ + simpl. eapply syn_type_has_layout_untyped; first done.
+ - done.
+ - lia.
+ - by apply Halmon.
+ + done.
+ + done.
+ + iIntros (??). iApply value_untyped_mono; [done.. | ]. eauto.
+ + simpl. done.
+ Qed.
+ Lemma ofty_value_t_merge_adjacent π l vs1 vs2 ly1 ly2 ly3 :
+ l `has_layout_loc` ly3 →
+ ly_size ly1 ≤ ly_size ly3 →
+ ly_size ly2 = ly_size ly3 - ly_size ly1 →
+ syn_type_has_layout (UntypedSynType ly3) ly3 →
+ (l â—â‚—[Ï€, Owned false] #vs1 @ â— value_t (UntypedSynType ly1)) -∗
+ ((l +â‚— ly_size ly1) â—â‚—[Ï€, Owned false] #vs2 @ â— value_t (UntypedSynType ly2)) -∗
+ (l â—â‚—[Ï€, Owned false] #(vs1++vs2) @ â— value_t (UntypedSynType ly3)).
+ Proof.
+ iIntros (Hal Hsz Hlysz ?) "Hl1 Hl2".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own. simpl.
+ iDestruct "Hl1" as "(%ly10 & %Hly1 & %Hly_l & _ & #Hlb1 & _ & %r' & -> & Hb1)".
+ apply syn_type_has_layout_untyped_inv in Hly1 as (-> & _).
+ iDestruct "Hl2" as "(%ly20 & %Hly2 & %Hly_l' & _ & #Hlb2 & _ & %r'' & -> & Hb2)".
+ apply syn_type_has_layout_untyped_inv in Hly2 as (-> & _).
+ iExists ly3. simpl. iR.
+ iSplitR. { done. }
+ iR.
+ iSplitR. { iCombine "Hlb1 Hlb2" as "Hlb". rewrite loc_in_bounds_split_suf.
+ rewrite {2}Hlysz.
+ match goal with | |- context[(?m + (?n - ?m))] => replace (m + (n - m)) with n by lia end; done. }
+ iSplitR; first done.
+ iExists _. iSplitR; first done.
+ iMod (fupd_mask_mono with "Hb1") as "(%v1 & Hl1 & Hv1)"; first done.
+ iMod (fupd_mask_mono with "Hb2") as "(%v2 & Hl2 & Hv2)"; first done.
+ iModIntro.
+ iExists (v1 ++ v2).
+ rewrite heap_mapsto_app. iFrame.
+ iPoseProof (ty_has_layout with "Hv1") as "(%ly' & %Halg & %Hlyv)".
+ apply syn_type_has_layout_untyped_inv in Halg as (-> & ? & ?).
+ iSplitL "Hl2". { rewrite /has_layout_val in Hlyv. rewrite Hlyv. done. }
+ iApply (value_t_app_untyped with "Hv1 Hv2").
+ - done.
+ - rewrite Hlysz. lia.
+ Qed.
+
+ (* TODO move *)
+ Lemma use_op_alg_untyped_inv ly ot :
+ use_op_alg (UntypedSynType ly) = Some ot → ot = (UntypedOp ly).
+ Proof.
+ rewrite /use_op_alg.
+ intros [= <-]; done.
+ Qed.
+
+ Lemma value_t_app_split_untyped π v v1 v2 ly1 ly2 ly3 :
+ ly_size ly1 = ly_size ly2 + ly_size ly3 →
+ length v1 = ly_size ly2 →
+ layout_wf ly2 →
+ layout_wf ly3 →
+ ly_align_in_bounds ly3 →
+ ly_align_in_bounds ly2 →
+ v â—áµ¥{Ï€} (v1 ++ v2) @ value_t (UntypedSynType ly1) -∗
+ (take (length v1) v) â—áµ¥{Ï€} v1 @ value_t (UntypedSynType ly2) ∗
+ (drop (length v1) v) â—áµ¥{Ï€} v2 @ value_t (UntypedSynType ly3).
+ Proof.
+ iIntros (Hsz ?????) "Hv".
+ rewrite /ty_own_val/=. iDestruct "Hv" as "(%ot & %Hot & %Hmc & %Hly & %Hst)".
+ apply use_op_alg_untyped_inv in Hot as ->.
+ apply syn_type_has_layout_untyped_inv in Hst as (<- & Hwf & Hsz' & ?).
+ apply is_memcast_val_untyped_inv in Hmc as <-.
+ rewrite /has_layout_val/= app_length in Hly.
+ simpl in *.
+ iSplit.
+ - iPureIntro. exists (UntypedOp ly2). split; first done.
+ split. { left. rewrite take_app//. }
+ split. { rewrite take_app. rewrite /has_layout_val/=. lia. }
+ apply syn_type_has_layout_untyped; try naive_solver lia.
+ - iPureIntro. exists (UntypedOp ly3). split; first done.
+ split. { left. rewrite drop_app//. }
+ split. { rewrite drop_app. rewrite /has_layout_val/=. lia. }
+ apply syn_type_has_layout_untyped; naive_solver lia.
+ Qed.
+
+ (* TODO move *)
+ Lemma ly_align_in_bounds_mono ly1 ly2 :
+ ly_align_log ly2 ≤ ly_align_log ly1 →
+ ly_align_in_bounds ly1 →
+ ly_align_in_bounds ly2.
+ Proof.
+ rewrite /ly_align_in_bounds.
+ intros Hle. rewrite /ly_align/min_alloc_start. intros Ha.
+ split.
+ - specialize (Nat_pow_ge_1 (ly_align_log ly2)). lia.
+ - etrans; last apply Ha.
+ apply inj_le. apply Nat.pow_le_mono_r; done.
+ Qed.
+
+ Lemma ofty_value_t_split_adjacent F π l v1 v2 v3 ly1 ly2 ly3 :
+ lftE ⊆ F →
+ ly_align_log ly3 ≤ ly_align_log ly1 →
+ ly_align_log ly2 ≤ ly_align_log ly1 →
+ ly_size ly1 = ly_size ly2 + ly_size ly3 →
+ v1 = v2 ++ v3 →
+ length v2 = ly_size ly2 →
+ layout_wf ly2 →
+ layout_wf ly3 →
+ ⊢ l â—â‚—[Ï€, Owned false] #v1 @ (â— value_t (UntypedSynType ly1)) ={F}=∗
+ l â—â‚—[Ï€, Owned false] #v2 @ (â— value_t (UntypedSynType ly2)) ∗
+ (l +â‚— ly_size ly2) â—â‚—[Ï€, Owned false] #v3 @ â— value_t (UntypedSynType ly3).
+ Proof.
+ iIntros (? Hal3 Hal2 Hsz -> Hszeq ??) "Hl".
+ rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & %Hly & Hsc & Hlb & _ & %r' & <- & Hb)".
+ iMod (fupd_mask_mono with "Hb") as "(%v & Hl & Hv)"; first done.
+ apply syn_type_has_layout_untyped_inv in Halg as (-> & ? & ? &?).
+ rewrite Hsz. rewrite -loc_in_bounds_split_suf. iDestruct "Hlb" as "(Hlb1 & Hlb2)".
+ efeed pose proof (ly_align_in_bounds_mono ly1 ly2); [done.. | ].
+ efeed pose proof (ly_align_in_bounds_mono ly1 ly3); [done.. | ].
+ iPoseProof (value_t_app_split_untyped _ _ _ _ ly1 ly2 ly3 with "Hv") as "(Hv1 & Hv2)".
+ { done. }
+ { done. }
+ { done. }
+ { done. }
+ { done. }
+ { done. }
+ (rewrite -{1}(take_drop (length v2) v)).
+ rewrite heap_mapsto_app. iDestruct "Hl" as "(Hl1 & Hl2)".
+ iSplitL "Hv1 Hl1 Hlb1".
+ - iModIntro. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly2. iSplitR. { iPureIntro. apply syn_type_has_layout_untyped; naive_solver lia. }
+ iSplitR. { iPureIntro. eapply has_layout_loc_trans; first done. lia. }
+ simpl. iR. iFrame. iR. iExists v2. iR.
+ iModIntro. iExists _. iFrame.
+ - iModIntro. rewrite ltype_own_ofty_unfold /lty_of_ty_own.
+ iExists ly3. iSplitR. { iPureIntro. apply syn_type_has_layout_untyped; naive_solver lia. }
+ iSplitR. { iPureIntro. admit. }
+ simpl. iR. iFrame. iExists v3. iR.
+ iModIntro. iExists _. iFrame.
+ rewrite take_length. rewrite Hszeq Nat.min_l; first done.
+ (* length v1 = ly_size ly1 *)
+ Admitted.
+
+End value.
+
+Global Hint Unfold value_t : tyunfold.
+Global Typeclasses Opaque value_t.
+
+(** ** value rules *)
+Section rules.
+ Context `{!typeGS Σ}.
+
+ (* TODO move *)
+ Lemma maybe_logical_step_fupd step F P :
+ maybe_logical_step step F (|={F}=> P) -∗
+ maybe_logical_step step F P.
+ Proof.
+ destruct step; simpl.
+ - iApply logical_step_fupd.
+ - rewrite fupd_trans; auto.
+ Qed.
+
+ (** *** instances for types that are not value -- these have lower priority than the the value-specific versions below *)
+ (** by default, we go to UntypedSynType, and can later on specialize if needed by subsumption (we cannot go the other way around due to memcast compatibility) *)
+ Lemma value_subsume_goal π {rt} (ty : type rt) (r : rt) v vs st T :
+ (∃ ly, ⌜syn_type_has_layout ty.(ty_syn_type) ly⌠∗
+ (v â—áµ¥{Ï€} r @ ty -∗ subsume (v â—áµ¥{Ï€} v @ value_t (UntypedSynType ly)) (v â—áµ¥{Ï€} vs @ value_t st) T))
+ ⊢ subsume (v â—áµ¥{Ï€} r @ ty) (v â—áµ¥{Ï€} vs @ value_t st) T.
+ Proof.
+ iIntros "(%ly & %Halg & HT) Hv".
+ iPoseProof (value_split _ _ _ _ (UntypedSynType _) with "Hv") as "(Hv' & Hv)".
+ { split; first done. eapply syn_type_has_layout_make_untyped; done. }
+ iApply ("HT" with "Hv Hv'").
+ Qed.
+ Global Instance value_subsume_goal_inst π {rt} (ty : type rt) (r : rt) v vs st :
+ Subsume (v â—áµ¥{Ï€} r @ ty) (v â—áµ¥{Ï€} vs @ value_t st) | 50 :=
+ λ T, i2p (value_subsume_goal π ty r v vs st T).
+
+ (* TODO: this isn't ideal if v' is an evar -- then this currently will lead to evar instantiation failures, since we don't know the value yet.
+ Maybe we want to have a type which encapsulates the existential quantifier in that case?
+ *)
+ Lemma value_subsume_full_goal_ofty π E L step {rt} l v' st (ty : type rt) r T:
+ li_tactic (compute_layout_goal ty.(ty_syn_type)) (λ ly,
+ (∀ v, v â—áµ¥{Ï€} r @ ty -∗
+ subsume_full E L step (l â—â‚—[Ï€, Owned false] #v @ â— value_t (UntypedSynType ly)) (l â—â‚—[Ï€, Owned false] #v' @ â— (value_t st)) T))
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] #r @ â— ty) (l â—â‚—[Ï€, Owned false] #v' @ â— (value_t st)) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly & %Hst & HT)" (???) "#CTX #HE HL Hty".
+ iMod (value_split_ofty_untyped with "Hty") as "(%v & Hv & Hty)"; [done.. | ].
+ iDestruct ("HT" with "Hv") as "HT".
+ by iApply ("HT" with "[//] [//] CTX HE HL").
+ Qed.
+ (* NOTE: not an instance due to the above issue *)
+ (*Global Instance value_subsume_full_goal_ofty_inst π E L {rt} l v' st (ty : type rt) r :*)
+ (*SubsumeFull E L (l â—â‚—[Ï€, Owned false] PlaceIn r @ â— ty)%I (l â—â‚—[Ï€, Owned false] PlaceIn v' @ â— (value_t st))%I | 50 :=*)
+ (*λ T, i2p (value_subsume_full_goal_ofty π E L l v' st ty r T).*)
+
+
+
+ (** Strategy for unifying two values:
+ Step 1 (equalize st):
+ - if goal st is evar, instantiate with same and proceed to 2
+ - if goal st is given:
+ + if current is Untyped and goal is Untyped, go to step 2
+ + if current is Untyped and goal is something else, make goal Untyped
+ + otherwise, require equality (TODO: not complete: we could also make a prefix here)
+
+ Invariant after step 2: either st match, or both are Untyped.
+
+ Step 2
+ - if both are untyped:
+ a) if both are using the same layout, done
+ b) if both have the same size, require the goal's alignment to be lower, done
+ c) otherwise (size also not equal), require current to be a prefix and continue with prove_with_subtype of the rest (startign at step 1 again); require goal's alignment to be lower
+ - otherwise: require the values to be the same.
+ *)
+
+ (** Step 2 *)
+
+ (* if both are using the same st, unify the values *)
+ Lemma subsume_full_ofty_value_unify_vs π E L step l vs1 vs2 st T :
+ ⌜vs1 = vs2⌠∗ T L True%I
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t st) (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t st) T.
+ Proof.
+ iIntros "(-> & HT)". iApply subsume_full_id. done.
+ Qed.
+ Global Instance subsume_full_ofty_value_unify_vs_inst π E L step l vs1 vs2 st :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t st)%I (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t st)%I | 5 :=
+ λ T, i2p (subsume_full_ofty_value_unify_vs π E L step l vs1 vs2 st T).
+
+
+
+ (* if both are untyped, and have not been handled by the previous instance,
+ check if the sizes of the layout are the same;
+ - if so, fully subsume the values
+ - else if the size of the first layout is smaller, prove that the left one is a prefix of the latter, and continue searching for the rest.
+ - else, the goal refers to a subset of the current chunk and we split off. *)
+ Lemma subsume_full_ofty_value_untyped_full π E L step l vs1 vs2 ly1 ly2 T `{!LayoutSizeEq ly1 ly2} :
+ (⌜l `has_layout_loc` ly1⌠-∗ ⌜ly_align_in_bounds ly1⌠-∗ ⌜l `has_layout_loc` ly2⌠∗ ⌜vs1 = vs2⌠∗ ⌜ly_align_in_bounds ly2⌠∗ ⌜layout_wf ly2⌠∗ T L True%I)
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t (UntypedSynType ly1)) (l â—â‚—[Ï€, Owned false] vs2 @ â— value_t (UntypedSynType ly2)) T.
+ Proof.
+ (*iIntros "(%Halign & -> & HT)".*)
+ iIntros "HT".
+ iIntros (F ??) "#CTX #HE HL Hl". iModIntro. iExists L, True%I. iFrame.
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly' & %Hly' & %Hlyl)". simp_ltypes in Hly'. simpl in *.
+ apply syn_type_has_layout_untyped_inv in Hly' as (-> & ? & ? & ?).
+ iPoseProof ("HT" with "[//] [//]") as "(% & -> & % & % & HT)".
+ iPoseProof (ofty_value_t_untyped_reduce_alignment _ _ _ _ ly2 with "Hl") as "Hl".
+ { done. }
+ { done. }
+ { done. }
+ { done. }
+ iFrame. iApply (maybe_logical_step_intro). iL. done.
+ Qed.
+ Global Instance subsume_full_ofty_value_untyped_full_inst π E L step l vs1 vs2 ly1 ly2 `{!LayoutSizeEq ly1 ly2} :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t (UntypedSynType ly1))%I (l â—â‚—[Ï€, Owned false] vs2 @ â— value_t (UntypedSynType ly2))%I | 6 :=
+ λ T, i2p (subsume_full_ofty_value_untyped_full π E L step l vs1 vs2 ly1 ly2 T).
+
+
+ (* TODO: need simplification mechanism for the ly_offset here to get to a sane layout.
+ Or more specifically: a SimplifyHyp instance for value_t. *)
+ (*ly_size ly2 = ly_size (ly_offset ly3 (ly_size ly1))*)
+ Lemma subsume_full_ofty_value_untyped_prefix π E L step l vs1 vs2 ly1 ly2 T `{!LayoutSizeLe ly1 ly2} :
+ (⌜syn_type_has_layout (UntypedSynType ly2) ly2⌠∗
+ (⌜l `has_layout_loc` ly1⌠-∗
+ ⌜l `has_layout_loc` ly2⌠∗
+ ∃ vs2', ⌜vs2 = vs1 ++ vs2'⌠∗
+ ∃ ly1', prove_with_subtype E L step ProveDirect ((l +â‚— ly_size ly1) â—â‚—[Ï€, Owned false] PlaceIn vs2' @ â— value_t (UntypedSynType ly1')) (λ L2 _ R2, ⌜ly_size ly1' = ly_size ly2 - ly_size ly1⌠∗ T L2 R2)))
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] #vs1 @ â— value_t (UntypedSynType ly1)) (l â—â‚—[Ï€, Owned false] #vs2 @ â— value_t (UntypedSynType ly2)) T.
+ Proof.
+ iIntros "(%Hst & HT)".
+ match goal with H : LayoutSizeLe _ _ |- _ => rewrite /LayoutSizeLe in H end.
+ iIntros (F ??) "#CTX #HE HL Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "(%ly & %Halg & %Hal)".
+ apply syn_type_has_layout_untyped_inv in Halg as (-> & ? & ?).
+ iDestruct ("HT" with "[//]") as "(%Hal2 & %vs2' & -> & %ly1' & HT)".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & % & %R2 & Hl' & HL & %Hsz & HT)".
+ iExists _, R2. iFrame.
+ iApply maybe_logical_step_fupd.
+ iApply (maybe_logical_step_compose with "Hl'").
+ iApply maybe_logical_step_intro.
+ iIntros "!> (Hl' & $)".
+ iPoseProof (ofty_value_t_merge_adjacent with "Hl Hl'") as "$"; last done.
+ - done.
+ - done.
+ - done.
+ - done.
+ Qed.
+ Global Instance subsume_full_ofty_value_untyped_prefix_inst π E L step l vs1 vs2 ly1 ly2 `{!LayoutSizeLe ly1 ly2} :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] #vs1 @ â— value_t (UntypedSynType ly1))%I (l â—â‚—[Ï€, Owned false] #vs2 @ â— value_t (UntypedSynType ly2))%I | 7 :=
+ λ T, i2p (subsume_full_ofty_value_untyped_prefix π E L step l vs1 vs2 ly1 ly2 T).
+
+ (* TODO we should also have a corresponding case for the thing that the new one is smaller *)
+ (*
+ Lemma subsume_full_ofty_value_untyped_larger π E L step l vs1 vs2 ly1 ly2 T :
+ (⌜ly_size ly2 ≤ ly_size ly1⌠∗
+ ⌜ly_align_log ly2 ≤ ly_align_log ly1⌠∗
+ ⌜layout_wf (ly_offset ly1 (ly_size ly2))⌠∗
+ ⌜vs2 = take (ly_size ly2) vs1⌠∗
+ ((l +â‚— ly_size ly2) â—â‚—[Ï€, Owned false] PlaceIn (drop (ly_size ly2) vs1) @ (â— value_t (UntypedSynType (ly_offset ly1 (ly_size ly2)))) -∗ T L True%I))-∗
+ subsume_full E L step (l â—â‚—[Ï€, Owned false] #vs1 @ â— value_t (UntypedSynType ly1)) (l â—â‚—[Ï€, Owned false] #vs2 @ â— value_t (UntypedSynType ly2)) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance subsume_full_ofty_value_untyped_larger_inst π E L step l vs1 vs2 ly1 ly2 :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t (UntypedSynType ly1))%I (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t (UntypedSynType ly2))%I | 9 :=
+ λ T, i2p (subsume_full_ofty_value_untyped_larger π E L step l vs1 vs2 ly1 ly2 T).
+ *)
+
+
+ (** Step 1 *)
+ (* instantiate in case [st2] is an evar *)
+ Lemma subsume_full_ofty_value_st_evar π E L step l st1 st2 vs1 vs2 T :
+ ⌜st1 = st2⌠∗ subsume_full E L step (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t st1)%I (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t st1)%I T
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t st1) (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t st2) T.
+ Proof.
+ iIntros "(-> & HT)". iApply "HT".
+ Qed.
+ Global Instance subsume_full_ofty_value_st_evar_inst π E L step l st1 st2 vs1 vs2 `{!IsProtected st2} :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t st1)%I (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t st2)%I | 10 :=
+ λ T, i2p (subsume_full_ofty_value_st_evar π E L step l st1 st2 vs1 vs2 T).
+
+ (* in case st1 is Untyped, make the goal untyped, too *)
+ Lemma subsume_full_ofty_value_st_untyped π E L step vs1 vs2 l st2 ly1 T :
+ (li_tactic (compute_layout_goal st2) (λ ly2,
+ subsume_full E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t (UntypedSynType ly1))%I
+ (l â—â‚—[Ï€, Owned false] vs2 @ (â— value_t (UntypedSynType ly2)))%I T))
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t (UntypedSynType ly1))
+ (l â—â‚—[Ï€, Owned false] vs2 @ (â— value_t st2)) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly2 & %Halg & HT)".
+ iIntros (F ??) "#CTX #HE HL Hl".
+ iMod ("HT" with "[//] [//] CTX HE HL Hl") as "(%L' & %R2 & Hl & HL & HT)".
+ iModIntro. iExists L', R2. iFrame.
+ iApply (maybe_logical_step_wand with "[] Hl"). iIntros "(Hl & $)".
+ iApply (ofty_mono_ly_strong with "[] [] Hl").
+ - simpl. by eapply syn_type_has_layout_make_untyped.
+ - done.
+ - done.
+ - done.
+ - iIntros (v r) "Hv". rewrite /ty_own_val /=.
+ iDestruct "Hv" as "(%ot & %Heq & %Hmc & %Hv & _)".
+ injection Heq as <-. apply is_memcast_val_untyped_inv in Hmc as <-.
+ specialize (syn_type_has_layout_op_alg _ _ Halg) as (ot & Hot & <-).
+ iExists ot. iSplitR; first done. iSplitR. { by iLeft. }
+ done.
+ - simpl. done.
+ Qed.
+ Global Instance subsume_full_ofty_value_st_untyped_inst π E L step l ly1 st2 vs1 vs2 :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t (UntypedSynType ly1))%I (l â—â‚—[Ï€, Owned false] vs2 @ â— value_t st2)%I | 15 :=
+ λ T, i2p (subsume_full_ofty_value_st_untyped π E L step vs1 vs2 l st2 ly1 T).
+
+ (* if both of the above fail, require equality of the syntypes.
+ TODO: this is too strict *)
+ Lemma subsume_full_ofty_value_st_eq π E L step l vs1 vs2 st1 st2 T :
+ ⌜st1 = st2⌠∗ subsume_full E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t st2)
+ (l â—â‚—[Ï€, Owned false] vs2 @ â— value_t st2) T
+ ⊢ subsume_full E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t st1)
+ (l â—â‚—[Ï€, Owned false] vs2 @ â— value_t st2) T.
+ Proof.
+ iIntros "(-> & $)".
+ Qed.
+ Global Instance subsume_full_ofty_value_st_eq_inst π E L step l st1 st2 vs1 vs2 :
+ SubsumeFull E L step (l â—â‚—[Ï€, Owned false] vs1 @ â— value_t st1)%I (l â—â‚—[Ï€, Owned false] vs2 @ â— value_t st2)%I | 20 :=
+ λ T, i2p (subsume_full_ofty_value_st_eq π E L step l vs1 vs2 st1 st2 T).
+
+
+ (** Same instances for the case that we have just values *)
+ (* if both are using the same st, unify the values *)
+ Lemma subsume_full_value_unify_vs E L step π v vs1 vs2 st T :
+ ⌜vs1 = vs2⌠∗ T L True%I
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t st) (v â—áµ¥{Ï€} vs2 @ value_t st) T.
+ Proof.
+ iIntros "(-> & HT)". iApply subsume_full_id. done.
+ Qed.
+ Global Instance subsume_full_value_unify_vs_inst E L step π v vs1 vs2 st :
+ SubsumeFull E L step (v â—áµ¥{Ï€} vs1 @ value_t st)%I (v â—áµ¥{Ï€} vs2 @ value_t st)%I | 5 :=
+ λ T, i2p (subsume_full_value_unify_vs E L step π v vs1 vs2 st T).
+
+ (* if both are untyped, and have not been handled by the previous instance,
+ check if the sizes of the layout are the same;
+ - if so, show that the alignment of the goal is lower
+ - else, prove that the left one is a prefix of the latter, and continue searching for the rest. *)
+ (*
+ Lemma subsume_full_ofty_value_untyped_prefix π E L l vs1 vs2 ly1 ly2 T :
+ ⌜ly_align_log ly2 ≤ ly_align_log ly1⌠∗
+ ⌜ly_size ly1 ≤ ly_size ly2⌠∗
+ ⌜vs1 = take (ly_size ly1) vs2⌠∗
+ prove ((drop (ly_size ly1) vs2) â—áµ¥{Ï€} (drop (ly_size ly1) vs2) @ â— value_t (UntypedSynType (ly_offset ly2 (ly_size ly1)))) T -∗
+ subsume (v â—áµ¥{Ï€} vs1 @ value_t (UntypedSynType ly1)) (v â—áµ¥{Ï€} vs2 @ value_t (UntypedSynType ly2)) T.
+ Proof.
+ (* TODO *)
+ Admitted.
+ Global Instance subsume_full_ofty_value_untyped_prefix_inst π E L l vs1 vs2 ly1 ly2 :
+ SubsumeFull E L (l â—â‚—[Ï€, Owned false] PlaceIn vs1 @ â— value_t (UntypedSynType ly1))%I (l â—â‚—[Ï€, Owned false] PlaceIn vs2 @ â— value_t (UntypedSynType ly2))%I | 6 :=
+ λ T, i2p (subsume_full_ofty_value_untyped_prefix π E L l vs1 vs2 ly1 ly2 T).
+ *)
+
+ Lemma subsume_full_value_untyped_full π E L step v vs1 vs2 ly1 ly2 T `{!LayoutSizeEq ly1 ly2} :
+ ⌜ly_align_log ly2 ≤ ly_align_log ly1⌠∗ ⌜vs1 = vs2⌠∗ T L True%I
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t (UntypedSynType ly1)) (v â—áµ¥{Ï€} vs2 @ value_t (UntypedSynType ly2)) T.
+ Proof.
+ iIntros "(%Hal & -> & HT)".
+ iIntros (???) "#CTX #HE HL Hv".
+ iExists _, _. iFrame.
+ iApply maybe_logical_step_intro. iL.
+ iApply value_untyped_mono; last done.
+ - done.
+ - intros. by eapply layout_wf_mono.
+ - intros. by eapply ly_align_in_bounds_mono.
+ Qed.
+ (* NOTE: needs to be higher-priority than [subsume_full_value_st_untyped] in order to prevent divergence *)
+ Global Instance subsume_full_value_untyped_full_inst π E L step v vs1 vs2 ly1 ly2 `{!LayoutSizeEq ly1 ly2} :
+ SubsumeFull E L step (v â—áµ¥{Ï€} vs1 @ value_t (UntypedSynType ly1))%I (v â—áµ¥{Ï€} vs2 @ value_t (UntypedSynType ly2))%I | 6 :=
+ λ T, i2p (subsume_full_value_untyped_full π E L step v vs1 vs2 ly1 ly2 T).
+
+ (** Step 1 *)
+ (* instantiate in case [st2] is an evar *)
+ Lemma subsume_full_value_st_evar E L step π v st1 st2 vs1 vs2 T :
+ ⌜st1 = st2⌠∗ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t st1)%I (v â—áµ¥{Ï€} vs2 @ value_t st1)%I T
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t st1) (v â—áµ¥{Ï€} vs2 @ value_t st2) T.
+ Proof.
+ iIntros "(-> & HT)". iApply "HT".
+ Qed.
+ Global Instance subsume_full_value_st_evar_inst E L step π v st1 st2 vs1 vs2 `{!IsProtected st2} :
+ SubsumeFull E L step (v â—áµ¥{Ï€} vs1 @ value_t st1)%I (v â—áµ¥{Ï€} vs2 @ value_t st2)%I | 10 :=
+ λ T, i2p (subsume_full_value_st_evar E L step π v st1 st2 vs1 vs2 T).
+
+ (* in case st1 is Untyped, make the goal untyped, too *)
+ Lemma subsume_full_value_st_untyped E L step π vs1 vs2 v st2 ly1 T :
+ (li_tactic (compute_layout_goal st2) (λ ly2, subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t (UntypedSynType ly1))%I (v â—áµ¥{Ï€} vs2 @ (value_t (UntypedSynType ly2)))%I T))
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t (UntypedSynType ly1)) (v â—áµ¥{Ï€} vs2 @ (value_t st2)) T.
+ Proof.
+ rewrite /compute_layout_goal.
+ iIntros "(%ly2 & %Halg & HT)".
+ iIntros (???) "#CTX #HE HL Hv".
+ iMod ("HT" with "[//] [//] CTX HE HL Hv") as "(%L2 & %R2 & Hv & ? & ?)".
+ iExists L2, _. iFrame.
+ iApply (maybe_logical_step_wand with "[] Hv").
+ iIntros "(Hv & $)". iApply value_make_typed; done.
+ Qed.
+ Global Instance subsume_full_value_st_untyped_inst E L step π v ly1 st2 vs1 vs2 :
+ SubsumeFull E L step (v â—áµ¥{Ï€} vs1 @ value_t (UntypedSynType ly1))%I (v â—áµ¥{Ï€} vs2 @ value_t st2)%I | 15 :=
+ λ T, i2p (subsume_full_value_st_untyped E L step π vs1 vs2 v st2 ly1 T).
+
+ (* if all of the above fail, require equality of the syntypes.
+ TODO: this is too strict *)
+ Lemma subsume_full_value_st_eq E L step π v vs1 vs2 st1 st2 T :
+ ⌜st1 = st2⌠∗ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t st2) (v â—áµ¥{Ï€} vs2 @ value_t st2) T
+ ⊢ subsume_full E L step (v â—áµ¥{Ï€} vs1 @ value_t st1) (v â—áµ¥{Ï€} vs2 @ value_t st2) T.
+ Proof.
+ iIntros "(-> & $)".
+ Qed.
+ Global Instance subsume_full_value_st_eq_inst E L step π v st1 st2 vs1 vs2 :
+ SubsumeFull E L step (v â—áµ¥{Ï€} vs1 @ value_t st1)%I (v â—áµ¥{Ï€} vs2 @ value_t st2)%I | 20 :=
+ λ T, i2p (subsume_full_value_st_eq E L step π v vs1 vs2 st1 st2 T).
+
+
+
+ (* TODO: one thing that definitely needs to work:
+ value_t (UntypedOp ly) <: value_t st when st_has_layout st ly
+ *)
+
+
+ (* When we require assembled ownership, try to assemble it. *)
+ (* This needs to have lower priority than the above subsumption instances that specialize to the case where [ty = value_t _]. *)
+ (* In addition, other rules for other types should similarly be able to implement their own proof strategies.
+ Namely, this rule makes a pretty strong commitment (having an exactly fitting value assignment available),
+ so we should really try it as a last resort. So we give it a pretty low priority.
+ *)
+ (* TODO: for this, need some ty_has_syn_type relation that also captures the Untyped case *)
+ (* TODO ideally, the requirement for the UntypedOp case should just generally hold for types. Untyped should always be possible. *)
+ Lemma subsume_value_merge_ofty {rt} π (ty : type rt) r v l st wl T :
+ (v â—áµ¥{Ï€} r @ ty ∗
+ ⌜match st with
+ | UntypedSynType ly1 => syn_type_has_layout ty.(ty_syn_type) ly1 ∧ ty_has_op_type ty (UntypedOp ly1) MCCopy
+ | _ => ty.(ty_has_op_type) (use_op_alg' ty.(ty_syn_type)) MCCopy ∧ ty_syn_type ty = st
+ end⌠∗ T)
+ ⊢ subsume (l â—â‚—[Ï€, Owned wl] PlaceIn v @ â— value_t st) (l â—â‚—[Ï€, Owned wl] PlaceIn r @ (â— ty)) T.
+ Proof.
+ iDestruct 1 as "(Hv & %Ha & HT)". simpl.
+ iIntros "Hl".
+ rewrite !ltype_own_ofty_unfold /lty_of_ty_own.
+ iDestruct "Hl" as "(%ly & %Halg & % & Hsc & Hlb & Hcred & %r' & Hrfn & Hb)".
+ simpl in Halg. iFrame "HT".
+ iExists ly.
+ iFrame. iFrame "%".
+ iPoseProof (ty_own_val_sidecond with "Hv") as "#$".
+ assert ((∃ ly1, st = UntypedSynType ly1 ∧ syn_type_has_layout (ty_syn_type ty) ly1 ∧ ty_has_op_type ty (UntypedOp ly1) MCCopy) ∨ (ty_has_op_type ty (use_op_alg' (ty_syn_type ty)) MCCopy ∧ ty_syn_type ty = st)) as Hb.
+ { destruct st; eauto. }
+ iSplitR. { iPureIntro. destruct Hb as [(ly1 & -> & ? & ?) | (? & <-)]; last done.
+ apply syn_type_has_layout_untyped_inv in Halg as (-> & _). done. }
+ iExists r. iSplitR; first done.
+ iNext. iMod "Hb" as "(%v' & Hl & Hv')". iModIntro.
+ iDestruct "Hrfn" as "<-".
+ iExists v'. iFrame.
+ iEval (rewrite /ty_own_val/=) in "Hv'".
+ iDestruct "Hv'" as "(%ot & %Hot' & %Hmc & %Hv & ?)".
+ destruct Hmc as [-> | [st' ->]]; first done.
+ iApply (ty_memcast_compat_copy with "Hv").
+
+ destruct Hb as [(ly1 & -> & Hst & ?) | (Hst & <-)].
+ - injection Hot' as <-. done.
+ - move: Hst. rewrite /use_op_alg' Hot' //.
+ Qed.
+
+ Lemma subsume_full_value_merge_ofty_untyped {rt} π E L (ty : type rt) r v l ly1 wl T :
+ (prove_with_subtype E L false ProveDirect (v â—áµ¥{Ï€} r @ ty) (λ L' _ R,
+ ⌜syn_type_has_layout ty.(ty_syn_type) ly1⌠∗ ⌜ty_has_op_type ty (UntypedOp ly1) MCCopy⌠∗ T L' R))
+ ⊢ subsume_full E L false (l â—â‚—[Ï€, Owned wl] PlaceIn v @ â— value_t (UntypedSynType ly1)) (l â—â‚—[Ï€, Owned wl] PlaceIn r @ (â— ty)) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL Hl".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & % & %R & >(Hv & HR) & HL & % & % & HT)".
+ iModIntro. iExists L', R. iFrame.
+ iPoseProof (subsume_value_merge_ofty _ _ _ _ _ _ _ True%I with "[$Hv ] Hl") as "($ & _)"; last done.
+ iL. done.
+ Qed.
+ (* should have a lower priority than Lithium's id instance - in case the goal specifies that we want a value_t, we should not try to fiddle with that. *)
+ Global Instance subsume_full_value_merge_ofty_untyped_inst {rt} π E L (ty : type rt) r v l ly1 wl :
+ SubsumeFull E L false (l â—â‚—[Ï€, Owned wl] PlaceIn v @ â— value_t (UntypedSynType ly1))%I (l â—â‚—[Ï€, Owned wl] PlaceIn r @ (â— ty))%I | 100 :=
+ λ T, i2p (subsume_full_value_merge_ofty_untyped π E L ty r v l ly1 wl T).
+
+ Lemma subsume_full_value_merge_ofty {rt} π E L (ty : type rt) r v l st wl T :
+ (prove_with_subtype E L false ProveDirect (v â—áµ¥{Ï€} r @ ty) (λ L' _ R,
+ ⌜ty.(ty_has_op_type) (use_op_alg' ty.(ty_syn_type)) MCCopy⌠∗ ⌜ty_syn_type ty = st⌠∗ T L' R))
+ ⊢ subsume_full E L false (l â—â‚—[Ï€, Owned wl] PlaceIn v @ â— value_t st) (l â—â‚—[Ï€, Owned wl] PlaceIn r @ (â— ty)) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL Hl". iPoseProof (ltype_own_has_layout with "Hl") as "(%ly' & %Hst & %)".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L' & % & %R & >(Hv & HR) & HL & %Hc & %Ha & HT)".
+ iModIntro. iExists L', R. iFrame.
+ iPoseProof (subsume_value_merge_ofty _ _ _ _ _ _ _ True%I with "[$Hv] Hl") as "($ & _)"; last done.
+ iL. destruct st; try done. simp_ltypes in Hst. simpl in Hst. rewrite Ha.
+ specialize (syn_type_has_layout_untyped_inv _ _ Hst) as (-> & _).
+ rewrite Ha in Hc. iPureIntro. split; done.
+ Qed.
+ (* should have a lower priority than Lithium's id instance - in case the goal specifies that we want a value_t, we should not try to fiddle with that. *)
+ Global Instance subsume_full_value_merge_ofty_inst {rt} π E L (ty : type rt) r v l st wl :
+ SubsumeFull E L false (l â—â‚—[Ï€, Owned wl] PlaceIn v @ â— value_t st)%I (l â—â‚—[Ï€, Owned wl] PlaceIn r @ (â— ty))%I | 101 :=
+ λ T, i2p (subsume_full_value_merge_ofty π E L ty r v l st wl T).
+
+ Lemma owned_subtype_value_merge {rt} π E L (ty : type rt) r v' st T :
+ prove_with_subtype E L false ProveDirect (v' â—áµ¥{Ï€} r @ ty) (λ L' _ R,
+ introduce_with_hooks E L' R (λ L2, ⌜ty.(ty_has_op_type) (use_op_alg' ty.(ty_syn_type)) MCCopy⌠∗
+ ⌜ty_syn_type ty = st⌠∗ T L2))
+ ⊢ owned_subtype π E L false v' r (value_t st) (ty) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L2 & %κs & %R & >(Hv' & HR) & HL & HT)".
+ iMod ("HT" with "[//] HE HL HR") as "(%L3 & HL & %Hot & <- & HT)".
+ iExists _. iFrame. iModIntro.
+ iPoseProof (ty_own_val_sidecond with "Hv'") as "#$".
+ iSplitR. { iPureIntro. simpl. iIntros (????). f_equiv. by eapply syn_type_has_layout_inj. }
+ iSplitR; first by eauto.
+ iIntros (v) "Hv".
+ iEval (rewrite /ty_own_val/=) in "Hv".
+ iDestruct "Hv" as "(%ot & %Hot' & %Hmc & %Hly & %Hst')".
+ rewrite /use_op_alg' Hot'/= in Hot.
+ destruct Hmc as [-> | (st & ->)]; first done.
+ iApply (ty_memcast_compat_copy with "Hv'"). done.
+ Qed.
+ (* shouldn't have super high priority because the conclusion is very general *)
+ Global Instance owned_subtype_value_merge_inst {rt} π E L (ty : type rt) r v' st :
+ OwnedSubtype π E L false v' r (value_t st) (ty) | 100 :=
+ λ T, i2p (owned_subtype_value_merge π E L ty r v' st T).
+ (*
+ Lemma subsume_full_value_merge {rt} π E L (ty : type rt) r v v' st T :
+ prove_with_subtype E L false ProveDirect (v' â—áµ¥{Ï€} r @ ty) (λ L' _ R,
+ ⌜ty.(ty_has_op_type) (use_op_alg' ty.(ty_syn_type)) MCCopy⌠∗ ⌜ty_syn_type ty = st⌠∗ T L' R) -∗
+ subsume_full E L false (v â—áµ¥{Ï€} v' @ value_t st) (v â—áµ¥{Ï€} r @ ty) T.
+ Proof.
+ iIntros "HT".
+ iIntros (???) "#CTX #HE HL Hv".
+ iMod ("HT" with "[//] [//] CTX HE HL") as "(%L2 & %κs & %R & >(Hv' & HR) & HL & %Hot & <- & HT)".
+ iExists _, _. iFrame. iModIntro.
+ iEval (rewrite /ty_own_val/=) in "Hv".
+ iDestruct "Hv" as "(%ot & %Hot' & %Hmc & %Hly & %Hst')".
+ rewrite /use_op_alg' Hot'/= in Hot.
+ destruct Hmc as [-> | (st & ->)]; first done.
+ iApply (ty_memcast_compat_copy with "Hv'"). done.
+ Qed.
+ *)
+
+
+
+ (* Simplification instance - when introducing a value_t, we simply destruct it *)
+ (* TODO how does this overlap with ghost_drop?
+ TODO can we simplify the is_memcast_val? Otherwise, it seems pretty useless. *)
+ (*
+ Lemma value_simplify π v T ot st p :
+ (⌜is_memcast_val p ot v⌠-∗ ⌜v `has_layout_val` ot_layout ot⌠-∗ ⌜syn_type_has_layout st (ot_layout ot)⌠-∗ T) -∗
+ simplify_hyp (v â—áµ¥{Ï€} p @ value_t st)%I T.
+ Proof. iIntros "HT (% & % & %)". by iApply "HT". Qed.
+ Global Instance value_simplify_inst π v ot st p :
+ SimplifyHypVal v π (value_t ot st) p (Some 0%N) :=
+ λ T, i2p (value_simplify π v T ot st p).
+ *)
+
+ (* We also need stratification instances.
+ - One option: always cancel value_t in stratification.
+ This limits expressivity a bit for specs, because when we really want to have value_t there, we get stuck.
+ => do this for now, it should suffice.
+ - Other option: have a (non-semantic) guidance parameter that gets provided by OpenedLtype.
+ Only if that guidance parameter is not giving us identity do we fold the value_t.
+ - Other option: do not let stratify do this, but rather have subtyping do this before folding.
+
+ TODO: currently not an instance, because we sometimes do not want to do this!
+ Instead, should give stratify some syntactic guidance from OpenedLtype above it.
+ *)
+ Lemma stratify_ltype_ofty_value_owned π E L mu mdu ma {M} (m : M) l st v wl (T : stratify_ltype_cont_t) :
+ find_in_context (FindVal v π) (λ '(existT rt (ty', r')),
+ ⌜ty'.(ty_has_op_type) (use_op_alg' ty'.(ty_syn_type)) MCCopy⌠∗
+ ⌜ty'.(ty_syn_type) = st⌠∗
+ stratify_ltype π E L mu mdu ma m l (◠ty') (PlaceIn r') (Owned wl) T)
+ ⊢ stratify_ltype π E L mu mdu ma m l (◠value_t st)%I (PlaceIn v) (Owned wl) T.
+ Proof.
+ iDestruct 1 as ([rt [ty' r']]) "(Hv & %Hot & %Heq & HT)" => /=.
+ iIntros (???) "#CTX #HE HL Hl".
+ iPoseProof (ltype_own_has_layout with "Hl") as "#(%ly & %Hst &_)".
+ iPoseProof (subsume_value_merge_ofty with "[$Hv] Hl") as "(Ha & _)".
+ { instantiate (1 := True%I). iSplitR; last done.
+ iPureIntro. subst st. destruct (ty_syn_type ty'); try done.
+ simp_ltypes in Hst. simpl in Hst.
+ specialize (syn_type_has_layout_untyped_inv _ _ Hst) as (-> & _).
+ done. }
+ iMod ("HT" with "[//] [//] CTX HE HL Ha") as "Ha".
+ subst st. eauto.
+ Qed.
+ (* needs to have a higher priority than the ofty_resolve_ghost instance *)
+ (*Global Instance stratify_ltype_unblock_ofty_value_owned_inst π E L mu mdu ma l st v wl :*)
+ (*StratifyLtype π E L mu mdu ma StratifyUnblockOp l (◠value_t st)%I (PlaceIn v) (Owned wl) | 10:=*)
+ (*λ T, i2p (stratify_ltype_ofty_value_owned π E L mu mdu ma StratifyUnblockOp l st v wl T).*)
+ (* TODO: not an instance right now since we don't always want to stratify this -- esp. not for functions passing values in their interface *)
+
+ (* TODO: this is now problematic. Maybe should have an untyped bit after all?
+ Alternative: use syn_type_compat everywhere to allow untyped interaction.
+
+ Use an untyped bit:
+ - then we still have a problem that often we should maybe be talking about a concrete layout instead.
+ In particular when we assemble chunks.
+ For array, we can work around that, since it is "chunkable", but for everything else, that does not really work.
+ Q: do we reallyneed that for anything but arrays?
+ + when we want to have a view on data and change the element type: e.g. in copy_nonoverlapping, would like to have an array of u8.
+ We could in principle also do that for the ArraySynType, but it would be more of a hassle, and we would again end up with a different syntype
+ OTOH is copy_nonoverlapping that much of a concern?
+ In principle, we could also have something that first adapts
+ - making things untyped would be much less of a hassle in the rules.
+
+ Make rules compatible with UntypedSynType everywhere:
+ - what is the intuitive justification for this? Why should we do it?
+ + to my mind, UntypedSynType is just an undesirable artifact -- at least in safe Rust.
+ + for unsafe stuff, the story may be different. We may want to treat stuff just as bytes.
+ - allocation API itself should maybe treat it that way. We should just have some layout there.
+ In our system, we will have a mixed concrete-symbolic layout.
+ Arguably, that should not be a proper syntype, but that's how it is: our types need a syntype, and generally that requirement seems sensible.
+
+ Alternative for this particular issue:
+ - at the place, just don't leave an Untyped, but the right type. We should not loose information there!
+ Then we also do not need a syntype update.
+
+ *)
+
+ (* TODO: consider whether we need special instances for reading/writing.
+ In particular, what if we read with an ot from an UntypedOp-value? Then we should specialize the ot further in the result of the read.
+ - problem currently: the generic ofty instance requires the type to have the same ot
+ - but in case of value_t, we can change the ot!
+
+ *)
+
+
+ (* [type_read_end] instance that does a move -- should be triggered when the copy instance does not work, hence the lower priority.
+ This leaves a [value_t] at the place.
+ *)
+ Lemma type_read_ofty_move_owned_value E L {rt} π (T : typed_read_end_cont_t rt) l (ty : type rt) r ot wl bmin :
+ ( ⌜use_op_alg (ty_syn_type ty) = Some ot⌠∗ (* TODO too strong, should also allow Untyped *)
+ (* TODO for some reason, [simpl] will even unfold [ty_has_op_type] here... this breaks automation ofc *)
+ (*⌜ty_allows_reads ty⌠∗*)
+ ⌜ty_has_op_type ty (use_op_alg' (ty_syn_type ty)) MCCopy⌠∗
+ (*⌜ty.(ty_has_op_type) ot MCCopy⌠∗*)
+ ∀ v v', v â—áµ¥{Ï€} r @ ty -∗
+ T L v' _ (value_t ty.(ty_syn_type)) v val (â— value_t ty.(ty_syn_type)) (#v) ResultStrong)
+ ⊢ typed_read_end π E L l (◠ty) (#r) (Owned wl) bmin AllowStrong ot T.
+ Proof.
+ iIntros "(%Hotalg & %Hot & Hs)" (F ???) "#CTX #HE HL".
+ iIntros "_ Hb".
+ iPoseProof (ofty_ltype_acc_owned with "Hb") as "(%ly & %Halg & %Hly & Hsc & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ specialize (ty_op_type_stable Hot) as Halg''.
+ rewrite /use_op_alg' Hotalg in Halg''.
+ assert (ly = ot_layout ot) as ->. { by eapply syn_type_has_layout_inj. }
+ iModIntro. iExists _, _, rt, _, _.
+ iFrame "Hl Hv".
+ iSplitR; first done. iSplitR; first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl %st Hl Hv".
+ iAssert (v â—áµ¥{Ï€} v @ value_t ty.(ty_syn_type))%I as "Hv'".
+ { rewrite /ty_own_val/=.
+ (*destruct (syn_type_has_layout_op_alg _ _ Halg) as (ot' & Hop & Hot').*)
+ iExists (ot).
+ iR. iSplitR. { iPureIntro. left. done. }
+ iSplitR; last done. iPureIntro. rewrite /has_layout_val . done. }
+ iPoseProof (ty_memcast_compat_copy _ _ _ ot _ st with "Hv'") as "Hv''".
+ { simpl. exists ot. split_and!; first done; last done. by apply is_value_ot_core_refl. }
+ iMod ("Hcl" $! v _ (value_t ty.(ty_syn_type)) (v) with "Hl [//] [] []") as "Hl".
+ { simpl. done. }
+ { iNext. done. }
+ (*iPoseProof (ty_memcast_compat with "Hv") as "Hid"; first done. simpl.*)
+ iModIntro. iExists _, _, (value_t (ty_syn_type ty)), _. iFrame "∗ #".
+ (* strong update *)
+ iExists _, _, _, ResultStrong. iFrame.
+ do 2 iR.
+ iApply "Hs". done.
+ Qed.
+ (* TODO replace the succeeding instances with this, once we have fixed:
+ (a) owned_subtype to be able to move stuff into it again reliably, also below structs etc.
+ (b) the model to allow syntype updates as long as the layout stays the same *)
+ (*Global Instance type_read_ofty_move_owned_inst E L {rt} π wl bmin l (ty : type rt) r ot :*)
+ (*TypedReadEnd π E L l (◠ty)%I (PlaceIn r) (Owned wl) bmin AllowStrong ot | 19 :=*)
+ (*λ T, i2p (type_read_ofty_move_owned E L π T l ty r ot wl bmin).*)
+
+ (* TODO for Untyped, we currently cannot leave a value, because we cannot do syntype updates, but [value_t] relies on the syntype to compute the value update *)
+ Lemma type_read_ofty_move_owned_value_untyped E L {rt} π (T : typed_read_end_cont_t rt) l (ty : type rt) r ly wl bmin :
+ (⌜ty.(ty_has_op_type) (UntypedOp ly) MCCopy⌠∗
+ ∀ v, T L v _ ty r unit (◠uninit ty.(ty_syn_type)) (#()) ResultStrong)
+ ⊢ typed_read_end π E L l (◠ty) (#r) (Owned wl) bmin AllowStrong (UntypedOp ly) T.
+ Proof.
+ iIntros "(%Hot & Hs)" (F ???) "#CTX #HE HL".
+ iIntros "_ Hb".
+ iPoseProof (ofty_ltype_acc_owned with "Hb") as "(%ly' & %Halg & %Hly & Hsc & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ specialize (ty_op_type_stable Hot) as Halg''.
+ assert (ly' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ iModIntro. iExists _, _, rt, _, _.
+ iFrame "Hl Hv".
+ iSplitR; first done. iSplitR; first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl %st Hl Hv". iMod ("Hcl" $! v _ (uninit ty.(ty_syn_type)) tt with "Hl [//] [] []") as "Hl".
+ { simpl. done. }
+ { iNext. iApply uninit_own_spec. iExists _. iSplitR; first done. done. }
+ iPoseProof (ty_memcast_compat with "Hv") as "Hid"; first done. simpl.
+ iModIntro. iExists _, _,_, _. iFrame.
+ (* strong update *)
+ iExists _, _, _, ResultStrong. iFrame.
+ iSplitR; first done.
+ iR.
+ done.
+ Qed.
+ (*
+ Global Instance type_read_ofty_move_owned_untyped_inst E L {rt} π wl bmin l (ty : type rt) r ly :
+ TypedReadEnd π E L l (◠ty)%I (PlaceIn r) (Owned wl) bmin AllowStrong (UntypedOp ly) | 20 :=
+ λ T, i2p (type_read_ofty_move_owned_untyped E L π T l ty r ly wl bmin).
+ *)
+
+ Lemma type_read_ofty_move_owned E L {rt} π (T : typed_read_end_cont_t rt) l (ty : type rt) r ot wl bmin :
+ (⌜ty.(ty_has_op_type) ot MCCopy⌠∗
+ ∀ v, T L v _ ty r unit (◠uninit ty.(ty_syn_type)) (#()) ResultStrong)
+ ⊢ typed_read_end π E L l (◠ty) (#r) (Owned wl) bmin AllowStrong ot T.
+ Proof.
+ iIntros "(%Hot & Hs)" (F ???) "#CTX #HE HL".
+ iIntros "_ Hb".
+ iPoseProof (ofty_ltype_acc_owned with "Hb") as "(%ly' & %Halg & %Hly & Hsc & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ specialize (ty_op_type_stable Hot) as Halg''.
+ assert (ly' = ot_layout ot) as ->. { by eapply syn_type_has_layout_inj. }
+ iModIntro. iExists _, _, rt, _, _.
+ iFrame "Hl Hv".
+ iSplitR; first done. iSplitR; first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl %st Hl Hv". iMod ("Hcl" $! v _ (uninit ty.(ty_syn_type)) tt with "Hl [//] [] []") as "Hl".
+ { simpl. done. }
+ { iNext. iApply uninit_own_spec. iExists _. iSplitR; first done. done. }
+ iPoseProof (ty_memcast_compat with "Hv") as "Hid"; first done. simpl.
+ iModIntro. iExists _, _,_, _. iFrame.
+ (* strong update *)
+ iExists _, _, _, ResultStrong. iFrame.
+ iSplitR; first done.
+ iR.
+ done.
+ Qed.
+ Global Instance type_read_ofty_move_owned_inst E L {rt} π wl bmin l (ty : type rt) r ot :
+ TypedReadEnd π E L l (◠ty)%I (PlaceIn r) (Owned wl) bmin AllowStrong (ot) | 20 :=
+ λ T, i2p (type_read_ofty_move_owned E L π T l ty r ot wl bmin).
+
+ (*
+ Lemma type_read_ofty_move_owned_untyped E L {rt} π (T : typed_read_end_cont_t rt) l (ty : type rt) r ly wl bmin :
+ ( ⌜ty.(ty_has_op_type) (UntypedOp ly) MCCopy⌠∗
+ ∀ v v', v â—áµ¥{Ï€} r @ ty -∗
+ T L v' _ (value_t (UntypedSynType ly)) v val (◠value_t (UntypedSynType ly)) (#v) ResultStrong) -∗
+ typed_read_end π E L l (◠ty) (#r) (Owned wl) bmin AllowStrong (UntypedOp ly) T.
+ Proof.
+ iIntros "(%Hot & Hs)" (F ???) "#CTX #HE HL".
+ iIntros "_ Hb".
+ iPoseProof (ofty_ltype_acc_owned with "Hb") as "(%ly' & %Halg & %Hly & Hsc & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ specialize (ty_op_type_stable Hot) as Halg''.
+ (*rewrite /use_op_alg' Hotalg in Halg''.*)
+ assert (ly' = ly) as ->. { by eapply syn_type_has_layout_inj. }
+ iModIntro. iExists _, _, rt, _, _.
+ iFrame "Hl Hv".
+ iSplitR; first done. iSplitR; first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "Hcl %st Hl Hv".
+ iAssert (v â—áµ¥{Ï€} v @ value_t (UntypedSynType ly))%I as "Hv'".
+ { rewrite /ty_own_val/=.
+ (*destruct (syn_type_has_layout_op_alg _ _ Halg) as (ot' & Hop & Hot').*)
+ iExists (UntypedOp ly).
+ iR. iSplitR. { iPureIntro. left. done. }
+ simpl. iR. iPureIntro. by eapply syn_type_has_layout_make_untyped. }
+ (*iPoseProof (ty_memcast_compat_copy _ _ _ ot _ st with "Hv'") as "Hv''".*)
+ (*{ simpl. exists ot. split_and!; first done; last done. by apply is_value_ot_core_refl. }*)
+ iMod ("Hcl" $! v _ (value_t (UntypedSynType ly)) (v) with "Hl [//] [] []") as "Hl".
+ { simpl. done. }
+ { iNext. done. }
+ (*iPoseProof (ty_memcast_compat with "Hv") as "Hid"; first done. simpl.*)
+ iModIntro. iExists _, _, (value_t (ty_syn_type ty)), _. iFrame "∗ #".
+ (* strong update *)
+ iExists _, _, _, ResultStrong. iFrame.
+ do 2 iR.
+ iApply "Hs". done.
+ Qed.
+ Global Instance type_read_ofty_move_owned_inst E L {rt} π wl bmin l (ty : type rt) r ot :
+ TypedReadEnd π E L l (◠ty)%I (PlaceIn r) (Owned wl) bmin AllowStrong ot | 20 :=
+ λ T, i2p (type_read_ofty_move_owned E L π T l ty r ot wl bmin).
+ *)
+
+
+
+ (* We also have a corresponding rule for Uniq ownership that leaves [Opened].
+ This allows us to move out of mutable references, as long as another object is moved in at a later point. *)
+ (* TODO also move value out here. *)
+ Lemma type_read_ofty_move_uniq E L {rt} π (T : typed_read_end_cont_t rt) l (ty : type rt) r ot κ γ bmin :
+ (li_tactic (lctx_lft_alive_count_goal E L κ) (λ '(κs, L2),
+ ⌜ty.(ty_has_op_type) ot MCCopy⌠∗
+ ∀ v, T L2 v _ ty r unit (OpenedLtype (â— uninit ty.(ty_syn_type)) (â— ty) (â— ty) (λ r1 r2, ⌜r1 = r2âŒ) (λ _ _, llft_elt_toks κs)) (#()) ResultStrong))
+ ⊢ typed_read_end π E L l (◠ty) (#r) (Uniq κ γ) bmin AllowStrong ot T.
+ Proof.
+ iIntros "HT" (F ???) "#CTX #HE HL".
+ rewrite /lctx_lft_alive_count_goal.
+ iDestruct "HT" as (κs L2) "(%Hal & %Hot & HT)".
+ iIntros "Hincl0 Hb".
+
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod (lctx_lft_alive_count_tok with "HE HL") as (q) "(Htok & Hcl_tok & HL)"; [done.. | ].
+ iPoseProof (ofty_ltype_acc_uniq with "CTX Htok Hcl_tok Hb") as "(%ly & %Halg & %Hly & Hlb & >(%v & Hl & Hv & Hcl))"; first done.
+ iPoseProof (ty_own_val_has_layout with "Hv") as "%Hlyv"; first done.
+ specialize (ty_op_type_stable Hot) as Halg''.
+ assert (ly = ot_layout ot) as ->. { by eapply syn_type_has_layout_inj. }
+ iMod "Hcl_F" as "_".
+ iModIntro. iExists _, _, rt, _, _.
+ iFrame "Hl Hv".
+ do 2 iR.
+ iApply (logical_step_mask_mono lftE); first done.
+ iApply (logical_step_wand with "Hcl").
+ iIntros "[_ Hcl] %st Hl Hv".
+ iMod (fupd_mask_subseteq lftE) as "Hcl_F"; first done.
+ iMod ("Hcl" $! v _ (uninit ty.(ty_syn_type)) tt with "Hl [] [] [//]") as "Hl".
+ { simpl. done. }
+ { iApply uninit_own_spec. iExists _. iSplitR; first done. done. }
+ iPoseProof (ty_memcast_compat _ _ _ _ st with "Hv") as "Hid"; first done. simpl.
+ iMod "Hcl_F" as "_".
+ iModIntro. iExists _, _,_, _. iFrame.
+ (* strong update *)
+ iExists _, _, _, ResultStrong. iFrame.
+ iSplitR; first done.
+ iR.
+ done.
+ Qed.
+ Global Instance type_read_ofty_move_uniq_inst E L {rt} π κ γ bmin l (ty : type rt) r ot :
+ TypedReadEnd π E L l (◠ty)%I (#r) (Uniq κ γ) bmin AllowStrong ot | 20 :=
+ λ T, i2p (type_read_ofty_move_uniq E L π T l ty r ot κ γ bmin).
+
+End rules.