From 156e9d6f4b6f6d5b393a501812cf95dcbce8ad67 Mon Sep 17 00:00:00 2001 From: Eddy Westbrook Date: Tue, 19 Oct 2021 16:32:40 -0700 Subject: [PATCH] Change array permissions to contain shapes (#1484) * fixed the IRT description generation to match the recent change that made the translation of bitvector permissions to just be bitvectors * updated xor_swap_rust example to use the Rust type in the SAW script * added a case to the Rust to Heapster translator to handle function types with no return value * whoops, forgot to update the bitcode file for xor_swap_rust * bugfix in the Rust to Heapster translator: empty return types need to be converted to unit, not to the empty struct * tweaked the error message for when Rust types do not translate correctly to the expected LLVM type * started adding support for string literals by moving all creation of a HeapsterEnv into a single function which iterates through the globals and adds those it can handle * added a formatting example in Rust, and started defining the necessary types for it * started trying to figure out how Rust stores string literals in its generated LLVM files * fixed the prtty-printing for constant values * changed TrueEnum::fmt to use the fmt method rather than the write! macro * whoops, changed the fmt method for TrueEnum back to using the write! macro, because that seems to be the proper way to do things * whoops, forgot to add the repr(u64) pragma to the TrueEnum type * added a type-checking command for TrueEnum::fmt * moved some OpenTerm operators from SAWTranslation.hs to OpenTerm.hs * added llvmReadBlockOfShape * more work trying to translate globals * got string literals translated, but now there is some translation bug... * whoops, translating a shape always yields exactly one term * added helper function exprLLVMTypeBytes * added support for Rust slice types * whoops, combined the two cases for translating shared vs mutable references into one * updated funPerm3FromArgLayout to handle layouts with existential permissions * updated the rust_data example to use string literals * added mapM and mapBVVecM * added support for proving array permissions from other array permissions with different fields using the SImpl_LLVMArrayContents rule; to get the translation of the SImpl_LLVMArrayContents to work correctly, I had to change local implications to not use strict tuples, which in turn required changing the translation of lowned permissions (which are themselves local implications) to not use strict tuples as well * added more definitions to the arrays example now that the implication prover can map array permission contents * moved the LLVM globals code to a new file LLVMGlobalConst.hs * fixed the translation of LLVM array constants to generate SAW core BVVecs instead of SAW core Vecs * regenerated Coq files for saw-core-coq * added support for the Crucible BVZext and BVTrunc instructions, and fixed up that for BVSext * added heapster_init_env_debug and heapster_init_env_from_file_debug commands * small tweaks to rust_data.saw to get it to work * added another formatting example that we cannot handle yet... * RecurseFlag to Permissions.hs; added requireNamedPerm * widening now unfolds defined and recursive permissions * whoops, forgot to insert a bindM into the translation of SImpl_LLVMArrayContents * removed the old gen_block_perms hints that are no longer used anyway from arrays.saw * changed tupleTypeTrans to no longer having the trailing unit type on tuples of 2 or more types; updated foldList and unfoldList in the SAW core Prelude to fit this new approach; regenerated the resulting Coq files * small tweak to the expression type-checker to type-check the bodies of existential shapes as arbitrary expressions * expanded the translation of Rust slices to allow multiple fields * updated mbox proof script to work with the recent changes, though not all the mbox proofs work... * started updating the mbox proofs, but I got stuck... * moved formatting-related types in the rust_data example to their own section * finished updating mbox proofs * generalized array permissions and array shapes to use shapes for their cells instead of lists of fields * updated examples to match the change to the SAW translation * updated the IRT translation to match the updates to the SAW translation * updated to use the new array permission with a shape for the cells * started updating the permission implication prover with the new array permissions * added support for array permissions in lowned permissions; fixed a few small bugs * more work moving two arrays with shapes for their cells * wrote implElimLLVMBlockForOffset; rewrote proveVarLLVMField in terms of implGetLLVMPermForOffset * trying to get the newly-writte Implication.hs to compile... * finally got Implication.hs to compile * added support for the new LOwnedPermArray constructor * small tweak to avoid warning * updated parser and type-checker for the new array permissions * whoops, fixed some compilation errors in Widening.hs that were obscured by other files * fixed typo in comment * removed comments * removed a use of the now outdated LLVMArrayField type * fixed error message * udpated SAWTranslation.hs to compile with the new approach to array permissions * changed updBVVec to not require a proof that the index is in the array * updated IRTTranslation.hs to support the new form of the array permission * updated the arrays.saw example to use the new form of array permission * whoops, fixed a bug in proveVarLLVMField; also added some extra debugging information * incorporated unfolding into implGetLLVMPermForOffset; fixed llvmPermIndicesForOffset, which was implemented incorrectly; added some debugging info * whoops, should not have commented out the cases for eliminating blocks with field or array shape * changed typeTransF to a helper function that prints more debug info on error * whoops, fixed the translation of SImpl_ElimLLVMBlockField * updated the linked_list example to use the new array permission * whoops, used the wrong variant of implGetConjM in one of the proveVarLLVMBlocks1 cases; also added more debug info to some of the lower-level implication prover combinators * updated the parsing for array shapes to more closely match the conventions for array permissions * clarified the fact that the cell type translation of an array permission translation is really the translation of the memblock permission to the first cell of the array, and fixed a translation bug related to this issue * fixed a bug in the SImpl_ElimLLVMBlockArray: that rule should only work when the input block permission has the same size as the resulting array shape * updated the generated Coq files * updated array permissions in the examples to use the new array permission syntax * fixed a bug in implElimLLVMBlockForOffset, which was not handling non-conjunctive permissions returned by implElimLLVMBlock; added pretty-printing and typing information for the names bound by local implications * fixed a subtle bug in offsetLLVMPermTrans applied to the translations of defined permissions * fixed the pretty-printer for array shapes to use the < and * prefixes * whoops, I accidentally swapped the input and output permissions of the local implication used to prove array contents! * Changed the SImpl_LLVMArrayCopy and SImpl_LLVMArrayBorrow rules to generate the sub-array being borrowed, and to only take the borrows from the larger array that could overlap with the sub-array; Added cases to prove field permissions from arrays of smaller strides; added more debug information * whoops, llvmMakeSubArray was keeping the borrows the could be disjoint from the sub-array instead of those the could overlap with it * changed the way tagged union shapes are proved to always try to prove a tag first, thereby reducing the cases in which they bottom out into general disjunctions * re-imagined how solveForPermListImpl works, by having solveForPermListImplBlock delete all the BVRanges of perms on the left-hand size from the BVRange of the right-hande side, and then creating blocks with existentially-quantified shapes for those ranges * removed the checks that the block perm has the proper length in llvmBlockPermToField and llvmBlockPermToArray, because these do not take the current partial substitution into account * commented out proof in rust_data_proofs.v that no longer works * *almost* got a use of the write! macro to work in the rust_data exmample * wrapped an overly long line * whoops, removed duplicate functions that were accidentally added during the recent merge * wrapped an overly long line * changed widening to drop permissions on unreachable variables * oops, finished updating the examples to use the correct syntax * commented out some parts of the proofs for sum_inc_ptr in the arrays example that no longer work * wrapped some of the lines in rust_data.saw * whoops, updated the ArgumentV1 type incorrectly in the last commit --- heapster-saw/examples/arrays.saw | 10 +- heapster-saw/examples/arrays_proofs.v | 10 +- heapster-saw/examples/clearbufs.saw | 2 +- heapster-saw/examples/linked_list.saw | 2 +- heapster-saw/examples/mbox.saw | 32 +- heapster-saw/examples/memcpy.saw | 7 +- heapster-saw/examples/rust_data.saw | 82 +- heapster-saw/examples/rust_data_proofs.v | 4 +- .../Verifier/SAW/Heapster/IRTTranslation.hs | 24 +- .../src/Verifier/SAW/Heapster/Implication.hs | 2345 +++++++++-------- .../Verifier/SAW/Heapster/LLVMGlobalConst.hs | 11 +- .../src/Verifier/SAW/Heapster/Parser.y | 12 +- .../src/Verifier/SAW/Heapster/Permissions.hs | 1374 ++++++---- .../src/Verifier/SAW/Heapster/RustTypes.hs | 64 +- .../Verifier/SAW/Heapster/SAWTranslation.hs | 312 +-- .../src/Verifier/SAW/Heapster/TypeChecker.hs | 45 +- .../Verifier/SAW/Heapster/TypedCrucible.hs | 8 +- .../src/Verifier/SAW/Heapster/UntypedAST.hs | 6 +- .../src/Verifier/SAW/Heapster/Widening.hs | 48 +- .../generated/CryptolToCoq/SAWCorePrelude.v | 4 +- saw-core/prelude/Prelude.sawcore | 11 +- 21 files changed, 2396 insertions(+), 2017 deletions(-) diff --git a/heapster-saw/examples/arrays.saw b/heapster-saw/examples/arrays.saw index dff3d1c8df..468fbeb1a8 100644 --- a/heapster-saw/examples/arrays.saw +++ b/heapster-saw/examples/arrays.saw @@ -5,7 +5,7 @@ env <- heapster_init_env_from_file "arrays.sawcore" "arrays.bc"; heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; heapster_define_perm env "int8" " " "llvmptr 8" "exists x:bv 8.eq(llvmword(x))"; -heapster_define_perm env "int64array" "len:bv 64" "llvmptr 64" "array(0, int64<>])"; +heapster_define_perm env "int64array" "len:bv 64" "llvmptr 64" "array(W,0,))"; heapster_typecheck_fun env "contains0_rec_" @@ -42,13 +42,13 @@ heapster_typecheck_fun env "filter_and_sum_pos" \ arg0:int64array, arg1:true, ret:int64<>"; heapster_typecheck_fun env "sum_2d" - "(l1:bv 64,l2:bv 64). arg0:array(0, array(0, int64<>])]), \ + "(l1:bv 64,l2:bv 64). arg0:array(W,0,)))), \ \ arg1:eq(llvmword(l1)), arg2:eq(llvmword(l2)) -o \ - \ arg0:array(0, array(0, int64<>])]), \ + \ arg0:array(W,0,)))), \ \ arg1:true, arg2:true, ret:int64<>"; heapster_typecheck_fun env "sum_inc_ptr" - "(len:bv 64). arg0:array(0, int8<>]), arg1:eq(llvmword(len)) -o \ - \ arg0:array(0, int8<>]), arg1:true, ret:int64<>"; + "(len:bv 64). arg0:array(W,0,)), arg1:eq(llvmword(len)) -o \ + \ arg0:array(W,0,)), arg1:true, ret:int64<>"; heapster_export_coq env "arrays_gen.v"; diff --git a/heapster-saw/examples/arrays_proofs.v b/heapster-saw/examples/arrays_proofs.v index b1e5f1dd2e..32e80eaed0 100644 --- a/heapster-saw/examples/arrays_proofs.v +++ b/heapster-saw/examples/arrays_proofs.v @@ -150,11 +150,12 @@ Proof. unfold noErrorsSpec, sum_inc_ptr_invar. time "no_errors_sum_inc_ptr" prove_refinement. all: try assumption. + (* - assert (isBvult 64 a2 a1). + apply isBvule_to_isBvult_or_eq in e_assuming. destruct e_assuming; [assumption |]. apply bvEq_bvSub_r in H. - symmetry in H; contradiction. + (* symmetry in H; contradiction. *) admit. + rewrite H in e_maybe; discriminate e_maybe. - apply isBvult_to_isBvule_suc; assumption. - repeat rewrite bvSub_eq_bvAdd_neg. @@ -162,7 +163,9 @@ Proof. rewrite bvNeg_bvAdd_distrib; reflexivity. - apply isBvule_zero_n. - symmetry; apply bvSub_n_zero. -Qed. + *) +Admitted. +(* Qed. *) Definition sum_inc_ptr_spec len : BVVec 64 len (bitvector 8) -> bitvector 64 := @@ -186,6 +189,7 @@ Proof. 3: prove_refinement_eauto; [| apply refinesM_returnM ]. 7: prove_refinement_eauto; [| apply refinesM_returnM ]. (* same as no_errors_sum_inc_ptr *) + (* - assert (isBvult 64 a2 a1). + apply isBvule_to_isBvult_or_eq in e_forall. destruct e_forall; [assumption |]. @@ -206,5 +210,5 @@ Proof. (* unique to this proof *) - rewrite bvAdd_id_l. repeat f_equal. - admit. + admit. *) Admitted. diff --git a/heapster-saw/examples/clearbufs.saw b/heapster-saw/examples/clearbufs.saw index 42ac69eeb0..359e5bf964 100644 --- a/heapster-saw/examples/clearbufs.saw +++ b/heapster-saw/examples/clearbufs.saw @@ -8,7 +8,7 @@ heapster_define_reachability_perm env "Bufs" "x:llvmptr 64" "llvmptr 64" "exists len:(bv 64).ptr((W,0) |-> Bufs) * \ \ ptr((W,8) |-> eq(llvmword(len))) * \ - \ array(16, int64<>])" + \ array(W, 16, ))" "Mbox_def" "foldMbox" "unfoldMbox" "transMbox"; heapster_block_entry_hint env "clearbufs" 3 diff --git a/heapster-saw/examples/linked_list.saw b/heapster-saw/examples/linked_list.saw index 3ab875f062..23e0db8484 100644 --- a/heapster-saw/examples/linked_list.saw +++ b/heapster-saw/examples/linked_list.saw @@ -17,7 +17,7 @@ heapster_typecheck_fun env "is_elem" heapster_assume_fun env "malloc" "(sz:bv 64). arg0:eq(llvmword(8*sz)) -o \ - \ arg0:true, ret:array(0, true])" + \ arg0:true, ret:array(W,0, int64<>])"; +heapster_define_perm env "state_t" " " "llvmptr 64" "array(W, 0, <16, *1, fieldsh(int64<>))"; heapster_define_perm env "aes_sw_ctx" "rw1:rwmodality, rw2:rwmodality" "llvmptr 64" - "array(0, <240, *1, [(rw1,0) |-> int64<>]) * ptr((rw2, 1920) |-> int64<>)"; + "array(rw1, 0, <240, *1, fieldsh (int64<>)) * ptr((rw2, 1920) |-> int64<>)"; heapster_define_reachability_perm env "mbox" "rw:rwmodality, x:llvmptr 64" "llvmptr 64" "ptr((rw,0) |-> int64<>) * ptr((rw,8) |-> int64<>) * ptr((rw,16) |-> mbox) * \ - \ array(24, <128, *1, [(rw,0,8) |-> int8<>])" + \ array(W, 24, <128, *1, fieldsh(8,int8<>))" "Mbox_def" "foldMbox" "unfoldMbox" "transMbox"; // heapster_define_perm env "mbox_nonnull" @@ -44,7 +44,7 @@ heapster_define_reachability_perm env "mbox" heapster_define_perm env "byte_array" "rw:rwmodality, len:bv 64" "llvmptr 64" - "array(0, int8<>])"; + "array(W, 0, ))"; heapster_define_perm env "boolean" " " "llvmptr 1" "exists x:bv 1.eq(llvmword(x))"; @@ -98,7 +98,7 @@ heapster_assume_fun env "mbox_new" heapster_assume_fun env "mbox_free" "(). arg0:ptr((W,0) |-> true) * ptr((W,8) |-> true) * ptr((W,16) |-> true) * \ - \ array(24, <128, *1, [(W,0,8) |-> int8<>]) -o \ + \ array(W, 24, <128, *1, fieldsh(8,int8<>)) -o \ \ arg0:true, ret:int32<>" "mboxFreeSpec"; @@ -132,25 +132,25 @@ heapster_typecheck_fun env "mbox_eq" heapster_block_entry_hint env "mbox_from_buffer" 24 "top1:bv 64, top2:llvmptr 64, top3:llvmptr 64" "frm:llvmframe 64, ghost0:llvmptr 64, ghost1:bv 64" - "top1:true, top2:array(0, int8<>]), \ + "top1:true, top2:array(W, 0, )), \ \ top3:eq(llvmword(top1)), arg0:ptr((W,0) |-> true), \ \ arg1:ptr((W,0) |-> eq(top2)), arg2:ptr((W,0) |-> eq(llvmword(top1))), \ \ arg3:ptr((W,0) |-> mbox), arg4:ptr((W,0) |-> eq(ghost0)), \ \ arg5:ptr((W,0) |-> eq(llvmword(ghost1))), arg6:ptr((W,0) |-> true), \ \ frm:llvmframe [arg6:8, arg5:8, arg4:8, arg3:8, arg2:8, arg1:8, arg0:8], \ \ ghost0:ptr((W,0) |-> int64<>) * ptr((W,8) |-> int64<>) * \ - \ ptr((W,16) |-> mbox) * array(24, <128, *1, [(W,0,8) |-> int8<>]), \ + \ ptr((W,16) |-> mbox) * array(W, 24, <128, *1, fieldsh(8, int8<>)), \ \ ghost1:true"; heapster_typecheck_fun env "mbox_from_buffer" - "(len:bv 64). arg0:array(0, int8<>]), arg1:eq(llvmword(len)) -o \ - \ arg0:array(0, int8<>]), arg1:true, ret:mbox"; + "(len:bv 64). arg0:array(W, 0,)), arg1:eq(llvmword(len)) -o \ + \ arg0:array(W, 0,)), arg1:true, ret:mbox"; heapster_block_entry_hint env "mbox_to_buffer" 32 "top1:bv 64, top2:llvmptr 64, top3:llvmptr 64, top4:llvmptr 64, top5:llvmptr 64" "frm:llvmframe 64, ghost0:llvmptr 64" - "top1:true, top2:array(0, int8<>]), \ + "top1:true, top2:array(W, 0, )), \ \ top3:eq(llvmword(top1)), top4:mbox, \ \ top5:int64<>, arg0:ptr((W,0) |-> true), \ \ arg1:ptr((W,0) |-> eq(top2)), arg2:ptr((W,0) |-> eq(top3)), \ @@ -160,16 +160,16 @@ heapster_block_entry_hint env "mbox_to_buffer" 32 \ ghost0:mbox"; heapster_typecheck_fun env "mbox_to_buffer" - "(len:bv 64). arg0:array(0, int8<>]), \ + "(len:bv 64). arg0:array(W, 0,)), \ \ arg1:eq(llvmword(len)), arg2:mbox, arg3:int64<> -o \ - \ arg0:array(0, int8<>]), \ + \ arg0:array(W, 0,)), \ \ arg1:true, arg2:mbox, arg3:true, ret:int64<>"; heapster_typecheck_fun env "mbox_to_buffer_rec" - "(len:bv 64). arg0:array(0, int8<>]), \ + "(len:bv 64). arg0:array(W, 0,)), \ \ arg1:eq(llvmword(len)), arg2:mbox -o \ - \ arg0:array(0, int8<>]), \ + \ arg0:array(W, 0,)), \ \ arg1:true, arg2:mbox, ret:true"; // heapster_typecheck_fun env "mbox_to_buffer_rec" @@ -203,7 +203,7 @@ heapster_block_entry_hint env "mbox_concat_chains" 16 \ arg0:ptr((W,0) |-> eq(x0)), arg1:ptr((W,0) |-> eq(top2)), \ \ frm:llvmframe [arg1:8, arg0:8], \ \ x0:ptr((W,0) |-> int64<>) * ptr((W,8) |-> int64<>) * \ - \ ptr((W,16) |-> mbox) * array(24, <128, *1, [(W,0,8) |-> int8<>])"; + \ ptr((W,16) |-> mbox) * array(W, 24, <128, *1, fieldsh(8, int8<>))"; heapster_typecheck_fun env "mbox_concat_chains" "(). arg0:mbox, arg1:mbox -o \ @@ -260,7 +260,7 @@ heapster_block_entry_hint env "mbox_randomize" 16 "top1:llvmptr 64" "frm:llvmframe 64" "top1:ptr((W,0) |-> int64<>) * ptr((W,8) |-> int64<>) * \ - \ ptr((W,16) |-> mbox) * array(24, <128, *1, [(W,0,8) |-> int8<>]), \ + \ ptr((W,16) |-> mbox) * array(W, 24, <128, *1, fieldsh(8, int8<>)), \ \ arg0:ptr((W,0,32) |-> true), arg1:ptr((W,0) |-> eq(top1)), arg2:ptr((W,0) |-> int64<>), \ \ frm:llvmframe [arg2:8, arg1:8, arg0:4]"; diff --git a/heapster-saw/examples/memcpy.saw b/heapster-saw/examples/memcpy.saw index 1d0cc90fe7..f2b9a22f62 100644 --- a/heapster-saw/examples/memcpy.saw +++ b/heapster-saw/examples/memcpy.saw @@ -5,11 +5,14 @@ env <- heapster_init_env_from_file "memcpy.sawcore" "memcpy.bc"; heapster_define_perm env "int64" " " "llvmptr 64" "exists x:bv 64.eq(llvmword(x))"; heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" - "(rw:rwmodality, l1:lifetime, l2:lifetime, sh:llvmshape 64, b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(b)), arg2:eq(llvmword(len)) -o \ + "(rw:rwmodality, l1:lifetime, l2:lifetime, sh:llvmshape 64, \ + \ b:llvmblock 64, len:bv 64). \ + \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(b)), \ + \ arg2:eq(llvmword(len)) -o \ \ arg0:[l1]memblock(W,0,len,eqsh(b)), arg1:[l2]memblock(rw,0,len,eqsh(b))" "\\ (X:sort 0) (len:Vec 64 Bool) (x:X) (_:#()) -> returnM (#() * #()) ((),())"; + heapster_typecheck_fun env "copy_int" "().arg0:int64<> -o ret:int64<>"; diff --git a/heapster-saw/examples/rust_data.saw b/heapster-saw/examples/rust_data.saw index 90bdaa185d..02f249c3ea 100644 --- a/heapster-saw/examples/rust_data.saw +++ b/heapster-saw/examples/rust_data.saw @@ -38,12 +38,12 @@ heapster_define_rust_type env "pub enum Option { None, Some (X) }"; // we don't yet have implications on array cells //heapster_define_llvmshape env "str" 64 "" "exsh len:bv 64.arraysh(len,1,[(8,int8<>)])"; heapster_define_llvmshape env "str" 64 "" - "exsh len:bv 64.arraysh(len,1,[(8,exists x:bv 8.eq(llvmword(x)))])"; + "exsh len:bv 64.arraysh())"; //heapster_define_rust_type env "type str = [u8];"; // The String type heapster_define_llvmshape env "String" 64 "" - "exsh cap:bv 64. ptrsh(arraysh(cap,1,[(8,int8<>)])); \ + "exsh cap:bv 64. ptrsh(arraysh())); \ \ fieldsh(int64<>);fieldsh(eq(llvmword(cap)))"; // List type @@ -76,8 +76,12 @@ heapster_define_rust_type env "pub struct ThreeValues(u32,u32,u32);"; heapster_define_rust_type env "pub struct FourValues(u32,u32,u32,u32);"; heapster_define_rust_type env "pub struct FiveValues(u32,u32,u32,u32,u32);"; +// The StrStruct type +heapster_define_rust_type env "pub struct StrStruct(String);"; + // MixedStruct type -// heapster_define_llvmshape env "MixedStruct" 64 "" "String<>;fieldsh(64,int64<>);fieldsh(64,int64<>)"; +// heapster_define_llvmshape env "MixedStruct" 64 "" +// "String<>;fieldsh(64,int64<>);fieldsh(64,int64<>)"; heapster_define_rust_type env "pub struct MixedStruct { pub s: String, pub i1: u64, pub i2: u64, }"; @@ -145,7 +149,8 @@ heapster_define_rust_type env heapster_define_rust_type_qual env "fmt" "pub struct Error { }"; // fmt::Result type -// FIXME: there seems to be some optimization in Rust that lays out fmt::Result as a 1-bit value +// FIXME: there seems to be some optimization in Rust that lays out fmt::Result +// as a 1-bit value heapster_define_llvmshape env "fmt::Result" 64 "" "fieldsh(1,eq(llvmword(0))) orsh fieldsh(1,eq(llvmword(1)))"; //heapster_define_rust_type_qual env "fmt" @@ -179,9 +184,14 @@ heapster_define_rust_type_qual env "fmt" // fmt::ArgumentV1 type heapster_define_rust_type_qual env "fmt" - "pub struct ArgumentV1<'a> { \ - \ value: &'a Void, \ - \ formatter: for <'b> fn(&'b Void, &'b mut fmt::Formatter) -> fmt::Result, }"; + "pub struct ArgumentV1 { value: Box, formatter: Box }"; + +// FIXME: this is the correct type, but Heapster cannot yet handle lifetime +// arguments for types +// heapster_define_rust_type_qual env "fmt" +// "pub struct ArgumentV1<'a> { \ +// \ value: &'a Void, \ +// \ formatter: for <'b> fn(&'b Void, &'b mut fmt::Formatter) -> fmt::Result, }"; // fmt::Arguments type //heapster_define_rust_type_qual env "fmt" @@ -190,6 +200,12 @@ heapster_define_rust_type_qual env "fmt" // \ args: &'a [fmt::ArgumentV1<'a>], }"; +heapster_define_rust_type_qual env "fmt" + "pub struct Arguments { pieces: Box, pieces_len:u64, \ + \ fmt: Box, fmt_len: u64, args: Box, \ + \ arg_len:u64, }"; + + /*** *** Assumed Functions ***/ @@ -207,13 +223,16 @@ heapster_assume_fun_rename env exchange_malloc_sym "exchange_malloc" // memcpy heapster_assume_fun env "llvm.memcpy.p0i8.p0i8.i64" - "(rw:rwmodality, l1:lifetime, l2:lifetime, sh:llvmshape 64, b:llvmblock 64, len:bv 64). \ - \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(b)), arg2:eq(llvmword(len)) -o \ + "(rw:rwmodality, l1:lifetime, l2:lifetime, sh:llvmshape 64, \ + \ b:llvmblock 64, len:bv 64). \ + \ arg0:[l1]memblock(W,0,len,sh), arg1:[l2]memblock(rw,0,len,eqsh(b)), \ + \ arg2:eq(llvmword(len)) -o \ \ arg0:[l1]memblock(W,0,len,eqsh(b)), arg1:[l2]memblock(rw,0,len,eqsh(b))" "\\ (X:sort 0) (len:Vec 64 Bool) (x:X) (_:#()) -> returnM (#() * #()) ((),())"; // ::to_string -to_string_str <- heapster_find_symbol env "$LT$str$u20$as$u20$alloc..string..ToString$GT$9to_string"; +to_string_str <- heapster_find_symbol env + "$LT$str$u20$as$u20$alloc..string..ToString$GT$9to_string"; // NOTE: this is the more incorrect version, with no lifetime argument and no shapes //heapster_assume_fun_rename env to_string_str "to_string_str" // "(len:bv 64). arg0:memblock(W,0,24,emptysh), @@ -230,7 +249,7 @@ to_string_str <- heapster_find_symbol env "$LT$str$u20$as$u20$alloc..string..ToS // NOTE: this is the incorrect version, with no lifetime argument heapster_assume_fun_rename env to_string_str "to_string_str" "(len:bv 64). arg0:memblock(W,0,24,emptysh), \ - \ arg1:array(0, int8<>]), \ + \ arg1:array(R,0,)), \ \ arg2:eq(llvmword(len)) -o \ \ arg0:memblock(W,0,24,String<>)" "\\ (len:Vec 64 Bool) (_:#()) (str:BVVec 64 len (Vec 8 Bool)) -> \ @@ -286,10 +305,28 @@ heapster_assume_fun_rename_prim env String__fmt_sym "String__fmt" */ +// ArgumentV1::new +//ArgumentV1_new <- heapster_find_symbol env "10ArgumentV13new"; +//heapster_assume_fun_rename_prim env ArgumentV1_new "ArgumentV1_new" +// "<'a,'b,T> fn (x: &'b T, f: fn(&T, &mut fmt::Formatter) -> fmt::Result) \ +// \ -> fmt::ArgumentV1<'b>"; +//ArgumentV1_new_String <- heapster_find_symbol env +// "_ZN4core3fmt10ArgumentV13new17hdf7e5958686d74c0E"; +//heapster_assume_fun_rename_prim env ArgumentV1_new_String "ArgumentV1_new_String" +// "<'a,'b> fn (x: &'b String, \ +// \ f: for<'c,'d> fn (&'c String, &'d mut fmt::Formatter) -> fmt::Result) \ +// \ -> fmt::ArgumentV1<'b>"; +//heapster_assume_fun_rename_prim env ArgumentV1_new_String "ArgumentV1_new_String" +// "<'a,'b> fn (x: &'b String, f: Box) -> fmt::ArgumentV1<'b>"; +//heapster_assume_fun_rename_prim env ArgumentV1_new_String "ArgumentV1_new_String" +// "<'a,'b> fn (x: &'b String, f: Box) -> fmt::ArgumentV1"; + // Arguments::new_v1 Arguments__new_v1_sym <- heapster_find_symbol env "3fmt9Arguments6new_v1"; //heapster_assume_fun_rename_prim env Arguments__new_v1_sym "Arguments__new" -// "<'a> fn (pieces: &'a [&'a str], args: &'a [ArgumentV1<'a>]) -> Arguments<'a>"; +// "<'a> fn (pieces: &'a [&'a str], args: &'a [fmt::ArgumentV1<'a>]) -> fmt::Arguments<'a>"; +heapster_assume_fun_rename_prim env Arguments__new_v1_sym "Arguments__new" + "<'a> fn (pieces: &'a [&'a str], args: &'a [fmt::ArgumentV1]) -> fmt::Arguments"; // Formatter::write_str Formatter__write_str_sym <- heapster_find_symbol env "9Formatter9write_str"; @@ -340,12 +377,20 @@ mixed_struct_get_i2 <- heapster_find_symbol env "11MixedStruct6get_i2"; heapster_typecheck_fun_rename env mixed_struct_get_i2 "MixedStruct_get_i2" "<'a> fn (m:&'a MixedStruct) -> u64"; +// MixedStruct::fmt +mixed_struct_fmt <- heapster_find_trait_method_symbol env + "core::fmt::Display::fmt"; +heapster_typecheck_fun_rename env mixed_struct_fmt "MixedStruct_fmt" + "<'a, 'b> fn(&'a MixedStruct, f: &'b mut fmt::Formatter) -> fmt::Result"; + cycle_true_enum_sym <- heapster_find_symbol env "15cycle_true_enum"; -// NOTE: This typecheck requires full(er) support for disjunctive shapes, which Heapster currently lacks +// NOTE: This typecheck requires full(er) support for disjunctive shapes, which +// Heapster currently lacks // heapster_typecheck_fun_rename env cycle_true_enum_sym "cycle_true_enum" // "<'a> fn (te:&'a TrueEnum) -> TrueEnum"; -TrueEnum__fmt_sym <- heapster_find_trait_method_symbol env "core::fmt::Display::fmt"; +TrueEnum__fmt_sym <- heapster_find_trait_method_symbol env + "core::fmt::Display::fmt"; heapster_typecheck_fun_rename env TrueEnum__fmt_sym "TrueEnum__fmt" "<'a, 'b> fn (&'a TrueEnum, f: &'b mut fmt::Formatter) -> fmt::Result"; @@ -390,11 +435,12 @@ str_struct_new <- heapster_find_symbol env "9StrStruct3new"; // \\ ptr((W,8) |-> int64<>) * ptr((W,16) |-> eq(llvmword(len')))"; // FIXME: this is the correct version, with the String shape +//heapster_typecheck_fun_rename env str_struct_new "str_struct_new" +// "(len:bv 64).arg0:memblock(W,0,24,emptysh), \ +// \ arg1:array(0, int8<>]), \ +// \ arg2:eq(llvmword(len)) -o arg0:memblock(W,0,24,String<>)"; heapster_typecheck_fun_rename env str_struct_new "str_struct_new" - "(len:bv 64). arg0:memblock(W,0,24,emptysh), \ - \ arg1:array(0, int8<>]), \ - \ arg2:eq(llvmword(len)) -o \ - \ arg0:memblock(W,0,24,String<>)"; + "<'a> fn (name:&'a str) -> StrStruct<>"; bintree_is_leaf_sym <- heapster_find_symbol env "15bintree_is_leaf"; heapster_typecheck_fun_rename env bintree_is_leaf_sym "bintree_is_leaf" diff --git a/heapster-saw/examples/rust_data_proofs.v b/heapster-saw/examples/rust_data_proofs.v index 0c0716db4e..2e03ac14d3 100644 --- a/heapster-saw/examples/rust_data_proofs.v +++ b/heapster-saw/examples/rust_data_proofs.v @@ -27,7 +27,8 @@ Import SAWCorePrelude. (* Print str_struct_new__tuple_fun. *) -Lemma no_errors_str_struct_new : refinesFun str_struct_new (fun _ _ _ => noErrorsSpec). +(* FIXME: need to handle mapBVVecM for this one to work! +Lemma no_errors_str_struct_new : refinesFun str_struct_new (fun _ _ _ _ => noErrorsSpec). Proof. unfold str_struct_new, str_struct_new__tuple_fun, noErrorsSpec, llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64, to_string_str. prove_refinement. @@ -44,3 +45,4 @@ Proof. unfold str_struct_new, str_struct_new__tuple_fun, noErrorsSpec, llvm__x2ememcpy__x2ep0i8__x2ep0i8__x2ei64, to_string_str. prove_refinement. Qed. +*) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs index 9602a78805..f7b9e6a236 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/IRTTranslation.hs @@ -102,7 +102,7 @@ instance ContainsIRTRecName (PermExpr a) where containsIRTRecName n args containsIRTRecName n (PExpr_PtrShape _ _ sh) = containsIRTRecName n sh containsIRTRecName n (PExpr_FieldShape fsh) = containsIRTRecName n fsh - containsIRTRecName n (PExpr_ArrayShape _ _ fshs) = containsIRTRecName n fshs + containsIRTRecName n (PExpr_ArrayShape _ _ sh) = containsIRTRecName n sh containsIRTRecName n (PExpr_SeqShape sh1 sh2) = containsIRTRecName n sh1 || containsIRTRecName n sh2 containsIRTRecName n (PExpr_OrShape sh1 sh2) = @@ -141,7 +141,7 @@ instance ContainsIRTRecName (RAssign ValuePerm tps) where instance ContainsIRTRecName (AtomicPerm a) where containsIRTRecName n (Perm_LLVMField fp) = containsIRTRecName n fp containsIRTRecName n (Perm_LLVMArray arrp) = - containsIRTRecName n (llvmArrayFields arrp) + containsIRTRecName n (llvmArrayCellShape arrp) containsIRTRecName n (Perm_LLVMBlock bp) = containsIRTRecName n (llvmBlockShape bp) containsIRTRecName _ (Perm_LLVMFree _) = False @@ -160,9 +160,6 @@ instance ContainsIRTRecName (AtomicPerm a) where containsIRTRecName _ (Perm_Fun _) = False containsIRTRecName _ (Perm_BVProp _) = False -instance ContainsIRTRecName (LLVMArrayField w) where - containsIRTRecName n (LLVMArrayField fp) = containsIRTRecName n fp - instance ContainsIRTRecName (LLVMFieldPerm w sz) where containsIRTRecName n fp = containsIRTRecName n $ llvmFieldContents fp @@ -401,8 +398,7 @@ instance IRTTyVars (AtomicPerm a) where [nuMP| Perm_LLVMField fld |] -> irtTyVars (fmap llvmFieldContents fld) [nuMP| Perm_LLVMArray mb_ap |] -> - irtTyVars $ fmap (fmap llvmArrayFieldToAtomicPerm . llvmArrayFields) - mb_ap + irtTyVars $ mbLLVMArrayCellShape mb_ap [nuMP| Perm_LLVMBlock bp |] -> irtTyVars (fmap llvmBlockShape bp) [nuMP| Perm_LLVMFree _ |] -> return ([], IRTVarsNil) @@ -461,7 +457,7 @@ instance IRTTyVars (PermExpr (LLVMShapeType w)) where [nuMP| PExpr_EqShape _ |] -> return ([], IRTVarsNil) [nuMP| PExpr_PtrShape _ _ sh |] -> irtTyVars sh [nuMP| PExpr_FieldShape fsh |] -> irtTyVars fsh - [nuMP| PExpr_ArrayShape _ _ fshs |] -> irtTyVars fshs + [nuMP| PExpr_ArrayShape _ _ sh |] -> irtTyVars sh [nuMP| PExpr_SeqShape sh1 sh2 |] -> do (tps1, ixs1) <- irtTyVars sh1 (tps2, ixs2) <- irtTyVars sh2 @@ -648,10 +644,8 @@ instance IRTDescs (AtomicPerm a) where do let w = natVal2 mb_ap w_term = natOpenTerm w len_term <- translate1 (fmap llvmArrayLen mb_ap) - let mb_flds = fmap (fmap llvmArrayFieldToAtomicPerm . llvmArrayFields) - mb_ap - xs_term <- irtDesc mb_flds ixs - irtCtor "Prelude.IRT_BVVec" [w_term, len_term, xs_term] + sh_desc_term <- irtDesc (mbLLVMArrayCellShape mb_ap) ixs + irtCtor "Prelude.IRT_BVVec" [w_term, len_term, sh_desc_term] ([nuMP| Perm_LLVMBlock bp |], _) -> irtDescs (fmap llvmBlockShape bp) ixs ([nuMP| Perm_LLVMFree _ |], _) -> return [] @@ -692,12 +686,12 @@ instance IRTDescs (PermExpr (LLVMShapeType w)) where irtDescs sh ixs ([nuMP| PExpr_FieldShape fsh |], _) -> irtDescs fsh ixs - ([nuMP| PExpr_ArrayShape mb_len _ mb_fshs |], _) -> + ([nuMP| PExpr_ArrayShape mb_len _ mb_sh |], _) -> do let w = natVal4 mb_len w_term = natOpenTerm w len_term <- translate1 mb_len - xs_term <- irtDesc mb_fshs ixs - irtCtor "Prelude.IRT_BVVec" [w_term, len_term, xs_term] + sh_desc_term <- irtDesc mb_sh ixs + irtCtor "Prelude.IRT_BVVec" [w_term, len_term, sh_desc_term] ([nuMP| PExpr_SeqShape sh1 sh2 |], IRTVarsAppend ixs1 ixs2) -> do x1 <- irtDesc sh1 ixs1 x2 <- irtDesc sh2 ixs2 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs index 63e0f255e2..ef9f706166 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Implication.hs @@ -66,6 +66,18 @@ import Verifier.SAW.Heapster.GenMonad import GHC.Stack +-- * Helper functions (should be moved to Hobbits) + +-- | Append two existentially quantified 'RAssign' lists +apSomeRAssign :: Some (RAssign f) -> Some (RAssign f) -> Some (RAssign f) +apSomeRAssign (Some x) (Some y) = Some (RL.append x y) + +-- | Concatenate a list of existentially quantified 'RAssign' lists +concatSomeRAssign :: [Some (RAssign f)] -> Some (RAssign f) +concatSomeRAssign = foldl apSomeRAssign (Some MNil) +-- foldl is intentional, appending RAssign matches on the second argument + + ---------------------------------------------------------------------- -- * Equality Proofs ---------------------------------------------------------------------- @@ -597,44 +609,56 @@ data SimplImpl ps_in ps_out where ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - -- | Copy an array permission out of a larger array permission, assuming that - -- all fields of the array are copyable, using a proof that the copied array - -- permission is contained in the larger one as per 'llvmArrayContainsArray', - -- i.e., that the range of the smaller array is contained in the larger one - -- and that all borrows in the larger one are either preserved in the smaller - -- or are disjoint from it: + -- | Demote an LLVM array permission to read modality: -- - -- > x:ar1=array(off1, x:[l]array(rw,off, -o x:[l]array(R,off, + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) + + -- | Copy a portion of an array permission with a given offset and length, as + -- computed by 'llvmMakeSubArray', assuming that the array is copyable. This + -- requires a proof that the copied sub-array permission is contained in the + -- larger one as per 'llvmArrayContainsArray', i.e., that the range of the + -- smaller array is contained in the larger one and that all borrows in the + -- larger one are either preserved in the smaller or are disjoint from it: + -- + -- > x:ar1=array(off1, * x:prop('llvmArrayContainsArray' ar1 ar2) - -- > -o x:ar2=array(off2, * x:ar1=array(off1, -o x:ar2=[l]array(rw,off2, * x:ar1=[l]array(rw,off1, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) (RNil :> LLVMPointerType w :> LLVMPointerType w) - -- | Borrow an array permission from a larger array permission, using a proof - -- that the borrowed array permission is contained in the larger one as per + -- | Borrow a portion of an arra permission with a given offset and length, as + -- computed by 'llvmMakeSubArray'. This requires a proof that the borrowed + -- array permission is contained in the larger one as per -- 'llvmArrayContainsArray', i.e., that the range of the smaller array is -- contained in the larger one and that all borrows in the larger one are -- either preserved in the smaller or are disjoint from it: -- - -- > x:ar1=array(off1, x:ar1=[l]array(rw,off1, * x:prop('llvmArrayContainsArray' ar1 ar2) - -- > -o x:ar2=array(off2, * x:array(off1, -o x:ar2=[l]array(rw,off2, * x:[l]array(rw,off1, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) (RNil :> LLVMPointerType w :> LLVMPointerType w) -- | Return a borrowed range of an array permission, undoing a borrow: -- - -- > x:array(off2, * x:array(off1, -o x:array(off, x:[l]array(rw,off2, * x:[l]array(rw,off1, -o x:[l]array(rw,off, ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> @@ -644,9 +668,9 @@ data SimplImpl ps_in ps_out where -- | Append two array permissions, assuming one ends where the other begins -- and that they have the same stride and fields: -- - -- > x:array(off1, * x:array(off2=off1+len*stride*word_size, -o x:array(off1, x:[l]array(rw, off1, * x:[l]array(rw,off2=off1+len*stride*word_size, -o x:[l]array(rw,off1, ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> @@ -655,95 +679,89 @@ data SimplImpl ps_in ps_out where -- | Rearrange the order of the borrows in an array permission: -- - -- > x:array(off, -o x:array(off, x:[l]array(rw,off, -o x:[l]array(rw,off, ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> [LLVMArrayBorrow w] -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - -- | Convert an array to a field of the same size with @true@ contents: - -- - -- > x:array(off,<(sz/stride/8),*stride,fps,[]) -o x:[l]ptr((rw,off) |-> true) - -- - -- where all @fps@ must have the same @rw@ and @l@ - SImpl_LLVMArrayToField :: - (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> NatRepr sz -> - SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - -- | Prove an empty array with length 0: -- - -- > -o x:array(off,<0,*stride,fps,[]) + -- > -o x:[l]array(rw,off,<0,*stride,sh,bs) SImpl_LLVMArrayEmpty :: (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> SimplImpl RNil (RNil :> LLVMPointerType w) - -- | Prove an array of static length from from field permissions for a single - -- cell, leaving borrows for all the other cells: + -- | Convert an array of byte-sized cells to a field of the same size with + -- @true@ contents: -- - -- > x:fps+(cell*w*stride) - -- > -o x:array(off, x:array[l](rw,off,<(sz/8),*stride,sh) -o x:[l]ptr((sz,rw,off) |-> true) + SImpl_LLVMArrayToField :: + (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> NatRepr sz -> + SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) + + -- | Prove an array of length 1 from a block of its same shape: + -- + -- > x:[l]memblock(rw,off,stride,sh) -o x:[l]array(rw,off,<1,*stride,sh,[]) + SImpl_LLVMArrayFromBlock :: (1 <= w, KnownNat w) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - -- | Copy out the @j@th field permission of the @i@th element of an array - -- permission, assuming that the @j@th field permission is copyable, where @j@ - -- is a static 'Int' and @i@ is an expression. Requires a proposition - -- permission on the top of the stack stating that @i@ is in the range of the - -- array and that the specified field permission does not overlap with any of - -- the existing borrows: + -- | Copy out the @i@th cell of an array permission, assuming it is + -- copyable. Requires a proposition permission on the top of the stack stating + -- that @i@ is in the range of the array and that it does not overlap with any + -- of the existing borrows: -- - -- > x:array(off, * x:(prop(i \in [off,len)) * disjoint(bs,i*stride+offset(fp_j))) - -- > -o x:(fp_j + off + i*stride) * x:array(off, x:[l]array(R,off, * x:(prop(i \in [off,len)) * disjoint(bs,i*stride)) + -- > -o x:[l]memblock(R,off + i*stride,stride,sh) + -- > * x:array(off, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayIndex w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) (RNil :> LLVMPointerType w :> LLVMPointerType w) - -- | Borrow the @j@th field permission of the @i@th element of an array - -- permission, where @j@ is a static 'Int' and @i@ is an expression. Requires - -- a proposition permission on the top of the stack stating that @i@ is in the - -- range of the array and that the specified field permission does not overlap - -- with any of the existing borrows, and adds a borrow of the given field: + -- | Borrow the @i@th cell an array permission. Requires a proposition + -- permission on the top of the stack stating that @i@ is in the range of the + -- array and that it does not overlap with any of the existing borrows, and + -- adds a borrow of the given field: -- - -- > x:array(off, * x:(prop(i \in [off,len)) * disjoint(bs,i*stride+offset(fp_j))) - -- > -o x:(fp_j + off + i*stride) - -- > * x:array(off, x:[l]array(rw,off, * x:(prop(i \in [off,len)) * disjoint(bs,i*stride)) + -- > -o x:[l]memblock(rw,off + i*stride,stride,sh) + -- > * x:[l]array(rw,off, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayIndex w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) (RNil :> LLVMPointerType w :> LLVMPointerType w) - -- | Return the @j@th field permission of the @i@th element of an array - -- permission, where @j@ is a static 'Int' and @i@ is an expression, undoing a - -- borrow: + -- | Return the @i@th cell of an array permission, undoing a borrow: -- - -- > x:(fp_j + offset + i*stride) - -- > * x:array(off, -o x:array(off, x:[l]memblock(rw,off + i*stride,stride,sh) + -- > * x:[l]array(rw,off, -o x:[l]array(rw,off, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayIndex w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> SimplImpl (RNil :> LLVMPointerType w :> LLVMPointerType w) (RNil :> LLVMPointerType w) - -- | Apply an implication to the fields of an array permission: + -- | Apply an implication to the cell shape of an array permission: -- - -- > y:fp1 * ... * fpn -o y:fp1' * ... * fpn' - -- > ------------------------------------------------ - -- > x:array(off, x:array(off, y:[l]memblock(rw,0,stride,sh1) -o y:[l]memblock(rw,0,stride,sh2) + -- > ---------------------------------------------------------------- + -- > x:array(off, x:array(off, - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> [LLVMArrayField w] -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + PermExpr (LLVMShapeType w) -> Binding (LLVMPointerType w) (LocalPermImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w)) -> @@ -900,7 +918,7 @@ data SimplImpl ps_in ps_out where -- | Eliminate any @memblock@ permission to an array of bytes: -- -- > x:memblock(rw,l,off,len,emptysh) - -- > -o x:array(off, true]) + -- > -o x:[l]array(rw,off, ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) @@ -959,43 +977,37 @@ data SimplImpl ps_in ps_out where SimplImpl (RNil :> LLVMPointerType w :> LLVMBlockType w) (RNil :> LLVMPointerType w) - -- | Prove an llvmblock permission of pointer shape from a pointer: + -- | Prove an llvmblock permission of pointer shape from one of field shape + -- containing a pointer permission: -- - -- > x:[l]ptr((rw,off,w) |-> [l2]memblock(rw2,off,'llvmShapeLength'(sh),sh)) + -- > x:[l]memblock(rw,off,w/8,fieldsh([l2]memblock(rw2,0,sh_len,sh))) -- > -o x:[l]memblock(rw,off,w/8,[l2]ptrsh(rw2,sh)) SImpl_IntroLLVMBlockPtr :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - Maybe (PermExpr RWModalityType) -> Maybe (PermExpr LifetimeType) -> - LLVMBlockPerm w -> + (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) -- | Eliminate an llvmblock permission of pointer shape: -- -- > x:[l]memblock(rw,off,w/8,[l2]ptrsh(rw2,sh)) - -- > -o x:[l]ptr((rw,off,w) |-> - -- > [l2]memblock(rw2,off,'llvmShapeLength'(sh),sh)) + -- > -o x:[l]memblock(rw,off,w/8,fieldsh([l2]memblock(rw2,0,sh_len,sh))) SImpl_ElimLLVMBlockPtr :: - (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> - Maybe (PermExpr RWModalityType) -> Maybe (PermExpr LifetimeType) -> - LLVMBlockPerm w -> + (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) -- | Prove a block of field shape from the corresponding field permission: -- - -- > x:[l]ptr((rw,off,sz) |-> p) -o x:memblock(rw,l,off,len+sz,ptrsh(sz,p)) + -- > x:[l]ptr((rw,off,sz) |-> p) -o x:memblock(rw,l,off,len+sz,fieldsh(sz,p)) SImpl_IntroLLVMBlockField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) -- | Eliminate a block of field shape to the corresponding field permission - -- plus an empty memblock for the remaining @len@, which is the extra arg: -- - -- > x:[l]memblock(rw,off,len,fieldsh(sz,p)) - -- > -o x:[l]ptr((rw,off,sz) |-> p) * [l]memblock(rw,off+sz,len-sz,emptysh) + -- > x:[l]memblock(rw,off,sz/8,fieldsh(sz,p)) -o x:[l]ptr((rw,off,sz) |-> p) SImpl_ElimLLVMBlockField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> PermExpr (BVType w) -> + ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) -- | Prove a block of array shape from the corresponding array permission: @@ -1005,11 +1017,13 @@ data SimplImpl ps_in ps_out where (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) - -- | Eliminate a block of array shape to the corresponding array permission: + -- | Eliminate a block of array shape to the corresponding array permission, + -- assuming that the length of the block equals that of the array: -- - -- > x:memblock(...) -o x:array(...) + -- > x:[l]memblock(rw,off,stride*len,arraysh( -o x:[l]array(rw,off, ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + (1 <= w, KnownNat w) => ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> SimplImpl (RNil :> LLVMPointerType w) (RNil :> LLVMPointerType w) -- | Prove a block of shape @sh1;sh2@ from blocks of shape @sh1@ and @sh2@, @@ -1628,17 +1642,21 @@ simplImplIn (SImpl_IntroLLVMFieldContents x y fld) = y (llvmFieldContents fld) simplImplIn (SImpl_DemoteLLVMFieldRW x fld) = distPerms1 x (ValPerm_Conj [Perm_LLVMField fld]) -simplImplIn (SImpl_LLVMArrayCopy x ap sub_ap) = - if isJust (llvmArrayIsOffsetArray ap sub_ap) && +simplImplIn (SImpl_DemoteLLVMArrayRW x ap) = + distPerms1 x (ValPerm_Conj [Perm_LLVMArray ap]) +simplImplIn (SImpl_LLVMArrayCopy x ap off len) = + if isJust (matchLLVMArrayCell ap off) && atomicPermIsCopyable (Perm_LLVMArray ap) then distPerms2 x (ValPerm_Conj [Perm_LLVMArray ap]) - x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayContainsArray ap sub_ap) + x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayContainsArray ap $ + llvmMakeSubArray ap off len) else error "simplImplIn: SImpl_LLVMArrayCopy: array permission not copyable or not a sub-array" -simplImplIn (SImpl_LLVMArrayBorrow x ap sub_ap) = - if isJust (llvmArrayIsOffsetArray ap sub_ap) then +simplImplIn (SImpl_LLVMArrayBorrow x ap off len) = + if isJust (matchLLVMArrayCell ap off) then distPerms2 x (ValPerm_Conj [Perm_LLVMArray ap]) - x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayContainsArray ap sub_ap) + x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayContainsArray ap $ + llvmMakeSubArray ap off len) else error "simplImplIn: SImpl_LLVMArrayBorrow: array permission not a sub-array" simplImplIn (SImpl_LLVMArrayReturn x ap ret_ap) = @@ -1653,7 +1671,7 @@ simplImplIn (SImpl_LLVMArrayAppend x ap1 ap2) = case llvmArrayIsOffsetArray ap1 ap2 of Just len1 | bvEq len1 (llvmArrayLen ap1) - , llvmArrayFields ap1 == llvmArrayFields ap2 -> + , llvmArrayCellShape ap1 == llvmArrayCellShape ap2 -> distPerms2 x (ValPerm_Conj1 $ Perm_LLVMArray ap1) x (ValPerm_Conj1 $ Perm_LLVMArray ap2) _ -> error "simplImplIn: SImpl_LLVMArrayAppend: arrays cannot be appended" @@ -1668,40 +1686,29 @@ simplImplIn (SImpl_LLVMArrayToField x ap _) = distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) simplImplIn (SImpl_LLVMArrayEmpty _ ap) = - if bvEq (llvmArrayLen ap) (bvInt 0) && llvmArrayBorrows ap == [] then - DistPermsNil - else + if bvIsZero (llvmArrayLen ap) then DistPermsNil else error "simplImplIn: SImpl_LLVMArrayEmpty: malformed empty array permission" -simplImplIn (SImpl_LLVMArrayOneCell x ap) = - case llvmArrayAsFields ap of - Just (flds, []) -> - distPerms1 x (ValPerm_Conj $ map llvmArrayFieldToAtomicPerm flds) - _ -> error "simplImplIn: SImpl_LLVMArrayOneCell: unexpected form of array permission" +simplImplIn (SImpl_LLVMArrayFromBlock x bp) = + distPerms1 x $ ValPerm_LLVMBlock bp -simplImplIn (SImpl_LLVMArrayIndexCopy x ap ix) = - if llvmArrayIndexFieldNum ix < length (llvmArrayFields ap) && - atomicPermIsCopyable (llvmArrayFieldToAtomicPerm $ - llvmArrayFieldWithOffset ap ix) then - distPerms2 x (ValPerm_Conj [Perm_LLVMArray ap]) - x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayIndexInArray ap ix) +simplImplIn (SImpl_LLVMArrayCellCopy x ap cell) = + if atomicPermIsCopyable (Perm_LLVMArray ap) then + distPerms2 x (ValPerm_LLVMArray ap) + x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayCellInArray ap cell) else - if llvmArrayIndexFieldNum ix >= length (llvmArrayFields ap) then - error "simplImplIn: SImpl_LLVMArrayIndexCopy: index out of range" - else - error "simplImplIn: SImpl_LLVMArrayIndexCopy: field is not copyable" + error "simplImplIn: SImpl_LLVMArrayCellCopy: array is not copyable" -simplImplIn (SImpl_LLVMArrayIndexBorrow x ap ix) = +simplImplIn (SImpl_LLVMArrayCellBorrow x ap cell) = distPerms2 x (ValPerm_Conj [Perm_LLVMArray ap]) - x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayIndexInArray ap ix) + x (ValPerm_Conj $ map Perm_BVProp $ llvmArrayCellInArray ap cell) -simplImplIn (SImpl_LLVMArrayIndexReturn x ap ix) = - if elem (FieldBorrow ix) (llvmArrayBorrows ap) then - distPerms2 x (ValPerm_Conj1 $ llvmArrayFieldToAtomicPerm $ - llvmArrayFieldWithOffset ap ix) +simplImplIn (SImpl_LLVMArrayCellReturn x ap cell) = + if elem (FieldBorrow cell) (llvmArrayBorrows ap) then + distPerms2 x (ValPerm_LLVMBlock $ llvmArrayCellPerm ap cell) x (ValPerm_Conj [Perm_LLVMArray ap]) else - error "simplImplIn: SImpl_LLVMArrayIndexReturn: index not being borrowed" + error "simplImplIn: SImpl_LLVMArrayCellReturn: index not being borrowed" simplImplIn (SImpl_LLVMArrayContents x ap _ _) = distPerms1 x (ValPerm_Conj [Perm_LLVMArray ap]) @@ -1775,32 +1782,20 @@ simplImplIn (SImpl_IntroLLVMBlockFromEq x bp y) = distPerms2 x (ValPerm_Conj1 $ Perm_LLVMBlock $ bp { llvmBlockShape = PExpr_EqShape $ PExpr_Var y }) y (ValPerm_Conj1 $ Perm_LLVMBlockShape $ llvmBlockShape bp) -simplImplIn (SImpl_IntroLLVMBlockPtr x maybe_rw2 maybe_l2 bp) = - if llvmShapeLength (llvmBlockShape bp) == Just (llvmBlockLen bp) then - distPerms1 x (llvmBlockPtrPerm $ - llvmBlockAdjustModalities maybe_rw2 maybe_l2 bp) - else - error "simplImplIn: SImpl_IntroLLVMBlockPtr: incorrect length" -simplImplIn (SImpl_ElimLLVMBlockPtr x maybe_rw2 maybe_l2 bp) = - if llvmShapeLength (llvmBlockShape bp) == Just (llvmBlockLen bp) then - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockLen = bvInt (machineWordBytes bp), - llvmBlockShape = - PExpr_PtrShape maybe_rw2 maybe_l2 (llvmBlockShape bp) }) - else - error "simplImplIn: SImpl_ElimLLVMBlockPtr: incorrect length" +simplImplIn (SImpl_IntroLLVMBlockPtr x bp) = + case llvmBlockPtrShapeUnfold bp of + Just bp' -> distPerms1 x $ ValPerm_LLVMBlock bp' + Nothing -> error "simplImplIn: SImpl_IntroLLVMBlockPtr: malformed block shape" +simplImplIn (SImpl_ElimLLVMBlockPtr x bp) = + distPerms1 x $ ValPerm_LLVMBlock bp simplImplIn (SImpl_IntroLLVMBlockField x fp) = distPerms1 x (ValPerm_Conj1 $ Perm_LLVMField fp) -simplImplIn (SImpl_ElimLLVMBlockField x fp len) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - (llvmFieldPermToBlock fp) { llvmBlockLen = len }) +simplImplIn (SImpl_ElimLLVMBlockField x fp) = + distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ llvmFieldPermToBlock fp) simplImplIn (SImpl_IntroLLVMBlockArray x ap) = distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) -simplImplIn (SImpl_ElimLLVMBlockArray x ap) = - case llvmAtomicPermToBlock (Perm_LLVMArray ap) of - Just bp -> distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) - Nothing -> - error "simplImplIn: SImpl_ElimLLVMBlockArray: malformed array permission" +simplImplIn (SImpl_ElimLLVMBlockArray x bp) = + distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) simplImplIn (SImpl_IntroLLVMBlockSeq x bp1 len2 sh2) = distPerms2 x (ValPerm_Conj1 $ Perm_LLVMBlock bp1) @@ -1932,24 +1927,27 @@ simplImplOut (SImpl_IntroLLVMFieldContents x _ fld) = simplImplOut (SImpl_DemoteLLVMFieldRW x fld) = distPerms1 x (ValPerm_Conj [Perm_LLVMField $ fld { llvmFieldRW = PExpr_Read }]) -simplImplOut (SImpl_LLVMArrayCopy x ap sub_ap) = - if isJust (llvmArrayIsOffsetArray ap sub_ap) && +simplImplOut (SImpl_DemoteLLVMArrayRW x ap) = + distPerms1 x (ValPerm_Conj [Perm_LLVMArray $ + ap { llvmArrayRW = PExpr_Read }]) +simplImplOut (SImpl_LLVMArrayCopy x ap off len) = + if isJust (matchLLVMArrayCell ap off) && atomicPermIsCopyable (Perm_LLVMArray ap) then - distPerms2 x (ValPerm_Conj [Perm_LLVMArray sub_ap]) + distPerms2 x (ValPerm_Conj [Perm_LLVMArray $ llvmMakeSubArray ap off len]) x (ValPerm_Conj [Perm_LLVMArray ap]) else error "simplImplOut: SImpl_LLVMArrayCopy: array permission not copyable or not a sub-array" -simplImplOut (SImpl_LLVMArrayBorrow x ap sub_ap) = - case llvmArrayIsOffsetArray ap sub_ap of - Just _ -> - distPerms2 x (ValPerm_Conj [Perm_LLVMArray sub_ap]) - x (ValPerm_Conj - [Perm_LLVMArray $ - llvmArrayAddBorrow (llvmSubArrayBorrow ap sub_ap) $ +simplImplOut (SImpl_LLVMArrayBorrow x ap off len) = + if isJust (matchLLVMArrayCell ap off) then + let sub_ap = llvmMakeSubArray ap off len in + distPerms2 x (ValPerm_Conj [Perm_LLVMArray sub_ap]) + x (ValPerm_Conj + [Perm_LLVMArray $ + llvmArrayAddBorrow (llvmSubArrayBorrow ap sub_ap) $ llvmArrayRemArrayBorrows ap sub_ap]) - Nothing -> - error "simplImplOut: SImpl_LLVMArrayBorrow: array permission not a sub-array" + else + error "simplImplOut: SImpl_LLVMArrayBorrow: array permission not a sub-array" simplImplOut (SImpl_LLVMArrayReturn x ap ret_ap) = if isJust (llvmArrayIsOffsetArray ap ret_ap) && @@ -1965,7 +1963,7 @@ simplImplOut (SImpl_LLVMArrayAppend x ap1 ap2) = case llvmArrayIsOffsetArray ap1 ap2 of Just len1 | bvEq len1 (llvmArrayLen ap1) - , llvmArrayFields ap1 == llvmArrayFields ap2 + , llvmArrayCellShape ap1 == llvmArrayCellShape ap2 , ap1' <- ap1 { llvmArrayLen = bvAdd (llvmArrayLen ap1) (llvmArrayLen ap2) } -> distPerms1 x $ ValPerm_Conj1 $ Perm_LLVMArray $ @@ -1985,45 +1983,35 @@ simplImplOut (SImpl_LLVMArrayToField x ap sz) = error "simplImplOut: SImpl_LLVMArrayToField: malformed array permission" simplImplOut (SImpl_LLVMArrayEmpty x ap) = - if bvEq (llvmArrayLen ap) (bvInt 0) && llvmArrayBorrows ap == [] then + if bvIsZero (llvmArrayLen ap) then distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) else error "simplImplOut: SImpl_LLVMArrayEmpty: malformed empty array permission" -simplImplOut (SImpl_LLVMArrayOneCell x ap) = - case llvmArrayAsFields ap of - Just (_, []) -> - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) - _ -> error "simplImplOut: SImpl_LLVMArrayOneCell: unexpected form of array permission" - -simplImplOut (SImpl_LLVMArrayIndexCopy x ap ix) = - if llvmArrayIndexFieldNum ix < length (llvmArrayFields ap) && - atomicPermIsCopyable (llvmArrayFieldToAtomicPerm $ - llvmArrayFieldWithOffset ap ix) then - distPerms2 x (ValPerm_Conj1 $ llvmArrayFieldToAtomicPerm $ - llvmArrayFieldWithOffset ap ix) - x (ValPerm_Conj [Perm_LLVMArray ap]) +simplImplOut (SImpl_LLVMArrayFromBlock x bp) = + case llvmBlockPermToArray1 bp of + Just ap -> distPerms1 x $ ValPerm_LLVMArray ap + _ -> error "simplImplOut: SImpl_LLVMArrayFromBlock: block perm with non-static length" + +simplImplOut (SImpl_LLVMArrayCellCopy x ap cell) = + if atomicPermIsCopyable (Perm_LLVMArray ap) then + distPerms2 x (ValPerm_LLVMBlock $ llvmArrayCellPerm ap cell) + x (ValPerm_LLVMArray ap) else - if llvmArrayIndexFieldNum ix >= length (llvmArrayFields ap) then - error "simplImplOut: SImpl_LLVMArrayIndexCopy: index out of range" - else - error "simplImplOut: SImpl_LLVMArrayIndexCopy: field is not copyable" + error "simplImplOut: SImpl_LLVMArrayCellCopy: array is not copyable" -simplImplOut (SImpl_LLVMArrayIndexBorrow x ap ix) = - distPerms2 x (ValPerm_Conj1 $ llvmArrayFieldToAtomicPerm $ - llvmArrayFieldWithOffset ap ix) - x (ValPerm_Conj [Perm_LLVMArray $ - llvmArrayAddBorrow (FieldBorrow ix) ap]) +simplImplOut (SImpl_LLVMArrayCellBorrow x ap cell) = + distPerms2 x (ValPerm_LLVMBlock $ llvmArrayCellPerm ap cell) + x (ValPerm_LLVMArray $ llvmArrayAddBorrow (FieldBorrow cell) ap) -simplImplOut (SImpl_LLVMArrayIndexReturn x ap ix) = - if elem (FieldBorrow ix) (llvmArrayBorrows ap) then - distPerms1 x - (ValPerm_Conj [Perm_LLVMArray $ llvmArrayRemBorrow (FieldBorrow ix) ap]) +simplImplOut (SImpl_LLVMArrayCellReturn x ap cell) = + if elem (FieldBorrow cell) (llvmArrayBorrows ap) then + distPerms1 x (ValPerm_LLVMArray $ llvmArrayRemBorrow (FieldBorrow cell) ap) else - error "simplImplOut: SImpl_LLVMArrayIndexReturn: index not being borrowed" + error "simplImplOut: SImpl_LLVMArrayCellReturn: index not being borrowed" -simplImplOut (SImpl_LLVMArrayContents x ap flds _) = - distPerms1 x (ValPerm_Conj [Perm_LLVMArray $ ap { llvmArrayFields = flds }]) +simplImplOut (SImpl_LLVMArrayContents x ap sh _) = + distPerms1 x (ValPerm_Conj [Perm_LLVMArray $ ap { llvmArrayCellShape = sh }]) simplImplOut (SImpl_LLVMFieldIsPtr x fp) = distPerms2 x (ValPerm_Conj1 Perm_IsLLVMPtr) @@ -2104,38 +2092,29 @@ simplImplOut (SImpl_ElimLLVMBlockNamed x bp nmsh) = _ -> error "simplImplOut: SImpl_ElimLLVMBlockNamed: unexpected block shape" simplImplOut (SImpl_IntroLLVMBlockFromEq x bp _) = distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) -simplImplOut (SImpl_IntroLLVMBlockPtr x maybe_rw2 maybe_l2 bp) = - if llvmShapeLength (llvmBlockShape bp) == Just (llvmBlockLen bp) then - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ - bp { llvmBlockLen = bvInt (machineWordBytes bp), - llvmBlockShape = - PExpr_PtrShape maybe_rw2 maybe_l2 (llvmBlockShape bp) }) - else - error "simplImplOut: SImpl_IntroLLVMBlockPtr: incorrect length" -simplImplOut (SImpl_ElimLLVMBlockPtr x maybe_rw2 maybe_l2 bp) = - if llvmShapeLength (llvmBlockShape bp) == Just (llvmBlockLen bp) then - distPerms1 x (llvmBlockPtrPerm $ - llvmBlockAdjustModalities maybe_rw2 maybe_l2 bp) - else - error "simplImplOut: SImpl_ElimLLVMBlockPtr: incorrect length" +simplImplOut (SImpl_IntroLLVMBlockPtr x bp) = + distPerms1 x $ ValPerm_LLVMBlock bp +simplImplOut (SImpl_ElimLLVMBlockPtr x bp) = + case llvmBlockPtrShapeUnfold bp of + Just bp' -> distPerms1 x $ ValPerm_LLVMBlock bp' + Nothing -> + error "simplImplOut: SImpl_ElimLLVMBlockPtr: unexpected block shape" simplImplOut (SImpl_IntroLLVMBlockField x fp) = distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ llvmFieldPermToBlock fp) -simplImplOut (SImpl_ElimLLVMBlockField x fp len) = - let bp_fp = llvmFieldPermToBlock fp - sz = llvmFieldLen fp in - distPerms1 x (ValPerm_Conj - [Perm_LLVMField fp, - Perm_LLVMBlock $ - bp_fp { llvmBlockOffset = bvAdd (llvmFieldOffset fp) sz, - llvmBlockLen = bvSub len sz, - llvmBlockShape = PExpr_EmptyShape }]) +simplImplOut (SImpl_ElimLLVMBlockField x fp) = + distPerms1 x $ ValPerm_LLVMField fp simplImplOut (SImpl_IntroLLVMBlockArray x ap) = case llvmAtomicPermToBlock (Perm_LLVMArray ap) of Just bp -> distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock bp) Nothing -> error "simplImplOut: SImpl_IntroLLVMBlockArray: malformed array permission" -simplImplOut (SImpl_ElimLLVMBlockArray x ap) = - distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) +simplImplOut (SImpl_ElimLLVMBlockArray x bp) = + case llvmBlockPermToArray bp of + Just ap + | bvEq (llvmArrayLengthBytes ap) (llvmBlockLen bp) -> + distPerms1 x (ValPerm_Conj1 $ Perm_LLVMArray ap) + _ -> + error "simplImplIn: SImpl_ElimLLVMBlockArray: malformed input permission" simplImplOut (SImpl_IntroLLVMBlockSeq x bp1 len2 sh2) = distPerms1 x (ValPerm_Conj1 $ Perm_LLVMBlock $ bp1 { llvmBlockLen = bvAdd (llvmBlockLen bp1) len2, @@ -2418,10 +2397,14 @@ instance SubstVar PermVarSubst m => genSubst s fld [nuMP| SImpl_DemoteLLVMFieldRW x fld |] -> SImpl_DemoteLLVMFieldRW <$> genSubst s x <*> genSubst s fld - [nuMP| SImpl_LLVMArrayCopy x ap rng |] -> - SImpl_LLVMArrayCopy <$> genSubst s x <*> genSubst s ap <*> genSubst s rng - [nuMP| SImpl_LLVMArrayBorrow x ap rng |] -> - SImpl_LLVMArrayBorrow <$> genSubst s x <*> genSubst s ap <*> genSubst s rng + [nuMP| SImpl_DemoteLLVMArrayRW x ap |] -> + SImpl_DemoteLLVMArrayRW <$> genSubst s x <*> genSubst s ap + [nuMP| SImpl_LLVMArrayCopy x ap off len |] -> + SImpl_LLVMArrayCopy <$> genSubst s x <*> genSubst s ap <*> genSubst s off + <*> genSubst s len + [nuMP| SImpl_LLVMArrayBorrow x ap off len |] -> + SImpl_LLVMArrayBorrow <$> genSubst s x <*> genSubst s ap <*> genSubst s off + <*> genSubst s len [nuMP| SImpl_LLVMArrayReturn x ap rng |] -> SImpl_LLVMArrayReturn <$> genSubst s x <*> genSubst s ap <*> genSubst s rng [nuMP| SImpl_LLVMArrayAppend x ap1 ap2 |] -> @@ -2433,19 +2416,19 @@ instance SubstVar PermVarSubst m => <*> return (mbLift sz) [nuMP| SImpl_LLVMArrayEmpty x ap |] -> SImpl_LLVMArrayEmpty <$> genSubst s x <*> genSubst s ap - [nuMP| SImpl_LLVMArrayOneCell x ap |] -> - SImpl_LLVMArrayOneCell <$> genSubst s x <*> genSubst s ap - [nuMP| SImpl_LLVMArrayIndexCopy x ap ix |] -> - SImpl_LLVMArrayIndexCopy <$> genSubst s x <*> genSubst s ap <*> genSubst s ix - [nuMP| SImpl_LLVMArrayIndexBorrow x ap ix |] -> - SImpl_LLVMArrayIndexBorrow <$> genSubst s x <*> genSubst s ap <*> - genSubst s ix - [nuMP| SImpl_LLVMArrayIndexReturn x ap ix |] -> - SImpl_LLVMArrayIndexReturn <$> genSubst s x <*> genSubst s ap <*> - genSubst s ix - [nuMP| SImpl_LLVMArrayContents x ap flds mb_mb_impl |] -> + [nuMP| SImpl_LLVMArrayFromBlock x bp |] -> + SImpl_LLVMArrayFromBlock <$> genSubst s x <*> genSubst s bp + [nuMP| SImpl_LLVMArrayCellCopy x ap cell |] -> + SImpl_LLVMArrayCellCopy <$> genSubst s x <*> genSubst s ap <*> genSubst s cell + [nuMP| SImpl_LLVMArrayCellBorrow x ap cell |] -> + SImpl_LLVMArrayCellBorrow <$> genSubst s x <*> genSubst s ap <*> + genSubst s cell + [nuMP| SImpl_LLVMArrayCellReturn x ap cell |] -> + SImpl_LLVMArrayCellReturn <$> genSubst s x <*> genSubst s ap <*> + genSubst s cell + [nuMP| SImpl_LLVMArrayContents x ap sh mb_mb_impl |] -> SImpl_LLVMArrayContents <$> genSubst s x <*> genSubst s ap <*> - genSubst s flds <*> genSubst s mb_mb_impl + genSubst s sh <*> genSubst s mb_mb_impl [nuMP| SImpl_LLVMFieldIsPtr x fp |] -> SImpl_LLVMFieldIsPtr <$> genSubst s x <*> genSubst s fp [nuMP| SImpl_LLVMArrayIsPtr x ap |] -> @@ -2510,21 +2493,18 @@ instance SubstVar PermVarSubst m => [nuMP| SImpl_IntroLLVMBlockFromEq x bp y |] -> SImpl_IntroLLVMBlockFromEq <$> genSubst s x <*> genSubst s bp <*> genSubst s y - [nuMP| SImpl_IntroLLVMBlockPtr x maybe_rw maybe_l bp |] -> - SImpl_IntroLLVMBlockPtr <$> genSubst s x <*> genSubst s maybe_rw - <*> genSubst s maybe_l <*> genSubst s bp - [nuMP| SImpl_ElimLLVMBlockPtr x maybe_rw maybe_l bp |] -> - SImpl_ElimLLVMBlockPtr <$> genSubst s x <*> genSubst s maybe_rw - <*> genSubst s maybe_l <*> genSubst s bp + [nuMP| SImpl_IntroLLVMBlockPtr x bp |] -> + SImpl_IntroLLVMBlockPtr <$> genSubst s x <*> genSubst s bp + [nuMP| SImpl_ElimLLVMBlockPtr x bp |] -> + SImpl_ElimLLVMBlockPtr <$> genSubst s x <*> genSubst s bp [nuMP| SImpl_IntroLLVMBlockField x fp |] -> SImpl_IntroLLVMBlockField <$> genSubst s x <*> genSubst s fp - [nuMP| SImpl_ElimLLVMBlockField x fp len |] -> + [nuMP| SImpl_ElimLLVMBlockField x fp |] -> SImpl_ElimLLVMBlockField <$> genSubst s x <*> genSubst s fp - <*> genSubst s len [nuMP| SImpl_IntroLLVMBlockArray x fp |] -> SImpl_IntroLLVMBlockArray <$> genSubst s x <*> genSubst s fp - [nuMP| SImpl_ElimLLVMBlockArray x fp |] -> - SImpl_ElimLLVMBlockArray <$> genSubst s x <*> genSubst s fp + [nuMP| SImpl_ElimLLVMBlockArray x bp |] -> + SImpl_ElimLLVMBlockArray <$> genSubst s x <*> genSubst s bp [nuMP| SImpl_IntroLLVMBlockSeq x bp1 len2 sh2 |] -> SImpl_IntroLLVMBlockSeq <$> genSubst s x <*> genSubst s bp1 <*> genSubst s len2 <*> genSubst s sh2 @@ -2748,19 +2728,24 @@ embedImplM ps_in m = -- | Embed a sub-computation in a name-binding inside another 'ImplM' -- computation, throwing away any state from that sub-computation and returning -- a 'PermImpl' inside a name-binding -embedMbImplM :: Mb ctx (DistPerms ps_in) -> +embedMbImplM :: KnownRepr CruCtx ctx => Mb ctx (DistPerms ps_in) -> Mb ctx (ImplM RNil s r' ps_out ps_in (r' ps_out)) -> ImplM vars s r ps ps (Mb ctx (PermImpl r' ps_in)) embedMbImplM mb_ps_in mb_m = do s <- get - lift $ strongMbM $ mbMap2 - (\ps_in m -> + lift $ strongMbM $ nuMultiWithElim + (\ns (_ :>: Identity ps_in :>: Identity m) -> runImplM CruCtxNil (distPermSet ps_in) (view implStatePermEnv s) (view implStatePPInfo s) (view implStateFailPrefix s) (view implStateDebugLevel s) - (view implStateNameTypes s) m (pure . fst)) - mb_ps_in mb_m + (view implStateNameTypes s) + (gmodify (over implStatePPInfo + (ppInfoAddTypedExprNames knownRepr ns)) >>> + implSetNameTypes ns knownRepr >>> + m) + (pure . fst)) + (MNil :>: mb_ps_in :>: mb_m) -- | Run an 'ImplM' computation in a locally-scoped way, where all effects -- are restricted to the local computation. This is essentially a form of the @@ -2865,6 +2850,15 @@ withExtVarsM m = Just e -> e Nothing -> zeroOfType knownRepr) +-- | Run an implication computation with an additional context of existential +-- variables +withExtVarsMultiM :: KnownCruCtx vars' -> + ImplM (vars :++: vars') s r ps1 ps2 a -> + ImplM vars s r ps1 ps2 a +withExtVarsMultiM MNil m = m +withExtVarsMultiM (ctx :>: KnownReprObj) m = + withExtVarsMultiM ctx (withExtVarsM m >>>= \(a,_) -> return a) + -- | Perform either the first, second, or both computations with an 'implCatchM' -- between, depending on the recursion flag implRecFlagCaseM :: NuMatchingAny1 r => ImplM vars s r ps_out ps_in a -> @@ -2911,11 +2905,12 @@ getPerms = use implStatePerms getPerm :: ExprVar a -> ImplM vars s r ps ps (ValuePerm a) getPerm x = use (implStatePerms . varPerm x) --- | Get the pointer permissions for a variable @x@, assuming @x@ has LLVM --- pointer permissions -getLLVMPtrPerms :: ExprVar (LLVMPointerType w) -> - ImplM vars s r ps ps [LLVMPtrPerm w] -getLLVMPtrPerms x = use (implStatePerms . varPerm x . llvmPtrPerms) +-- | Look up the current permission for a given variable, assuming it has a +-- conjunctive permissions, and return the conjuncts +getAtomicPerms :: ExprVar a -> ImplM vars s r ps ps [AtomicPerm a] +getAtomicPerms x = getPerm x >>= \case + ValPerm_Conj ps -> return ps + _ -> error "getAtomicPerms: non-conjunctive permission" -- | Get the distinguished permission stack getDistPerms :: ImplM vars s r ps ps (DistPerms ps) @@ -3313,23 +3308,23 @@ implTryProveBVProps x (prop:props) = implInsertConjM x (Perm_BVProp prop) (map Perm_BVProp props) 0 -- | Drop a permission from the top of the stack -implDropM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> +implDropM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> ImplM vars s r ps (ps :> a) () implDropM x p = implSimplM Proxy (SImpl_Drop x p) -- | Copy a permission on the top of the stack, assuming it is copyable -implCopyM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> +implCopyM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> ImplM vars s r (ps :> a :> a) (ps :> a) () implCopyM x p = implSimplM Proxy (SImpl_Copy x p) -- | Push a copyable permission using 'implPushM', copy that permission, and -- then pop it back to the variable permission for @x@ -implPushCopyM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> +implPushCopyM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> ImplM vars s r (ps :> a) ps () implPushCopyM x p = implPushM x p >>> implCopyM x p >>> implPopM x p -- | Swap the top two permissions on the top of the stack -implSwapM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> +implSwapM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> ValuePerm a -> ExprVar b -> ValuePerm b -> ImplM vars s r (ps :> b :> a) (ps :> a :> b) () implSwapM x p1 y p2 = implSimplM Proxy (SImpl_Swap x p1 y p2) @@ -3516,7 +3511,8 @@ implProveEqPerms (DistPermsCons ps' x p@(ValPerm_Eq _)) = implProveEqPerms _ = error "implProveEqPerms: non-equality permission" -- | Cast a proof of @x:p@ to one of @x:p'@ using a proof that @p=p'@ -implCastPermM :: NuMatchingAny1 r => ExprVar a -> SomeEqProof (ValuePerm a) -> +implCastPermM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> + SomeEqProof (ValuePerm a) -> ImplM vars s r (ps :> a) (ps :> a) () implCastPermM x some_eqp | UnSomeEqProof eqp <- unSomeEqProof some_eqp = @@ -3524,7 +3520,7 @@ implCastPermM x some_eqp implSimplM Proxy (SImpl_CastPerm x eqp) -- | Cast a permission somewhere in the stack using an equality proof -implCastStackElemM :: NuMatchingAny1 r => Member ps a -> +implCastStackElemM :: HasCallStack => NuMatchingAny1 r => Member ps a -> SomeEqProof (ValuePerm a) -> ImplM vars s r ps ps () implCastStackElemM memb some_eqp = getDistPerms >>>= \all_perms -> @@ -3535,7 +3531,8 @@ implCastStackElemM memb some_eqp = implMoveDownM ps0 (ps1 :>: px) x MNil -- | Cast all of the permissions on the stack using 'implCastPermM' -implCastStackM :: NuMatchingAny1 r => SomeEqProof (ValuePerms ps) -> +implCastStackM :: HasCallStack => NuMatchingAny1 r => + SomeEqProof (ValuePerms ps) -> ImplM vars s r ps ps () implCastStackM some_eqp = getDistPerms >>>= \perms -> @@ -3546,39 +3543,44 @@ implCastStackM some_eqp = -- | Introduce a proof of @x:true@ onto the top of the stack, which is the same -- as an empty conjunction -introConjM :: NuMatchingAny1 r => ExprVar a -> ImplM vars s r (ps :> a) ps () +introConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> ImplM vars s r (ps :> a) ps () introConjM x = implSimplM Proxy (SImpl_IntroConj x) -- | Extract the @i@th atomic permission from the conjunct on the top of the -- stack and put it just below the top of the stack -implExtractConjM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implExtractConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a :> a) (ps :> a) () implExtractConjM x ps i = implSimplM Proxy (SImpl_ExtractConj x ps i) -- | Extract the @i@th atomic permission from the conjunct on the top of the -- stack and push it to the top of the stack; i.e., call 'implExtractConjM' and -- then swap the top two stack elements -implExtractSwapConjM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implExtractSwapConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a :> a) (ps :> a) () implExtractSwapConjM x ps i = implExtractConjM x ps i >>> implSwapM x (ValPerm_Conj1 $ ps!!i) x (ValPerm_Conj $ deleteNth i ps) -- | Combine the top two conjunctive permissions on the stack -implAppendConjsM :: NuMatchingAny1 r => ExprVar a -> +implAppendConjsM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> [AtomicPerm a] -> ImplM vars s r (ps :> a) (ps :> a :> a) () implAppendConjsM x ps1 ps2 = implSimplM Proxy (SImpl_AppendConjs x ps1 ps2) -- | Split the conjuctive permissions on the top of the stack into the first @i@ -- and the remaining conjuncts after those -implSplitConjsM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implSplitConjsM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a :> a) (ps :> a) () implSplitConjsM x ps i = implSimplM Proxy (SImpl_SplitConjs x ps i) -- | Split the conjuctive permissions on the top of the stack into the first @i@ -- and the remaining conjuncts after those, and then swap them -implSplitSwapConjsM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implSplitSwapConjsM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a :> a) (ps :> a) () implSplitSwapConjsM x ps i = implSplitConjsM x ps i >>> @@ -3588,22 +3590,51 @@ implSplitSwapConjsM x ps i = -- assuming that conjunction contains the given atomic permissions and that the -- given conjunct is copyable, and put the copied atomic permission just below -- the top of the stack -implCopyConjM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implCopyConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a :> a) (ps :> a) () implCopyConjM x ps i = implSimplM Proxy (SImpl_CopyConj x ps i) -- | Copy the @i@th atomic permission in the conjunct on the top of the stack -- and push it to the top of the stack; i.e., call 'implCopyConjM' and then swap -- the top two stack elements -implCopySwapConjM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implCopySwapConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a :> a) (ps :> a) () implCopySwapConjM x ps i = implCopyConjM x ps i >>> implSwapM x (ValPerm_Conj1 $ ps!!i) x (ValPerm_Conj ps) +-- | Either extract or copy the @i@th atomic permission in the conjunct on the +-- top of the stack, leaving the extracted or copied permission just below the +-- top of the stack and the remaining other permissions on top of the stack. +-- Return the list of conjuncts remaining on top of the stack. +implGetConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> + ImplM vars s r (ps :> a :> a) (ps :> a) [AtomicPerm a] +implGetConjM x ps i = + if atomicPermIsCopyable (ps!!i) then + implCopyConjM x ps i >>> return ps + else + implExtractConjM x ps i >>> return (deleteNth i ps) + +-- | Either extract or copy the @i@th atomic permission in the conjunct on the +-- top of the stack, leaving the extracted or copied permission on top of the +-- stack and the remaining other permissions just below it. Return the list of +-- conjuncts remaining just below the top of the stack. +implGetSwapConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> + ImplM vars s r (ps :> a :> a) (ps :> a) [AtomicPerm a] +implGetSwapConjM x ps i = + if atomicPermIsCopyable (ps!!i) then + implCopySwapConjM x ps i >>> return ps + else + implExtractSwapConjM x ps i >>> return (deleteNth i ps) + -- | Either extract or copy the @i@th atomic permission in the conjunct on the -- top of the stack, popping the remaining permissions -implGetPopConjM :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Int -> +implGetPopConjM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a) (ps :> a) () implGetPopConjM x ps i = if atomicPermIsCopyable (ps!!i) then @@ -3615,14 +3646,15 @@ implGetPopConjM x ps i = -- | If the top element of the stack is copyable, then copy it and pop it, and -- otherwise just leave it alone on top of the stack -implMaybeCopyPopM :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> +implMaybeCopyPopM :: HasCallStack => NuMatchingAny1 r => + ExprVar a -> ValuePerm a -> ImplM vars s r (ps :> a) (ps :> a) () implMaybeCopyPopM x p | permIsCopyable p = implCopyM x p >>> implPopM x p implMaybeCopyPopM _ _ = pure () -- | Insert an atomic permission below the top of the stack at the @i@th -- position in the conjunct on the top of the stack, where @i@ must be between -implInsertConjM :: NuMatchingAny1 r => ExprVar a -> +implInsertConjM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> AtomicPerm a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a) (ps :> a :> a) () implInsertConjM x p ps i = implSimplM Proxy (SImpl_InsertConj x p ps i) @@ -3630,7 +3662,7 @@ implInsertConjM x p ps i = implSimplM Proxy (SImpl_InsertConj x p ps i) -- | Insert an atomic permission on the top of the stack into the @i@th position -- in the conjunct below it on the of the stack; that is, swap the top two -- permissions and call 'implInsertConjM' -implSwapInsertConjM :: NuMatchingAny1 r => ExprVar a -> +implSwapInsertConjM :: HasCallStack => NuMatchingAny1 r => ExprVar a -> AtomicPerm a -> [AtomicPerm a] -> Int -> ImplM vars s r (ps :> a) (ps :> a :> a) () implSwapInsertConjM x p ps i = @@ -3862,67 +3894,111 @@ introLLVMFieldContentsM :: introLLVMFieldContentsM x y fp = implSimplM Proxy (SImpl_IntroLLVMFieldContents x y fp) --- | Borrow a field from an LLVM array permission on the top of the stack, after +-- | Borrow a cell from an LLVM array permission on the top of the stack, after -- proving (with 'implTryProveBVProps') that the index is in the array exclusive --- of any outstanding borrows (see 'llvmArrayIndexInArray'). Return the --- resulting array permission with the borrow and the borrowed field permission, --- leaving the arry permission on top of the stack and the field permission just +-- of any outstanding borrows (see 'llvmArrayCellInArray'). Return the +-- resulting array permission with the borrow and the borrowed cell permission, +-- leaving the array permission on top of the stack and the cell permission just -- below it on the stack. -implLLVMArrayIndexBorrow :: +implLLVMArrayCellBorrow :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayIndex w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (ps :> LLVMPointerType w) (LLVMArrayPerm w, LLVMArrayField w) -implLLVMArrayIndexBorrow x ap ix = - implTryProveBVProps x (llvmArrayIndexInArray ap ix) >>> - implSimplM Proxy (SImpl_LLVMArrayIndexBorrow x ap ix) >>> - pure (llvmArrayAddBorrow (FieldBorrow ix) ap, - llvmArrayFieldWithOffset ap ix) - --- | Copy a field from an LLVM array permission on the top of the stack, after + (ps :> LLVMPointerType w) (LLVMArrayPerm w, LLVMBlockPerm w) +implLLVMArrayCellBorrow x ap cell = + implTryProveBVProps x (llvmArrayCellInArray ap cell) >>> + implSimplM Proxy (SImpl_LLVMArrayCellBorrow x ap cell) >>> + pure (llvmArrayAddBorrow (FieldBorrow cell) ap, + llvmArrayCellPerm ap cell) + +-- | Copy a cell from an LLVM array permission on the top of the stack, after -- proving (with 'implTryProveBVProps') that the index is in the array exclusive --- of any outstanding borrows (see 'llvmArrayIndexInArray') -implLLVMArrayIndexCopy :: +-- of any outstanding borrows (see 'llvmArrayCellInArray') +implLLVMArrayCellCopy :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayIndex w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) (ps :> LLVMPointerType w) () -implLLVMArrayIndexCopy x ap ix = - implTryProveBVProps x (llvmArrayIndexInArray ap ix) >>> - implSimplM Proxy (SImpl_LLVMArrayIndexCopy x ap ix) - --- | Return a field permission that has been borrowed from an array permission, --- where the array permission is on the top of the stack and the field --- permission borrowed from it is just below it -implLLVMArrayIndexReturn :: +implLLVMArrayCellCopy x ap cell = + implTryProveBVProps x (llvmArrayCellInArray ap cell) >>> + implSimplM Proxy (SImpl_LLVMArrayCellCopy x ap cell) + +-- | Copy or borrow a cell from an LLVM array permission on top of the stack, +-- depending on whether the array is copyable, after proving (with +-- 'implTryProveBVProps') that the index is in the array exclusive of any +-- outstanding borrows (see 'llvmArrayCellInArray'). Return the resulting array +-- permission with the borrow and the borrowed cell permission, leaving the +-- array permission on top of the stack and the cell permission just below it on +-- the stack. +implLLVMArrayCellGet :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayIndex w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> + ImplM vars s r (ps :> LLVMPointerType w + :> LLVMPointerType w) (ps :> LLVMPointerType w) + (LLVMArrayPerm w, LLVMBlockPerm w) +implLLVMArrayCellGet x ap cell = + if atomicPermIsCopyable (Perm_LLVMArray ap) then + implLLVMArrayCellCopy x ap cell >>> + return (ap, llvmArrayCellPerm ap cell) + else + implLLVMArrayCellBorrow x ap cell + +-- | Return a cell that has been borrowed from an array permission, where the +-- array permission is on the top of the stack and the cell permission borrowed +-- from it is just below it +implLLVMArrayCellReturn :: + (1 <= w, KnownNat w, NuMatchingAny1 r) => + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> PermExpr (BVType w) -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w :> LLVMPointerType w) () -implLLVMArrayIndexReturn x ap ix = - implSimplM Proxy (SImpl_LLVMArrayIndexReturn x ap ix) +implLLVMArrayCellReturn x ap cell = + implSimplM Proxy (SImpl_LLVMArrayCellReturn x ap cell) --- | Borrow a sub-array from an array as per 'SImpl_LLVMArrayBorrow', leaving --- the remainder of the larger array on the top of the stack and the borrowed --- sub-array just beneath it +-- | Borrow a sub-array from an array @ap@ using 'SImpl_LLVMArrayBorrow', +-- leaving the remainder of @ap@ on the top of the stack and the borrowed +-- sub-array just beneath it. Return the remainder of @ap@. implLLVMArrayBorrow :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (ps :> LLVMPointerType w) () -implLLVMArrayBorrow x ap sub_ap = + (ps :> LLVMPointerType w) (LLVMArrayPerm w) +implLLVMArrayBorrow x ap off len = + let sub_ap = llvmMakeSubArray ap off len in implTryProveBVProps x (llvmArrayContainsArray ap sub_ap) >>> - implSimplM Proxy (SImpl_LLVMArrayBorrow x ap sub_ap) + implSimplM Proxy (SImpl_LLVMArrayBorrow x ap off len) >>> + return (llvmArrayAddBorrow (llvmSubArrayBorrow ap sub_ap) $ + llvmArrayRemArrayBorrows ap sub_ap) --- | Copy a sub-array from an array as per 'SImpl_LLVMArrayCopy' +-- | Copy a sub-array from an array @ap@ as per 'SImpl_LLVMArrayCopy', leaving +-- @ap@ on the top of the stack and the borrowed sub-array just beneath +-- it. Return the remainder of @ap@ that is on top of the stack. implLLVMArrayCopy :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayPerm w -> + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) (ps :> LLVMPointerType w) () -implLLVMArrayCopy x ap sub_ap = - implTryProveBVProps x (llvmArrayContainsArray ap sub_ap) >>> - implSimplM Proxy (SImpl_LLVMArrayCopy x ap sub_ap) +implLLVMArrayCopy x ap off len = + implTryProveBVProps x (llvmArrayContainsArray ap $ + llvmMakeSubArray ap off len) >>> + implSimplM Proxy (SImpl_LLVMArrayCopy x ap off len) + +-- | Copy or borrow a sub-array from an array @ap@, depending on whether @ap@ is +-- copyable, assuming @ap@ is on top of the stack. Leave the remainder of @ap@ +-- on top of the stack and the sub-array just below it. Return the remainder of +-- @ap@ that was left on top of the stack. +implLLVMArrayGet :: + (1 <= w, KnownNat w, NuMatchingAny1 r) => + ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> + ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) + (ps :> LLVMPointerType w) (LLVMArrayPerm w) +implLLVMArrayGet x ap off len + | atomicPermIsCopyable (Perm_LLVMArray ap) = + implLLVMArrayCopy x ap off len >>> return ap +implLLVMArrayGet x ap off len = implLLVMArrayBorrow x ap off len + -- | Return a borrowed sub-array to an array as per 'SImpl_LLVMArrayReturn', -- where the borrowed array permission is just below the top of the stack and @@ -3939,26 +4015,24 @@ implLLVMArrayReturn x ap ret_ap = pure (llvmArrayRemBorrow (llvmSubArrayBorrow ap ret_ap) $ llvmArrayAddArrayBorrows ap ret_ap) --- | Add a borrow to an LLVM array permission, failing if that is not possible --- because the borrow is not in range of the array. The permission that is --- borrowed is left on top of the stack and returned as a return value. +-- | Add a borrow to an LLVM array permission by borrowing its corresponding +-- permission, failing if that is not possible because the borrow is not in +-- range of the array. The permission that is borrowed is left on top of the +-- stack and returned as a return value. implLLVMArrayBorrowBorrow :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayBorrow w -> ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) (ps :> LLVMPointerType w) (ValuePerm (LLVMPointerType w)) -implLLVMArrayBorrowBorrow x ap (FieldBorrow ix) = - implLLVMArrayIndexBorrow x ap ix >>>= \(ap',field) -> - let fld_p = ValPerm_Conj1 $ llvmArrayFieldToAtomicPerm field in - implSwapM x fld_p x (ValPerm_LLVMArray ap') >>> - pure fld_p -implLLVMArrayBorrowBorrow x ap b@(RangeBorrow _) = - let p = permForLLVMArrayBorrow ap b - ValPerm_Conj1 (Perm_LLVMArray sub_ap) = p - ap' = llvmArrayAddBorrow b ap in - implLLVMArrayBorrow x ap' sub_ap >>> - implSwapM x p x (ValPerm_Conj1 $ Perm_LLVMArray ap') >>> - pure p +implLLVMArrayBorrowBorrow x ap (FieldBorrow cell) = + implLLVMArrayCellBorrow x ap cell >>>= \(ap',bp) -> + implSwapM x (ValPerm_LLVMBlock bp) x (ValPerm_LLVMArray ap') >>> + return (ValPerm_LLVMBlock bp) +implLLVMArrayBorrowBorrow x ap (RangeBorrow (BVRange cell len)) = + let off = llvmArrayCellToAbsOffset ap cell + p = ValPerm_LLVMArray $ llvmMakeSubArray ap off len in + implLLVMArrayBorrow x ap off len >>>= \ap' -> + implSwapM x p x (ValPerm_LLVMArray ap') >>> return p -- | Return a borrow to an LLVM array permission, assuming the array is at the -- top of the stack and the borrowed permission, which should be that returned @@ -3968,8 +4042,8 @@ implLLVMArrayReturnBorrow :: ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> LLVMArrayBorrow w -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w :> LLVMPointerType w) () -implLLVMArrayReturnBorrow x ap (FieldBorrow ix) = - implLLVMArrayIndexReturn x ap ix +implLLVMArrayReturnBorrow x ap (FieldBorrow cell) = + implLLVMArrayCellReturn x ap cell implLLVMArrayReturnBorrow x ap b@(RangeBorrow _) = let ValPerm_Conj1 (Perm_LLVMArray ap_ret) = permForLLVMArrayBorrow ap b in implLLVMArrayReturn x ap ap_ret >>> @@ -4003,15 +4077,6 @@ implLLVMArrayEmpty :: ImplM vars s r (ps :> LLVMPointerType w) ps () implLLVMArrayEmpty x ap = implSimplM Proxy (SImpl_LLVMArrayEmpty x ap) --- | Prove an array that can be expressed as the conjunction of @N@ fields from --- those @N@ fields, assuming a proof of those fields is on the top of the stack -implLLVMArrayOneCell :: (1 <= w, KnownNat w, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) - (ps :> LLVMPointerType w) () -implLLVMArrayOneCell x ap = - implSimplM Proxy (SImpl_LLVMArrayOneCell x ap) - -- | Prove the @memblock@ permission returned by @'llvmAtomicPermToBlock' p@ -- from a proof of @p@ on top of the stack, assuming it returned one @@ -4083,27 +4148,29 @@ implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = implSimplM Proxy (SImpl_IntroLLVMBlockFromEq x bp' y) -- For [l]ptrsh(rw,sh), eliminate to a pointer to a memblock with shape sh -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_PtrShape maybe_rw maybe_l sh }) - | Just len <- llvmShapeLength sh = - let bp' = bp { llvmBlockLen = len, llvmBlockShape = sh } in - implSimplM Proxy (SImpl_ElimLLVMBlockPtr x maybe_rw maybe_l bp') +implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = PExpr_PtrShape _ _ _ }) + | isJust (llvmBlockPtrShapeUnfold bp) = + implSimplM Proxy (SImpl_ElimLLVMBlockPtr x bp) -- For a field shape, eliminate to a field permission -implElimLLVMBlock x (LLVMBlockPerm { llvmBlockShape = - PExpr_FieldShape (LLVMFieldShape p) - , ..}) = - implSimplM Proxy (SImpl_ElimLLVMBlockField x - (LLVMFieldPerm { llvmFieldRW = llvmBlockRW, - llvmFieldLifetime = llvmBlockLifetime, - llvmFieldOffset = llvmBlockOffset, - llvmFieldContents = p }) - llvmBlockLen) - --- For an array shape, eliminate to an array permission -implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = - PExpr_ArrayShape _ _ _ }) = - implSimplM Proxy (SImpl_ElimLLVMBlockArray x $ llvmArrayBlockToArrayPerm bp) +implElimLLVMBlock x bp@(LLVMBlockPerm + { llvmBlockShape = + PExpr_FieldShape (LLVMFieldShape p) }) + | Just fp <- llvmBlockPermToField (exprLLVMTypeWidth p) bp + , bvEq (llvmFieldLen fp) (llvmBlockLen bp) = + implSimplM Proxy (SImpl_ElimLLVMBlockField x fp) + +-- For an array shape of the right length, eliminate to an array permission +implElimLLVMBlock x bp + | Just ap <- llvmBlockPermToArray bp + , bvEq (llvmArrayLengthBytes ap) (llvmBlockLen bp) = + implSimplM Proxy (SImpl_ElimLLVMBlockArray x bp) + +-- FIXME: if we match an array shape here, its stride*length must be greater +-- than the length of bp, so we should truncate it +-- +-- implElimLLVMBlock x bp@(LLVMBlockPerm { llvmBlockShape = +-- PExpr_ArrayShape _ _ _ }) = -- Special case: for shape sh1;emptysh where the natural length of sh1 is the -- same as the length of the block permission, eliminate the emptysh, converting @@ -4144,7 +4211,7 @@ implElimLLVMBlock _ bp = -- for @x@. Extract the @i@th conjuct from @ps@, which should be a @memblock@ -- permission, pop the remaining permissions back to @x@, eliminate the -- @memblock@ permission using 'implElimLLVMBlock' if possible, and recombine --- all the resulting permissions. If the block permission cannot be elimnated, +-- all the resulting permissions. If the block permission cannot be eliminated, -- then fail. implElimPopIthLLVMBlock :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> @@ -4185,6 +4252,90 @@ implElimAppendIthLLVMBlock x ps i implElimAppendIthLLVMBlock _ _ _ = error "implElimAppendIthLLVMBlock: malformed inputs" + +-- | Assume @x:p@ is on top of the stack, where @p@ is a @memblock@ permission +-- that contains the supplied offset @off@, and repeatedly eliminate this +-- @memblock@ permission until @p@ has been converted to a non-@memblock@ +-- permission @p'@ that contains @off@. Leave @p'@ on top of the stack, return +-- it as the return value, and recombine any other permissions that are yielded +-- by this elimination. +-- +-- The notion of "contains" is determined by the supplied @imprecise_p@ flag: a +-- 'True' makes this mean "could contain" in the sense of 'bvPropCouldHold', +-- while 'False' makes this mean "definitely contains" in the sense of +-- 'bvPropHolds'. +-- +-- If there are multiple ways to eliminate @p@ to a @p'@ that contains @off@ +-- (which is only possible when @imprecise_p@ is 'True'), return each of them, +-- using 'implCatchM' to combine the different computation paths. +-- +-- If no matches are found, fail using 'implFailVarM', citing the supplied +-- permission as the one we are trying to prove. +implElimLLVMBlockForOffset :: (1 <= w, KnownNat w, NuMatchingAny1 r) => + ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> + Bool -> PermExpr (BVType w) -> + Mb vars (ValuePerm (LLVMPointerType w)) -> + ImplM vars s r (ps :> LLVMPointerType w) + (ps :> LLVMPointerType w) + (AtomicPerm (LLVMPointerType w)) +implElimLLVMBlockForOffset x bp imprecise_p off mb_p = + implElimLLVMBlock x bp >>> elimOrsExistsNamesM x >>>= \p' -> + case p' of + ValPerm_Conj ps -> + implGetLLVMPermForOffset x ps imprecise_p True off mb_p + _ -> + -- FIXME: handle eq perms here + implFailVarM "implElimLLVMBlockForOffset" x (ValPerm_LLVMBlock bp) mb_p + +-- | Assume @x:p1*...*pn@ is on top of the stack, and try to find a permission +-- @pi@ that contains a given offset @off@. If a @pi@ is found that definitely +-- contains @off@, in the sense of 'bvPropHolds', it is selected. Otherwise, if +-- the first 'Bool' flag is 'True', imprecise matches are allowed, which are +-- permissions @pi@ that could contain @off@ in the sense of 'bvPropCouldHold', +-- and all of these matches are selected. Use 'implCatchM' to try each selected +-- @pi@ and fall back to the next one if it leads to a failure. If the selected +-- @pi@ is a @memblock@ permission and the second 'Bool' flag is 'True', it is +-- then repeatedly eliminated in the sense of 'implElimLLVMBlock' until a +-- non-@memblock@ permission containing @off@ results, and this permission is +-- then used as the new @pi@. The resulting permission @pi@ is then left on top +-- of the stack and returned by the function, while the remaining permissions +-- for @x@ are recombined with any other existing permissions for @x@. If no +-- matches are found, fail using 'implFailVarM', citing the supplied permission +-- as the one we are trying to prove. +implGetLLVMPermForOffset :: + (1 <= w, KnownNat w, NuMatchingAny1 r) => + ExprVar (LLVMPointerType w) -> {- ^ the variable @x@ -} + [AtomicPerm (LLVMPointerType w)] -> {- ^ the permissions held for @x@ -} + Bool -> {- ^ whether imprecise matches are allowed -} + Bool -> {- ^ whether block permissions should be eliminated -} + PermExpr (BVType w) -> {- ^ the offset we are looking for -} + Mb vars (ValuePerm (LLVMPointerType w)) -> {- ^ the perm we want to prove -} + ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) + (AtomicPerm (LLVMPointerType w)) + +implGetLLVMPermForOffset x ps imprecise_p elim_blocks_p off mb_p = + case llvmPermIndicesForOffset ps imprecise_p off of + -- If we didn't find any matches, try to unfold on the left + [] -> + implUnfoldOrFail x ps mb_p >>>= \_ -> + elimOrsExistsNamesM x >>>= \p'' -> + (case p'' of + ValPerm_Conj ps' -> + implGetLLVMPermForOffset x ps' imprecise_p elim_blocks_p off mb_p + -- FIXME: handle eq perms here + _ -> implFailVarM "implGetLLVMPermForOffset" x (ValPerm_Conj ps) mb_p) + ixs -> + foldr1 implCatchM $ flip map ixs $ \i -> + implExtractConjM x ps i >>> + let ps' = deleteNth i ps in + recombinePerm x (ValPerm_Conj ps') >>> + case ps!!i of + Perm_LLVMBlock bp + | elim_blocks_p -> + implElimLLVMBlockForOffset x bp imprecise_p off mb_p + p_i -> return p_i + + -- | Prove a @memblock@ permission with shape @sh1 orsh sh2 orsh ... orsh shn@ -- from one with shape @shi@. implIntroOrShapeMultiM :: (NuMatchingAny1 r, 1 <= w, KnownNat w) => @@ -4367,6 +4518,11 @@ recombinePermConj x x_ps p@Perm_IsLLVMPtr implDropM x (ValPerm_Conj1 p) >>> pure x_ps +-- NOTE: the following is old, but it would never match anyway, because if we +-- have a field (or block) that was borrowed from an array, it almost certainly +-- was borrowed because we accessed it, so it will contain eq permissions and +-- its shape will not equal that of the array it was borrowed from +{- -- If p is a field that was borrowed from an array, return it; i.e., if we are -- returning x:ptr((rw,off+i*stride+j) |-> p) and x has a permission of the form -- x:array(off,>> recombinePermConj x x_ps' (Perm_LLVMArray $ llvmArrayRemBorrow (FieldBorrow ix) ap) +-} -- If p is an array that was borrowed from some other array, return it recombinePermConj x x_ps (Perm_LLVMArray ap) @@ -4395,7 +4552,7 @@ recombinePermConj x x_ps (Perm_LLVMArray ap) | isJust (llvmArrayIsOffsetArray ap' ap) && elem (llvmSubArrayBorrow ap' ap) (llvmArrayBorrows ap') && llvmArrayStride ap' == llvmArrayStride ap && - llvmArrayFields ap' == llvmArrayFields ap -> + llvmArrayCellShape ap' == llvmArrayCellShape ap -> return (ap', i) _ -> Nothing) = implPushM x (ValPerm_Conj x_ps) >>> implExtractConjM x x_ps i >>> @@ -4655,18 +4812,57 @@ proveEqCast x f e mb_e = ---------------------------------------------------------------------- --- * Lifetime Proofs +-- * Modality Proofs ---------------------------------------------------------------------- +-- | Take in a variable @x@, a function @F@ from read/write modalities to atomic +-- permissions, a read/write modality @rw@, a modality-in-binding @mb_rw@, and +-- an implication rule to coerce from @F(rw)@ to @F('PExpr_Read')@. Attempt to +-- coerce permission @x:F(rw)@ to @x:F(mb_rw)@, instantiating existential +-- variables in @mb_rw@ if necessary. Return the resulting instantiation of +-- @mb_rw@. +equalizeRWs :: NuMatchingAny1 r => ExprVar a -> + (PermExpr RWModalityType -> ValuePerm a) -> + PermExpr RWModalityType -> Mb vars (PermExpr RWModalityType) -> + SimplImpl (RNil :> a) (RNil :> a) -> + ImplM vars s r (ps :> a) (ps :> a) (PermExpr RWModalityType) +equalizeRWs x f rw mb_rw impl = + getPSubst >>>= \psubst -> equalizeRWsH x f rw psubst mb_rw impl + +-- | The main implementation of 'equalizeRWs' +equalizeRWsH :: NuMatchingAny1 r => ExprVar a -> + (PermExpr RWModalityType -> ValuePerm a) -> + PermExpr RWModalityType -> PartialSubst vars -> + Mb vars (PermExpr RWModalityType) -> + SimplImpl (RNil :> a) (RNil :> a) -> + ImplM vars s r (ps :> a) (ps :> a) (PermExpr RWModalityType) + +-- If rw and mb_rw are already equal, just return rw +equalizeRWsH _ _ rw psubst mb_rw _ + | Just rw' <- partialSubst psubst mb_rw + , rw == rw' = return rw + +-- If mb_rw is read, weaken rw to read using the supplied rule +equalizeRWsH _ _ _ psubst mb_rw impl + | Just PExpr_Read <- partialSubst psubst mb_rw = + implSimplM Proxy impl >>> return PExpr_Read + +-- Otherwise, prove rw = mb_rw and cast f(rw) to f(mb_rw) +equalizeRWsH x f rw _ mb_rw _ = + proveEqCast x f rw mb_rw >>> + partialSubstForceM mb_rw "equalizeRWs: incomplete psubst" + + -- | Take a variable @x@, a lifetime functor @F@, a lifetime @l@, and a desired -- lifetime-in-bindings @mb_l@, assuming the permission @x:F@ is on the top -- of the stack. Try to coerce the permission to @x:F@, possibly by -- instantiating existential variables in @mb_l@ and/or splitting lifetimes. +-- Return the resulting lifetime used for @mb_l@. proveVarLifetimeFunctor :: (KnownRepr TypeRepr a, NuMatchingAny1 r) => ExprVar a -> LifetimeFunctor args a -> PermExprs args -> PermExpr LifetimeType -> Mb vars (PermExpr LifetimeType) -> - ImplM vars s r (ps :> a) (ps :> a) () + ImplM vars s r (ps :> a) (ps :> a) (PermExpr LifetimeType) proveVarLifetimeFunctor x f args l mb_l = do psubst <- getPSubst proveVarLifetimeFunctor' x f args l mb_l psubst @@ -4677,14 +4873,14 @@ proveVarLifetimeFunctor' :: ExprVar a -> LifetimeFunctor args a -> PermExprs args -> PermExpr LifetimeType -> Mb vars (PermExpr LifetimeType) -> PartialSubst vars -> - ImplM vars s r (ps :> a) (ps :> a) () + ImplM vars s r (ps :> a) (ps :> a) (PermExpr LifetimeType) proveVarLifetimeFunctor' x f args l mb_l psubst = case mbMatch mb_l of -- If mb_l is an unset evar, set mb_l = l and return [nuMP| PExpr_Var mb_z |] | Left memb <- mbNameBoundP mb_z , Nothing <- psubstLookup psubst memb -> - setVarM memb l + setVarM memb l >>> return l -- If mb_l is a set evar, substitute for it and recurse [nuMP| PExpr_Var mb_z |] @@ -4694,7 +4890,7 @@ proveVarLifetimeFunctor' x f args l mb_l psubst = case mbMatch mb_l of -- If mb_l==l, we are done _ | mbLift $ fmap (== l) mb_l -> - pure () + return l -- If mb_l is a free variable l2 /= l, we need to split or weaken the lifetime [nuMP| PExpr_Var mb_z |] @@ -4711,7 +4907,8 @@ proveVarLifetimeFunctor' x f args l mb_l psubst = case mbMatch mb_l of getPerm l2 >>>= \case l2_p@(ValPerm_LOwned sub_ls ps_in ps_out) -> implPushM l2 l2_p >>> - implSplitLifetimeM x f args l l2 sub_ls ps_in ps_out + implSplitLifetimeM x f args l l2 sub_ls ps_in ps_out >>> + return (PExpr_Var l2) _ -> error ("proveVarLifetimeFunctor: unexpected error: " ++ "l2 lost its lowned perms") @@ -4719,7 +4916,8 @@ proveVarLifetimeFunctor' x f args l mb_l psubst = case mbMatch mb_l of _ -> let (l',l'_p) = lcurrentPerm l l2 in proveVarImplInt l' (fmap (const l'_p) mb_z) >>> - implSimplM Proxy (SImpl_WeakenLifetime x f args l l2) + implSimplM Proxy (SImpl_WeakenLifetime x f args l l2) >>> + return (PExpr_Var l2) -- Otherwise, fail; this should only include the case where the RHS is always -- but the LHS is not, which we cannot do anything with @@ -4732,35 +4930,44 @@ proveVarLifetimeFunctor' x f args l mb_l psubst = case mbMatch mb_l of -- * Solving for Permission List Implications ---------------------------------------------------------------------- --- | A sequence of permissions in bindings that need to be proved -type NeededPerms vars = Some (RAssign (Compose (Mb vars) VarAndPerm)) - --- | Append two existentially quantified 'RAssign' lists -apSomeRAssign :: Some (RAssign f) -> Some (RAssign f) -> Some (RAssign f) -apSomeRAssign (Some x) (Some y) = Some (RL.append x y) - --- | Concatenate a list of existentially quantified 'RAssign' lists -concatSomeRAssign :: [Some (RAssign f)] -> Some (RAssign f) -concatSomeRAssign = foldl apSomeRAssign (Some MNil) --- foldl is intentional, appending RAssign matches on the second argument +-- | A permission that needs to be proved for an implication, which has at least +-- those evars mentioned in @vars@ but possibly more +data NeededPerm vars a where + NeededPerm :: KnownCruCtx vars' -> ExprVar a -> + Mb (vars :++: vars') (ValuePerm a) -> + NeededPerm vars a --- | Convert a 'NeededPerms' list to an 'ExDistPerms' -neededPermsToExDistPerms :: RAssign prx vars -> - RAssign (Compose (Mb vars) VarAndPerm) ps -> - Mb vars (DistPerms ps) -neededPermsToExDistPerms vars MNil = nuMulti (RL.map (\_-> Proxy) vars) (const MNil) -neededPermsToExDistPerms vars (ps :>: Compose mb_vap) = - mbMap2 (:>:) (neededPermsToExDistPerms vars ps) mb_vap +-- | A sequence of permissions in bindings that need to be proved +type NeededPerms vars = Some (RAssign (NeededPerm vars)) -- | A single needed permission -neededPerms1 :: Mb vars (ExprVar a) -> Mb vars (ValuePerm a) -> NeededPerms vars -neededPerms1 mb_x mb_p = Some (MNil :>: Compose (mbMap2 VarAndPerm mb_x mb_p)) +neededPerms1 :: ExprVar a -> Mb vars (ValuePerm a) -> NeededPerms vars +neededPerms1 x mb_p = Some (MNil :>: NeededPerm MNil x mb_p) + +-- | A single needed permission with a single existential variable +mbNeededPerms1 :: KnownRepr TypeRepr tp => ExprVar a -> + Mb (vars :> tp) (ValuePerm a) -> NeededPerms vars +mbNeededPerms1 x mb_p = + Some (MNil :>: NeededPerm (MNil :>: KnownReprObj) x mb_p) -- | Convert an existential 'DistPerms' not in a binding to a 'NeededPerms' someDistPermsToNeededPerms :: RAssign Proxy vars -> Some DistPerms -> NeededPerms vars someDistPermsToNeededPerms prxs = - fmapF $ RL.map (Compose . nuMulti prxs . const) + fmapF $ RL.map (\(VarAndPerm x p) -> + NeededPerm MNil x (nuMulti prxs (const p))) + +-- | Prove the permission represented by a 'NeededPerm' +proveNeededPerm :: NuMatchingAny1 r => NeededPerm vars a -> + ImplM vars s r (ps :> a) ps () +proveNeededPerm (NeededPerm ctx x mb_p) = + withExtVarsMultiM ctx $ proveVarImpl x mb_p + +-- | Prove the permission represented by a 'NeededPerm' +proveNeededPerms :: NuMatchingAny1 r => RAssign (NeededPerm vars) ps' -> + ImplM vars s r (ps :++: ps') ps () +proveNeededPerms MNil = return () +proveNeededPerms (ps :>: p) = proveNeededPerms ps >>> proveNeededPerm p -- | If the second argument is an unset variable, set it to the first, otherwise -- do nothing @@ -4774,6 +4981,7 @@ tryUnifyVars x mb_x = case mbMatch mb_x of _ -> pure () _ -> pure () + -- | Find all the permissions that need to be added to the given list of -- permissions to prove the given block permission solveForPermListImplBlock :: (NuMatchingAny1 r, 1 <= w, KnownNat w) => @@ -4782,29 +4990,30 @@ solveForPermListImplBlock :: (NuMatchingAny1 r, 1 <= w, KnownNat w) => Mb vars (LLVMBlockPerm w) -> ImplM vars s r ps ps (NeededPerms vars) --- If the LHS is empty, return the input block permission -solveForPermListImplBlock MNil x mb_bp = - pure (neededPerms1 (fmap (const x) mb_bp) (fmap ValPerm_LLVMBlock mb_bp)) - --- If the LHS starts with a field permission, treat it like a block permission -solveForPermListImplBlock (ps_l :>: LOwnedPermField e fp_l) x mb_bp = - solveForPermListImplBlock - (ps_l :>: LOwnedPermBlock e (llvmFieldPermToBlock fp_l)) x mb_bp - --- If the LHS starts with a block permission bp', remove the range of bp' from --- the required bp and recurse on the results, setting the lifetime of our block --- permission to that of bp' if it is not already set -solveForPermListImplBlock (ps_l :>: LOwnedPermBlock (PExpr_Var y) bp_l) x mb_bp - | Just Refl <- testEquality x y - , rng_l <- llvmBlockRange bp_l - , [nuMP| Just mb_bps |] <- mbMatch $ fmap (remLLVMBLockPermRange rng_l) mb_bp = - tryUnifyVars (llvmBlockLifetime bp_l) (fmap llvmBlockLifetime mb_bp) >>> - tryUnifyVars (llvmBlockRW bp_l) (fmap llvmBlockRW mb_bp) >>> - concatSomeRAssign <$> mapM (solveForPermListImplBlock ps_l x) (mbList mb_bps) - --- Otherwise, recurse on the tail of the permission list -solveForPermListImplBlock (ps_l :>: _) x mb_bp = - solveForPermListImplBlock ps_l x mb_bp +solveForPermListImplBlock lops x mb_bp + | Just some_lop <- findLOwnedPermForVar x lops = + -- Use the modalities of some_lop to set the modalities of mb_bp, if needed + let (rw,l) = llvmLownedPermModalities some_lop in + tryUnifyVars rw (mbLLVMBlockRW mb_bp) >>> + tryUnifyVars l (mbLLVMBlockLifetime mb_bp) >>> + let rngs_lhs = lownedPermsOffsetsForLLVMVar x lops in + let mb_ex_bps = + fmap (\bp -> + -- Subtract all ranges of offsets in lops from that of mb_bp, + -- and, for each remaining range, create a memblock permission + -- with existential shape + map (\rng -> nu $ \z -> + (llvmBlockSetRange bp rng) + { llvmBlockShape = PExpr_Var z }) $ + bvRangesDelete (llvmBlockRange bp) rngs_lhs) mb_bp in + return $ concatSomeRAssign $ + map (\mb_ex_bp -> mbNeededPerms1 x $ mbValPerm_LLVMBlock $ + mbCombine RL.typeCtxProxies mb_ex_bp) $ + mbList mb_ex_bps + +-- If none of our lowned perms contain x, we need all of mb_bp +solveForPermListImplBlock _ x mb_bp = + return $ neededPerms1 x $ mbValPerm_LLVMBlock mb_bp -- | The second stage of 'solveForPermListImpl', after equality permissions have @@ -4813,31 +5022,23 @@ solveForPermListImpl1 :: NuMatchingAny1 r => LOwnedPerms ps_l -> Mb vars (LOwnedPerms ps_r) -> ImplM vars s r ps ps (NeededPerms vars) solveForPermListImpl1 ps_l mb_ps = case mbMatch mb_ps of - -- If the RHS is empty, we are done [nuMP| MNil |] -> pure (Some MNil) - -- If the RHS starts with a field perm, convert to a block perm and call - -- solveForPermListImplBlock - [nuMP| mb_ps_r :>: LOwnedPermField (PExpr_Var mb_x) mb_fp |] - | Right x <- mbNameBoundP mb_x - , mb_bp <- fmap llvmFieldPermToBlock mb_fp -> - do needed1 <- solveForPermListImplBlock ps_l x mb_bp - needed2 <- solveForPermListImpl1 ps_l mb_ps_r - pure (apSomeRAssign needed1 needed2) - - -- If the RHS starts with a block perm, call solveForPermListImplBlock - [nuMP| mb_ps_r :>: LOwnedPermBlock (PExpr_Var mb_x) mb_bp |] - | Right x <- mbNameBoundP mb_x -> - do needed1 <- solveForPermListImplBlock ps_l x mb_bp - needed2 <- solveForPermListImpl1 ps_l mb_ps_r - pure (apSomeRAssign needed1 needed2) - - -- Otherwise, we don't know what to do, so do nothing and return - _ -> - pure (Some MNil) + -- If the head of the RHS converts to a block permission, call + -- solveForPermListImplBlock, and recurse on the tail + [nuMP| mb_ps_r :>: mb_p_r |] + | Just [nuP| (mb_x, SomeLLVMBlockPerm mb_bp) |] <- + mbLownedPermVarBlockPerm mb_p_r + , Right x <- mbNameBoundP mb_x -> + do neededs1 <- solveForPermListImplBlock ps_l x mb_bp + neededs2 <- solveForPermListImpl1 ps_l mb_ps_r + pure (apSomeRAssign neededs1 neededs2) + -- Otherwise, drop the head and recurse on the tail + [nuMP| mb_ps_r :>: _ |] -> + solveForPermListImpl1 ps_l mb_ps_r -- | Determine what additional permissions from the variable permissions, if -- any, would be needed to prove one list of permissions implies another. Also @@ -4861,487 +5062,429 @@ solveForPermListImpl ps_l mb_ps_r = -- * Proving Field Permissions ---------------------------------------------------------------------- --- | Prove an LLVM field permission @x:ptr((rw,off) |-> p)@ from permission @pi@ --- assuming that the the current permissions @x:(p1 * ... *pn)@ for @x@ are on --- the top of the stack, and ensuring that any remaining permissions for @x@ get --- popped back to the primary permissions for @x@ +-- | Prove an LLVM field permission @x:ptr((rw,off) |-> p)@ from permissions +-- @x:p1*...*pn@ on the top of the stack, and ensure that any remaining +-- permissions for @x@ get popped back to the primary permissions for @x@. This +-- function does not unfold named permissions in the @pi@s. proveVarLLVMField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> Int -> + ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> PermExpr (BVType w) -> Mb vars (LLVMFieldPerm w sz) -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () --- Special case: if the LHS is a memblock perm, unfold it and prove again -proveVarLLVMField x ps i _ mb_fp - | Perm_LLVMBlock _ <- ps!!i = - implElimPopIthLLVMBlock x ps i >>> - proveVarImplInt x (fmap (ValPerm_Conj1 . Perm_LLVMField) mb_fp) - -proveVarLLVMField x ps i off mb_fp = - (if i < length ps then pure () else - error "proveVarLLVMField: index too large") >>>= \() -> - implExtractConjM x ps i >>> - let ps_rem = deleteNth i ps in - implPopM x (ValPerm_Conj ps_rem) >>> - getPSubst >>>= \psubst -> - extractNeededLLVMFieldPerm x (ps!!i) off psubst mb_fp >>>= \(fp,maybe_p_rem) -> - (case maybe_p_rem of - Just p_rem -> - implPushM x (ValPerm_Conj ps_rem) >>> - implInsertConjM x p_rem ps_rem i >>> - implPopM x (ValPerm_Conj (take i ps_rem ++ [p_rem] ++ drop i ps_rem)) - Nothing -> implDropM x ValPerm_True) >>> - proveVarLLVMFieldFromField x fp off mb_fp - - --- | Prove an LLVM field permission from another one that is on the top of the --- stack, by casting the offset, changing the lifetime if needed, and proving --- the contents -proveVarLLVMFieldFromField :: +proveVarLLVMField x ps off mb_fp = + implTraceM (\i -> + pretty "proveVarLLVMField:" <+> permPretty i x <> colon <> + align (sep [PP.group (permPretty i (ValPerm_Conj ps)), + pretty "-o", + PP.group (permPretty i mb_fp + <+> pretty "@" <+> permPretty i off)])) >>> + implGetLLVMPermForOffset x ps True True off + (mbValPerm_LLVMField mb_fp) >>>= \p -> + proveVarLLVMFieldH x p off mb_fp + +-- | Prove an LLVM field permission @mb_fp@ from an atomic permission @x:p@ on +-- the top of the stack, assuming that the offset of @mb_fp@ is @off@ and that +-- @p@ could (in the sense of 'bvPropCouldHold') contain the offset @off@ +proveVarLLVMFieldH :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz, NuMatchingAny1 r) => - ExprVar (LLVMPointerType w) -> LLVMFieldPerm w sz -> + ExprVar (LLVMPointerType w) -> AtomicPerm (LLVMPointerType w) -> PermExpr (BVType w) -> Mb vars (LLVMFieldPerm w sz) -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -proveVarLLVMFieldFromField x fp off' mb_fp = - -- Step 1: make sure to have a variable for the contents - implElimLLVMFieldContentsM x fp >>>= \y -> - let fp' = fp { llvmFieldContents = ValPerm_Eq (PExpr_Var y) } in - - -- Step 2: cast the field offset to off' if necessary - (if bvEq (llvmFieldOffset fp') off' then - pure fp' - else - implTryProveBVProp x (BVProp_Eq (llvmFieldOffset fp') off') >>> - implSimplM Proxy (SImpl_CastLLVMFieldOffset x fp' off') >>> - pure (fp' { llvmFieldOffset = off' })) >>>= \fp'' -> - - -- Step 3: prove the contents - proveVarImplInt y (fmap llvmFieldContents mb_fp) >>> - partialSubstForceM (fmap llvmFieldContents mb_fp) - "proveVarLLVMFieldFromField" >>>= \p_y -> - let fp''' = fp'' { llvmFieldContents = p_y } in - introLLVMFieldContentsM x y fp''' >>> - - -- Step 4: change the lifetime if needed. This is done after proving the - -- contents, so that, if we need to split the lifetime, we don't split the - -- lifetime of a pointer permission with eq(y) permissions, as that would - -- require the pointer to be constant until the end of the new lifetime. - let (f, args) = fieldToLTFunc fp''' in - proveVarLifetimeFunctor x f args (llvmFieldLifetime fp''') (fmap - llvmFieldLifetime - mb_fp) - - --- | Extract an LLVM field permission from the given atomic permission, leaving --- as much of the original atomic permission as possible on the top of the stack --- (which could be none of it, i.e., @true@). At the end of this function, the --- top of the stack should look like --- --- > x:ptr((rw,off) -> p) * x:rem --- --- where @rem@ is the remainder of the input atomic permission, which is either --- a single atomic permission or @true@. The field permission and remaining --- atomic permission (if any) are the return values of this function. -extractNeededLLVMFieldPerm :: + +proveVarLLVMFieldH x p off mb_fp = + implTraceM (\i -> + pretty "proveVarLLVMFieldH:" <+> permPretty i x <> colon <> + align (sep [PP.group (permPretty i p), + pretty "-o", + PP.group (permPretty i mb_fp)])) >>> + proveVarLLVMFieldH2 x p off mb_fp + +proveVarLLVMFieldH2 :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> AtomicPerm (LLVMPointerType w) -> - PermExpr (BVType w) -> PartialSubst vars -> Mb vars (LLVMFieldPerm w sz) -> - ImplM vars s r (ps :> LLVMPointerType w :> LLVMPointerType w) - (ps :> LLVMPointerType w) - (LLVMFieldPerm w sz, Maybe (AtomicPerm (LLVMPointerType w))) - --- If proving x:ptr((rw,off) |-> p) |- x:ptr((z,off') |-> p') for an RWModality --- variable z, set z = rw and recurse -extractNeededLLVMFieldPerm x p@(Perm_LLVMField fp) off' psubst mb_fp - | Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , [nuMP| PExpr_Var z |] <- mbMatch $ fmap llvmFieldRW mb_fp - , Left memb <- mbNameBoundP z - , Nothing <- psubstLookup psubst memb = - setVarM memb (llvmFieldRW fp) >>> - extractNeededLLVMFieldPerm x p off' psubst - (fmap (\fp' -> fp' { llvmFieldRW = llvmFieldRW fp }) mb_fp) - --- If proving x:ptr((rw,off) |-> p) |- x:ptr((z,off') |-> p') where z is --- defined, substitute for z and recurse -extractNeededLLVMFieldPerm x p@(Perm_LLVMField fp) off' psubst mb_fp - | Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , [nuMP| PExpr_Var z |] <- mbMatch $ fmap llvmFieldRW mb_fp - , Left memb <- mbNameBoundP z - , Just rw <- psubstLookup psubst memb = - extractNeededLLVMFieldPerm x p off' psubst - (fmap (\fp' -> fp' { llvmFieldRW = rw }) mb_fp) - --- If proving x:ptr((R,off) |-> p) |- x:ptr((R,off') |-> p'), just copy the read --- permission -extractNeededLLVMFieldPerm x (Perm_LLVMField fp) _ _ mb_fp - | Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , PExpr_Read <- llvmFieldRW fp - , [nuMP| PExpr_Read |] <- mbMatch $ fmap llvmFieldRW mb_fp - = implCopyConjM x [Perm_LLVMField fp] 0 >>> - pure (fp, Just (Perm_LLVMField fp)) - --- Cannot prove x:ptr((rw,off) |-> p) |- x:ptr((W,off') |-> p') if rw is not W, --- so fail -extractNeededLLVMFieldPerm x ap@(Perm_LLVMField fp) _ _ mb_fp - | Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , PExpr_Write /= llvmFieldRW fp - , [nuMP| PExpr_Write |] <- mbMatch $ fmap llvmFieldRW mb_fp - = implFailVarM "extractNeededLLVMFieldPerm" x (ValPerm_Conj1 $ ap) - (fmap (ValPerm_Conj1 . Perm_LLVMField) mb_fp) - --- If proving x:[l1]ptr((rw,off) |-> p) |- x:[l2]ptr((R,off') |-> p') for rw not --- equal to R (i.e., equal to W or to a variable), demote rw to R and copy it -extractNeededLLVMFieldPerm x (Perm_LLVMField fp) _ _ mb_fp - | Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , PExpr_Read /= llvmFieldRW fp - , [nuMP| PExpr_Read |] <- mbMatch $ fmap llvmFieldRW mb_fp - = let fp' = fp in - implSimplM Proxy (SImpl_DemoteLLVMFieldRW x fp') >>> - let fp'' = fp' { llvmFieldRW = PExpr_Read } in - implCopyConjM x [Perm_LLVMField fp''] 0 >>> - pure (fp'', Just (Perm_LLVMField fp'')) - --- If proving x:ptr((rw,off) |-> p) |- x:ptr((rw,off') |-> p') for any other --- case, just push a true permission, because there is no remaining permission -extractNeededLLVMFieldPerm x (Perm_LLVMField fp) _ _ mb_fp - | Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , mbLift (fmap ((llvmFieldRW fp ==) . llvmFieldRW) mb_fp) - = introConjM x >>> pure (fp, Nothing) - --- If proving x:array(off, p) such that --- off=i*stride+j and the jth field of the ith index of the array is of the --- right size and is a read containing only copyable permissions, copy that --- field -extractNeededLLVMFieldPerm x (Perm_LLVMArray ap) off' _ mb_fp - | Just ix <- matchLLVMArrayField ap off' - , LLVMArrayField fp <- llvmArrayFieldWithOffset ap ix - , Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) - , PExpr_Read <- llvmFieldRW fp - , permIsCopyable (llvmFieldContents fp) - , [nuMP| PExpr_Read |] <- mbMatch $ fmap llvmFieldRW mb_fp = - implLLVMArrayIndexCopy x ap ix >>> - pure (fp, Just (Perm_LLVMArray ap)) - --- If proving x:array(off, p) such --- that off=i*stride+j and the corresponding array field is of the right size in --- any other case, borrow that field -extractNeededLLVMFieldPerm x (Perm_LLVMArray ap) off' psubst mb_fp - | Just ix <- matchLLVMArrayField ap off' - , LLVMArrayField fp <- llvmArrayFieldWithOffset ap ix - , Just Refl <- testEquality (llvmFieldSize fp) (mbLift $ - fmap llvmFieldSize mb_fp) = - implLLVMArrayIndexBorrow x ap ix >>>= \(ap', _) -> - implSwapM x (ValPerm_Conj1 $ Perm_LLVMField fp) x (ValPerm_Conj1 $ - Perm_LLVMArray ap') >>> - extractNeededLLVMFieldPerm x (Perm_LLVMField fp) off' psubst mb_fp >>>= - \(fp', maybe_p_rem) -> - -- NOTE: it is safe to just drop the remaining permission on the stack, - -- because it is either Nothing (for a write) or a copy of the field - -- permission (for a read) - implDropM x (maybe ValPerm_True ValPerm_Conj1 maybe_p_rem) >>> - implSwapM x (ValPerm_Conj1 $ - Perm_LLVMArray ap') x (ValPerm_Conj1 $ Perm_LLVMField fp) >>> - pure (fp', Just (Perm_LLVMArray ap')) - --- If proving x:array(off, p) such --- that off=i*stride+j but the corresponding array field is of a smaller size, --- borrow a sub-array for the correct size and cast it to a field permission -extractNeededLLVMFieldPerm x (Perm_LLVMArray ap) off' _ mb_fp - | stride_bits <- llvmArrayStrideBits ap - , sz <- mbLift $ fmap llvmFieldSize mb_fp - , len <- bvInt (intValue sz `div` stride_bits) - , sub_ap <- ap { llvmArrayOffset = off', llvmArrayLen = len, + PermExpr (BVType w) -> Mb vars (LLVMFieldPerm w sz) -> + ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () + +-- If we have a field permission of the correct size on the left, use it to +-- prove the field permission on the right +proveVarLLVMFieldH2 x (Perm_LLVMField fp) off mb_fp + | bvEq (llvmFieldOffset fp) off + , Just Refl <- testEquality (llvmFieldSize fp) (mbLLVMFieldSize mb_fp) = + -- Step 1: make sure to have a variable for the contents + implElimLLVMFieldContentsM x fp >>>= \y -> + let fp' = fp { llvmFieldContents = ValPerm_Eq (PExpr_Var y) } in + + -- Step 2: prove the contents + proveVarImplInt y (mbLLVMFieldContents mb_fp) >>> + partialSubstForceM (mbLLVMFieldContents mb_fp) + "proveVarLLVMFieldH" >>>= \p_y -> + let fp'' = fp' { llvmFieldContents = p_y } in + introLLVMFieldContentsM x y fp'' >>> + + -- Step 3: change the lifetime if needed. This is done after proving the + -- contents, so that, if we need to split the lifetime, we don't split the + -- lifetime of a pointer permission with eq(y) permissions, as that would + -- require the pointer to be constant until the end of the new lifetime. + -- + -- FIXME: probably the right way to do this would be to first check if there + -- is going to be a borrow, and if so then recall the field permissions for + -- fp immediately before we do said borrow. Maybe this could be part of + -- proveVarLifetimeFunctor? + let (f, args) = fieldToLTFunc fp'' in + proveVarLifetimeFunctor x f args (llvmFieldLifetime fp'') + (fmap llvmFieldLifetime mb_fp) >>>= \l -> + let fp''' = fp'' { llvmFieldLifetime = l } in + + -- Step 4: equalize the read/write modalities. This is done after changing + -- the lifetime so that the original modality is recovered after any borrow + -- performed above is over. + equalizeRWs x (\rw -> ValPerm_LLVMField $ fp''' { llvmFieldRW = rw }) + (llvmFieldRW fp) (mbLLVMFieldRW mb_fp) (SImpl_DemoteLLVMFieldRW x fp''') >>> + return () + +-- If we have a block permission on the left, eliminate it +proveVarLLVMFieldH2 x (Perm_LLVMBlock bp) off mb_fp = + implElimLLVMBlockForOffset x bp True off (mbValPerm_LLVMField mb_fp) >>>= \p -> + proveVarLLVMFieldH x p off mb_fp + +-- If we have an array permission on the left such that @off@ matches an index +-- into that array permission and mb_fp fits into the cell of that index, copy +-- or borrow the corresponding cell and recurse +proveVarLLVMFieldH2 x (Perm_LLVMArray ap) off mb_fp + | Just ix <- matchLLVMArrayIndex ap off + , cell <- llvmArrayIndexCell ix + , sz_int <- intValue (mbLLVMFieldSize mb_fp) `div` 8 + , BV.asUnsigned (llvmArrayIndexOffset ix) + sz_int <= (toInteger $ + llvmArrayStride ap) = + implLLVMArrayCellGet x ap cell >>>= \(ap', bp) -> + recombinePerm x (ValPerm_LLVMArray ap') >>> + proveVarLLVMFieldH x (Perm_LLVMBlock bp) off mb_fp + +-- If we have an array on the left with a sub-array of the same size as mb_fp, +-- prove that sub-array, convert it to a field, and recurse +proveVarLLVMFieldH2 x (Perm_LLVMArray ap) off mb_fp + | Just ix <- matchLLVMArrayIndex ap off + , BV.BV 0 <- llvmArrayIndexOffset ix + , sz <- mbLLVMFieldSize mb_fp + , num_cells <- intValue sz `div` llvmArrayStrideBits ap + , cell <- llvmArrayIndexCell ix + , sub_ap <- ap { llvmArrayOffset = llvmArrayCellToAbsOffset ap cell, + llvmArrayLen = bvInt num_cells, llvmArrayBorrows = [] } - , isJust $ llvmArrayIsOffsetArray ap sub_ap - , Just fp <- llvmArrayToField sz sub_ap - , ap' <- llvmArrayAddBorrow (llvmSubArrayBorrow ap sub_ap) ap = - implLLVMArrayBorrow x ap sub_ap >>> - implSwapM x (ValPerm_Conj1 $ - Perm_LLVMArray sub_ap) x (ValPerm_Conj1 $ - Perm_LLVMArray ap') >>> + , Just fp <- llvmArrayToField sz sub_ap = + mbVarsM sub_ap >>>= \mb_sub_ap -> + proveVarLLVMArray_FromArray x ap mb_sub_ap >>> implSimplM Proxy (SImpl_LLVMArrayToField x sub_ap sz) >>> - -- NOTE: extractNeededLLVMFieldPerm is responsible for setting the - -- rwmodality, so we include this proveEqCast for just it here - proveEqCast x (\rw -> ValPerm_Conj1 $ Perm_LLVMField $ - fp { llvmFieldRW = rw }) - (llvmFieldRW fp) (fmap llvmFieldRW mb_fp) >>> - implSwapM x (ValPerm_Conj1 $ - Perm_LLVMArray ap') x (ValPerm_Conj1 $ - Perm_LLVMField fp) >>> - pure (fp, Just (Perm_LLVMArray ap')) + proveVarLLVMFieldH x (Perm_LLVMField fp) off mb_fp - --- All other cases fail -extractNeededLLVMFieldPerm x ap _ _ mb_fp = - implFailVarM "extractNeededLLVMFieldPerm" x (ValPerm_Conj1 $ ap) - (fmap (ValPerm_Conj1 . Perm_LLVMField) mb_fp) +-- If none of the above cases match, then fail +proveVarLLVMFieldH2 x p _ mb_fp = + implFailVarM "proveVarLLVMFieldH" x (ValPerm_Conj1 p) + (mbValPerm_LLVMField mb_fp) ---------------------------------------------------------------------- -- * Proving LLVM Array Permissions ---------------------------------------------------------------------- --- | FIXME HERE NOW: document, especially the bool flag = first iteration and --- that the bools with each perm are whether they can be used +-- | Prove an LLVM array permission @ap@ from permissions @x:(p1 * ... *pn)@ on +-- the top of the stack, ensuring that any remaining permissions for @x@ get +-- popped back to the primary permissions for @x@. This function does not unfold +-- named permissions in the @pi@s. proveVarLLVMArray :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> - Bool -> [AtomicPerm (LLVMPointerType w)] -> LLVMArrayPerm w -> + Bool -> [AtomicPerm (LLVMPointerType w)] -> Mb vars (LLVMArrayPerm w) -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -proveVarLLVMArray x first_p ps ap = +proveVarLLVMArray x first_p ps mb_ap = implTraceM (\i -> pretty "proveVarLLVMArray:" <+> permPretty i x <> colon <> align (sep [PP.group (permPretty i (ValPerm_Conj ps)), pretty "-o", - PP.group (permPretty i (ValPerm_Conj1 $ - Perm_LLVMArray ap))])) >>> - proveVarLLVMArrayH x first_p ps ap - + PP.group (permPretty i mb_ap)])) >>> + getPSubst >>>= \psubst -> + proveVarLLVMArrayH x first_p psubst ps mb_ap --- | FIXME HERE NOW: document, especially the bool flag = first iteration and --- that the bools with each perm are whether they can be used proveVarLLVMArrayH :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> - Bool -> [AtomicPerm (LLVMPointerType w)] -> LLVMArrayPerm w -> + Bool -> PartialSubst vars -> [AtomicPerm (LLVMPointerType w)] -> + Mb vars (LLVMArrayPerm w) -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () --- When len = 0, we are done -proveVarLLVMArrayH x _ ps ap - | bvEq (llvmArrayLen ap) (bvInt 0) = - implPopM x (ValPerm_Conj ps) >>> implLLVMArrayEmpty x ap +-- Special case: if the length is 0, prove an empty array +proveVarLLVMArrayH x _ psubst ps mb_ap + | Just len <- partialSubst psubst $ mbLLVMArrayLen mb_ap + , bvIsZero len = + implPopM x (ValPerm_Conj ps) >>> + partialSubstForceM mb_ap "proveVarLLVMArray: incomplete psubst" >>>= \ap -> + implLLVMArrayEmpty x ap --- If the offset of our array permission is inside a memblock permission, --- eliminate that memblock permission and try again -proveVarLLVMArrayH x _ ps ap - | Just i <- findIndex (isLLVMAtomicPermWithOffset $ llvmArrayOffset ap) ps - , Perm_LLVMBlock _ <- ps!!i = - implElimPopIthLLVMBlock x ps i >>> - mbVarsM (ValPerm_LLVMArray ap) >>>= \mb_p -> - proveVarImplInt x mb_p +-- Otherwise, look for any permission the could contain the offset of mb_ap +proveVarLLVMArrayH x first_p _ ps mb_ap = + implTraceM (\i -> + pretty "proveVarLLVMArrayH:" <+> permPretty i x <> colon <> + align (sep [PP.group (permPretty i (ValPerm_Conj ps)), + pretty "-o", + PP.group (permPretty i mb_ap)])) >>> + partialSubstForceM (mbLLVMArrayOffset mb_ap) + "proveVarLLVMArray: incomplete array offset" >>>= \off -> + implGetLLVMPermForOffset x ps first_p True off + (mbValPerm_LLVMArray mb_ap) >>>= \case + + -- If ps are eliminated to a field permission for off, pop all the permissions + -- for x and then prove the first cell of ap followed by the rest + p@(Perm_LLVMField _) -> + recombinePerm x (ValPerm_Conj1 p) >>> + proveVarLLVMArray_FromHead x mb_ap + + -- If ps are eliminated to an array permission for off, use it to prove ap, + -- after popping the remaining permissions for x + Perm_LLVMArray ap_lhs + | llvmArrayStride ap_lhs == mbLLVMArrayStride mb_ap -> + proveVarLLVMArray_FromArray x ap_lhs mb_ap >>>= \_ -> return () + + -- Because we told implGetLLVMPermForOffset to eliminate block perms, there + -- should be no other cases that will work here, so fail + _ -> + implFailVarM "proveVarLLVMArrayH" x (ValPerm_Conj ps) + (mbValPerm_LLVMArray mb_ap) --- If the required array permission ap is equivalent to a sequence of field --- permissions that we have all of, then prove it by proving those field --- permissions. This is accomplished by first proving the array with the --- un-borrowed cell that is allowed by 'implLLVMArrayOneCell' and then --- recursively proving the desired array permission by calling proveVarImplInt, --- which will remove the necessary borrows. -proveVarLLVMArrayH x _ ps ap - | Just (flds1, flds2) <- llvmArrayAsFields ap - , all (\fld -> - any (isLLVMFieldPermWithOffset - (llvmArrayFieldOffset fld)) ps) (flds1 ++ flds2) = - implPopM x (ValPerm_Conj ps) >>> - mbVarsM (ValPerm_Conj $ - map llvmArrayFieldToAtomicPerm flds1) >>>= \mb_p_flds -> - proveVarImplInt x mb_p_flds >>> - let ap' = llvmArrayAddBorrows (map (fromJust - . offsetToLLVMArrayBorrow ap - . llvmArrayFieldOffset) flds2) ap in - implLLVMArrayOneCell x ap' >>> - implPopM x (ValPerm_Conj1 $ Perm_LLVMArray ap') >>> - mbVarsM (ValPerm_Conj1 $ Perm_LLVMArray ap) >>>= \mb_p -> - proveVarImplInt x mb_p --- Otherwise, choose the best-matching array permission and copy, borrow, or use --- it directly (beg, borrow, or steal it) --- --- FIXME: need to handle the case where we have a field permission for the first --- cell of an array and an array permission for the rest -proveVarLLVMArrayH x first_p ps ap = - let best_elems :: [(Bool, a)] -> [a] - best_elems xs | Just i <- findIndex fst xs = [snd $ xs !! i] - best_elems xs = map snd xs in - - mbVarsM (Perm_LLVMArray ap) >>>= \mb_p -> - foldr1WithDefault implCatchM (proveVarAtomicImplUnfoldOrFail x ps mb_p) $ - best_elems $ - (let off = llvmArrayOffset ap in - catMaybes $ - zipWith (\p i -> case p of - Perm_LLVMArray ap_lhs - | precise <- bvEq off (llvmArrayOffset ap_lhs) - , (first_p || precise) - , Just cell_num <- llvmArrayIsOffsetArray ap_lhs ap - , bvCouldBeInRange cell_num (llvmArrayCells ap_lhs) -> - Just (precise, proveVarLLVMArray_ArrayStep x ps ap i ap_lhs) - _ -> Nothing) - ps [0..]) - - --- | FIXME HERE NOW: document this -proveVarLLVMArray_ArrayStep :: +-- | Prove an array permission by proving its first cell and then its remaining +-- cells and appending them together +proveVarLLVMArray_FromHead :: + (1 <= w, KnownNat w, NuMatchingAny1 r) => + ExprVar (LLVMPointerType w) -> Mb vars (LLVMArrayPerm w) -> + ImplM vars s r (ps :> LLVMPointerType w) ps () +proveVarLLVMArray_FromHead x mb_ap = + -- Prove the head permission and convert to an array + let mb_bp = mbMapCl $(mkClosed [| llvmArrayPermHead |]) mb_ap in + proveVarImplInt x (mbValPerm_LLVMBlock mb_bp) >>> + partialSubstForceM mb_bp "proveVarLLVMArray: incomplete psubst" >>>= \bp_head -> + implSimplM Proxy (SImpl_LLVMArrayFromBlock x bp_head) >>> + let ap_head = case llvmBlockPermToArray1 bp_head of + Just ap -> ap + Nothing -> error "proveVarLLVMArray: unexpected form of head cell" in + + -- Test if the length of ap is 1 + partialSubstForceM (mbLLVMArrayLen mb_ap) + "proveVarLLVMArray: incomplete length" >>>= \len -> + if bvEq len (bvInt 1) then + -- If so, then we are done! + return () + else + ( + -- Otherwise, recursively prove the tail of mb_ap + getAtomicPerms x >>>= \ps'' -> + implPushM x (ValPerm_Conj ps'') >>> + let mb_ap_tail = mbMapCl $(mkClosed [| llvmArrayPermTail |]) mb_ap in + proveVarLLVMArray x False ps'' mb_ap_tail >>> + + -- Append the head and the tail to get mb_ap + partialSubstForceM mb_ap_tail + "proveVarLLVMArray: incomplete psubst" >>>= \ap_tail -> + implLLVMArrayAppend x ap_head ap_tail + ) + + +-- | Prove an array permission @mb_ap@ using the array permission @ap_lhs@ on +-- top of the stack, assuming that @ap_lhs@ has the stride as @mb_ap@ and could +-- contain the offset of @mb_ap@. Return the resulting array permission that was +-- proved. +proveVarLLVMArray_FromArray :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> - [AtomicPerm (LLVMPointerType w)] -> LLVMArrayPerm w -> - Int -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -proveVarLLVMArray_ArrayStep x ps ap i ap_lhs = + LLVMArrayPerm w -> Mb vars (LLVMArrayPerm w) -> + ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) + (LLVMArrayPerm w) +proveVarLLVMArray_FromArray x ap_lhs mb_ap = implTraceM (\info -> - pretty "proveVarLLVMArray_ArrayStep:" <+> + pretty "proveVarLLVMArray_FromArray:" <+> permPretty info x <> colon <> - align (sep [PP.group (permPretty info (ValPerm_Conj ps)), - parens (permPretty info (ValPerm_LLVMArray ap)), + align (sep [permPretty info (ValPerm_LLVMArray ap_lhs), pretty "-o", - PP.group (permPretty info (ValPerm_Conj1 $ - Perm_LLVMArray ap))])) >>> - proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs + PP.group (permPretty info mb_ap)])) >>> + getAtomicPerms x >>>= \ps -> + partialSubstForceM (mbLLVMArrayOffset mb_ap) + "proveVarLLVMArray: incomplete psubst" >>>= \off -> + partialSubstForceM (mbLLVMArrayLen mb_ap) + "proveVarLLVMArray: incomplete psubst" >>>= \len -> + partialSubstForceM (mbLLVMArrayBorrows mb_ap) + "proveVarLLVMArray: incomplete array offset" >>>= \bs -> + proveVarLLVMArray_FromArray1 x ps ap_lhs off len bs mb_ap + + +-- | Prove an array permission @mb_ap@ with length and borrows set to the +-- supplied expression and list using the array permission @ap_lhs@ on top of +-- the stack, assuming that @off@ is the offset of @mb_ap@ and that @ap_lhs@ has +-- the same stride as @mb_ap@. Return the resulting array permission that was +-- proved. This function equalizes the offsets and lengths of @ap_lhs@ and +-- @mb_ap@ and then calls 'proveVarLLVMArray_FromArray2'. +proveVarLLVMArray_FromArray1 :: + (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> + [AtomicPerm (LLVMPointerType w)] -> LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> [LLVMArrayBorrow w] -> + Mb vars (LLVMArrayPerm w) -> + ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) + (LLVMArrayPerm w) +-- If ap_lhs and mb_ap have the same offset and length, proceed to phase 2 +proveVarLLVMArray_FromArray1 x _ ap_lhs off len bs mb_ap + | bvEq off (llvmArrayOffset ap_lhs) + , bvEq len (llvmArrayLen ap_lhs) = + proveVarLLVMArray_FromArray2 x ap_lhs len bs mb_ap + +-- If ap could extend beyond ap_lhs and there is an atomic permission for x +-- that starts at the end of ap_lhs, then use ap_lhs to prove the first portion +-- of ap and then recursively prove the rest +proveVarLLVMArray_FromArray1 x ps ap_lhs off len bs mb_ap + | len' <- bvSub (llvmArrayLen ap_lhs) (bvSub off $ llvmArrayOffset ap_lhs) + , bvCouldBeLt len' len + , off' <- bvAdd off len' + , any (isLLVMAtomicPermWithOffset off') ps + , (bs_first, bs_rest) <- + partition (\b -> + all bvPropCouldHold $ + llvmArrayBorrowInArrayBase ap_lhs b) bs = + + -- If ap_lhs starts before ap, then borrow or copy the portion we are going + -- to use, and otherwise just use ap_lhs as is + (if bvEq (llvmArrayOffset ap_lhs) off then return ap_lhs else + (implLLVMArrayGet x ap_lhs off len' >>>= \ap_lhs' -> + recombinePerm x (ValPerm_LLVMArray ap_lhs') >>> + return (llvmMakeSubArray ap_lhs off len'))) >>>= \ap_lhs' -> + + -- Recursively prove ap with length len' and borrows that could be in the + -- first portion of ap + proveVarLLVMArray_FromArray2 x ap_lhs' len' bs_first mb_ap >>>= \ap' -> + + -- Prove ap with the remaining offset, length, and borrows + let ap_rest = llvmMakeSubArray ap' off len in + mbVarsM ap_rest >>>= \mb_ap_rest -> + getAtomicPerms x >>>= \ps' -> + implPushM x (ValPerm_Conj ps') >>> + proveVarLLVMArray x False ps' mb_ap_rest >>> --- | The main workhorse of 'proveVarLLVMArray_ArrayStep' -proveVarLLVMArray_ArrayStepH :: + -- Combine ap_first and ap_rest to get out ap + implLLVMArrayAppend x ap' ap_rest >>> + implLLVMArrayRearrange x (ap' { llvmArrayLen = len, + llvmArrayBorrows = + bs_first ++ bs_rest }) bs >>> + return (ap' { llvmArrayLen = len, llvmArrayBorrows = bs }) + + +-- Otherwise, borrow or copy len bytes of ap_lhs and recurse +proveVarLLVMArray_FromArray1 x _ ap_lhs off len bs mb_ap = + let ap_lhs' = llvmMakeSubArray ap_lhs off len in + implLLVMArrayGet x ap_lhs off len >>>= \ap_lhs'' -> + recombinePerm x (ValPerm_LLVMArray ap_lhs'') >>> + proveVarLLVMArray_FromArray2 x ap_lhs' len bs mb_ap + + +-- | Prove an array permission @mb_ap@ with borrows set to the supplied list and +-- length set to that of @ap_lhs@ using the array permission @ap_lhs@ on top of +-- the stack, assuming that @ap_lhs@ has the same offset and stride as @ap@. +-- Return the resulting array permission that was proved. +proveVarLLVMArray_FromArray2 :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> - [AtomicPerm (LLVMPointerType w)] -> LLVMArrayPerm w -> - Int -> LLVMArrayPerm w -> - ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () + LLVMArrayPerm w -> PermExpr (BVType w) -> [LLVMArrayBorrow w] -> + Mb vars (LLVMArrayPerm w) -> + ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) + (LLVMArrayPerm w) + +proveVarLLVMArray_FromArray2 x ap_lhs len bs mb_ap = + implTraceM (\info -> + pretty "proveVarLLVMArray_FromArray2:" <+> + permPretty info x <> colon <> + align (sep [permPretty info (ValPerm_LLVMArray ap_lhs), + pretty "-o", + PP.group (permPretty info mb_ap)])) >>> + proveVarLLVMArray_FromArray2H x ap_lhs len bs mb_ap + +-- | The implementation of 'proveVarLLVMArray_FromArray2' +proveVarLLVMArray_FromArray2H :: + (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> + LLVMArrayPerm w -> PermExpr (BVType w) -> [LLVMArrayBorrow w] -> + Mb vars (LLVMArrayPerm w) -> + ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) + (LLVMArrayPerm w) --- If there is a borrow in ap_lhs that is not in ap but might overlap with ap, --- return it to ap_lhs +-- If there is a borrow in ap_lhs that is not in ap, return it to ap_lhs -- -- FIXME: when an array ap_ret is being borrowed from ap_lhs, this code requires -- all of it to be returned, with no borrows, even though it could be that ap -- allows some of ap_ret to be borrowed -proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs - | Just ap_cell_off <- llvmArrayIsOffsetArray ap_lhs ap - , Just b <- - find (\b -> - bvRangesCouldOverlap (llvmArrayBorrowAbsOffsets ap b) - (llvmArrayAbsOffsets ap) && - not (elem b $ llvmArrayBorrows ap)) - (map (cellOffsetLLVMArrayBorrow ap_cell_off) $ - llvmArrayBorrows ap_lhs) = - - -- Prove the rest of ap with b borrowed - let ap' = llvmArrayAddBorrow b ap in - proveVarLLVMArray_ArrayStep x ps ap' i ap_lhs >>> - - -- Prove the borrowed perm - let p = permForLLVMArrayBorrow ap b in - mbVarsM p >>>= \mb_p -> - proveVarImplInt x mb_p >>> - implSwapM x (ValPerm_Conj1 $ Perm_LLVMArray ap') x p >>> - - -- Return the borrowed perm to ap' to get ap - implLLVMArrayReturnBorrow x ap' b +proveVarLLVMArray_FromArray2H x ap_lhs len bs mb_ap + | Just b <- find (flip notElem bs) (llvmArrayBorrows ap_lhs) = + + -- Prove the rest of ap with b borrowed + proveVarLLVMArray_FromArray2 x ap_lhs len (b:bs) mb_ap >>>= \ap' -> + + -- Prove the borrowed perm + let p = permForLLVMArrayBorrow ap' b in + mbVarsM p >>>= \mb_p -> + proveVarImplInt x mb_p >>> + implSwapM x (ValPerm_Conj1 $ Perm_LLVMArray ap') x p >>> + + -- Return the borrowed perm to ap' to get ap + implLLVMArrayReturnBorrow x ap' b >>> + return (ap' { llvmArrayBorrows = bs }) -- If there is a borrow in ap that is not in ap_lhs, borrow it from ap_lhs. Note -- the assymmetry with the previous case: we only add borrows if we definitely -- have to, but we remove borrows if we might have to. -proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs - | Just ap_lhs_cell_off <- llvmArrayIsOffsetArray ap ap_lhs - , Just b <- - find (\b -> - let b' = cellOffsetLLVMArrayBorrow ap_lhs_cell_off b in - bvRangesOverlap (llvmArrayBorrowAbsOffsets ap b) - (llvmArrayAbsOffsets ap_lhs) && - not (elem b' (llvmArrayBorrows ap_lhs))) - (llvmArrayBorrows ap) = +proveVarLLVMArray_FromArray2H x ap_lhs len bs mb_ap + | Just b <- find (flip notElem (llvmArrayBorrows ap_lhs)) bs = -- Prove the rest of ap without b borrowed - let ap' = llvmArrayRemBorrow b ap in - proveVarLLVMArray_ArrayStep x ps ap' i ap_lhs >>> + proveVarLLVMArray_FromArray2 x ap_lhs len (delete b bs) mb_ap >>>= \ap' -> -- Borrow the permission if that is possible; this will fail if ap has a -- borrow that is not actually in its range. Note that the borrow is always -- added to the front of the list of borrows, so we need to rearrange. implLLVMArrayBorrowBorrow x ap' b >>>= \p -> recombinePerm x p >>> - implLLVMArrayRearrange x (llvmArrayAddBorrow b ap') (llvmArrayBorrows ap) - --- If ap and ap_lhs are equal up to the order of their borrows, just rearrange --- the borrows and we should be done -proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs - | bvEq (llvmArrayOffset ap_lhs) (llvmArrayOffset ap) - , bvEq (llvmArrayLen ap_lhs) (llvmArrayLen ap) - , llvmArrayStride ap_lhs == llvmArrayStride ap - , llvmArrayFields ap_lhs == llvmArrayFields ap - , llvmArrayBorrowsPermuteTo ap_lhs (llvmArrayBorrows ap) = - implGetPopConjM x ps i >>> - implLLVMArrayRearrange x ap_lhs (llvmArrayBorrows ap) - --- If ap and ap_lhs have the same range and stride but their fields are --- different, prove the rhs fields from the lhs fields -proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs - | bvEq (llvmArrayOffset ap_lhs) (llvmArrayOffset ap) - , bvEq (llvmArrayLen ap_lhs) (llvmArrayLen ap) - , llvmArrayStride ap_lhs == llvmArrayStride ap - , flds <- llvmArrayFields ap - , flds_lhs <- llvmArrayFields ap_lhs - , ap' <- ap { llvmArrayFields = flds_lhs } - , dps_in <- - nu $ \y -> distPerms1 y $ ValPerm_Conj $ - map llvmArrayFieldToAtomicPerm flds_lhs - , dps_out <- - nu $ \y -> distPerms1 y $ ValPerm_Conj $ - map llvmArrayFieldToAtomicPerm flds = - proveVarLLVMArray_ArrayStep x ps ap' i ap_lhs >>> - localMbProveVars dps_in dps_out >>>= \mb_impl -> - implSimplM Proxy (SImpl_LLVMArrayContents x ap' flds mb_impl) - --- If ap is contained inside ap_lhs at a cell boundary then copy or borrow ap --- from ap_lhs depending on whether they are copyable -proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs - | all bvPropCouldHold (bvPropRangeSubset - (llvmArrayAbsOffsets ap) (llvmArrayAbsOffsets ap_lhs)) - , llvmArrayStride ap_lhs == llvmArrayStride ap - , llvmArrayFields ap_lhs == llvmArrayFields ap - , Just (LLVMArrayIndex _ 0) <- - matchLLVMArrayField ap_lhs (llvmArrayOffset ap) = - implExtractConjM x ps i >>> - implPopM x (ValPerm_Conj $ deleteNth i ps) >>> - if atomicPermIsCopyable (Perm_LLVMArray ap) then - implLLVMArrayCopy x ap_lhs ap >>> - recombinePerm x (ValPerm_Conj1 $ Perm_LLVMArray ap_lhs) - else - implLLVMArrayBorrow x ap_lhs ap >>> - recombinePerm x (ValPerm_Conj1 $ Perm_LLVMArray $ - llvmArrayAddBorrow (llvmSubArrayBorrow ap_lhs ap) ap_lhs) - --- If we get to this case but ap is still at a cell boundary in ap_lhs then --- ap_lhs only satisfies some initial portion of ap, so borrow or copy that part --- of ap_lhs and continue proving the rest of ap -proveVarLLVMArray_ArrayStepH x ps ap i ap_lhs - | llvmArrayStride ap_lhs == llvmArrayStride ap - , llvmArrayFields ap_lhs == llvmArrayFields ap - , Just (LLVMArrayIndex ap_cell_num 0) <- - matchLLVMArrayField ap_lhs (llvmArrayOffset ap) = - - -- Split ap into ap_first = the portion of ap covered by ap_lhs and ap_rest - let (ap_first, ap_rest) = - llvmArrayPermDivide ap (bvSub (llvmArrayLen ap_lhs) ap_cell_num) in - - -- Copy or borrow ap_first from ap_lhs, leaving some ps' on top of the stack - -- and ap_first just below it - implExtractConjM x ps i >>> - implPopM x (ValPerm_Conj $ deleteNth i ps) >>> - (if atomicPermIsCopyable (Perm_LLVMArray ap_first) then - implLLVMArrayCopy x ap_lhs ap_first >>> - implPushM x (ValPerm_Conj $ deleteNth i ps) >>> - implInsertConjM x (Perm_LLVMArray ap_lhs) (deleteNth i ps) i >>> - pure ps - else - implLLVMArrayBorrow x ap_lhs ap_first >>> - implPushM x (ValPerm_Conj $ deleteNth i ps) >>> - let ap_lhs' = - llvmArrayAddBorrow (llvmSubArrayBorrow ap_lhs ap_first) ap_lhs in - implInsertConjM x (Perm_LLVMArray ap_lhs') (deleteNth i ps) i >>> - pure (replaceNth i (Perm_LLVMArray ap_lhs') ps)) >>>= \ps' -> - - -- Recursively prove ap_rest - proveVarLLVMArray x False ps' ap_rest >>> - - -- Combine ap_first and ap_rest to get out ap - implLLVMArrayAppend x ap_first ap_rest - + implLLVMArrayRearrange x (llvmArrayAddBorrow b ap') bs >>> + return (ap' { llvmArrayBorrows = bs }) + +-- If we get here then ap_lhs and ap have the same borrows, offset, length, and +-- stride, so equalize their modalities, prove the shape of mb_ap from that of +-- ap_lhs, rearrange their borrows, and we are done +proveVarLLVMArray_FromArray2H x ap_lhs _ bs mb_ap = + -- Coerce the rw modality of ap_lhs to that of mb_ap, if possibe + equalizeRWs x (\rw -> ValPerm_LLVMArray $ ap_lhs { llvmArrayRW = rw }) + (llvmArrayRW ap_lhs) (mbLLVMArrayRW mb_ap) + (SImpl_DemoteLLVMArrayRW x ap_lhs) >>>= \rw -> + let ap_lhs' = ap_lhs { llvmArrayRW = rw } in + + -- Coerce the lifetime of ap_lhs to that of mb_ap, if possible + let (f, args) = arrayToLTFunc ap_lhs' in + proveVarLifetimeFunctor x f args (llvmArrayLifetime ap_lhs) + (mbLLVMArrayLifetime mb_ap) >>>= \l -> + let ap_lhs'' = ap_lhs' { llvmArrayLifetime = l } in + + -- Coerce the shape of ap_lhs to that of mb_ap, if necessary. Note that all + -- the fields of ap should be defined at this point except possible its cell + -- shape, but we cannot handle instantiating evars inside local implications, + -- so we require it to be defined as well, and we substitute into mb_ap. + partialSubstForceM mb_ap "proveVarLLVMArray: incomplete psubst" >>>= \ap -> + let sh = llvmArrayCellShape ap in + (if sh == llvmArrayCellShape ap_lhs then + -- If the shapes are already equal, do nothing + return ap_lhs'' + else + -- Otherwise, coerce the contents + let dps_in = nu $ \y -> distPerms1 y $ ValPerm_LLVMBlock $ + llvmArrayCellPerm ap_lhs'' $ bvInt 0 + dps_out = nu $ \y -> distPerms1 y $ ValPerm_LLVMBlock $ + llvmArrayCellPerm ap $ bvInt 0 in + localMbProveVars dps_in dps_out >>>= \mb_impl -> + implSimplM Proxy (SImpl_LLVMArrayContents x ap_lhs'' sh mb_impl) >>> + return (ap_lhs'' { llvmArrayCellShape = sh })) >>>= \ap_lhs''' -> --- Otherwise we don't know what to do so we fail -proveVarLLVMArray_ArrayStepH _x _ps _ap _i _ap_lhs = - implFailMsgM "proveVarLLVMArray_ArrayStep" + -- Finally, rearrange the borrows of ap_lhs to match bs + implLLVMArrayRearrange x ap_lhs''' bs >>> + return (ap_lhs''' { llvmArrayBorrows = bs }) ---------------------------------------------------------------------- @@ -5455,6 +5598,8 @@ proveNamedArg x npn args off memb psubst arg = case mbMatch arg of -- * Proving LLVM Block Permissions ---------------------------------------------------------------------- +-- FIXME HERE: maybe use implGetLLVMPermForOffset for proveVarLLVMBlock? + -- | Prove a @memblock@ permission from the conjunction of the supplied atomic -- permissions which are on the top of the stack proveVarLLVMBlock :: @@ -5463,8 +5608,7 @@ proveVarLLVMBlock :: ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () proveVarLLVMBlock x ps mb_bp = do psubst <- getPSubst - proveVarLLVMBlocks x ps psubst [mb_bp] [] - + proveVarLLVMBlocks x ps psubst [mb_bp] -- | Prove a conjunction of block and atomic permissions for @x@, assuming all -- of the permissions for @x@ are on the top of the stack and given by the @@ -5474,34 +5618,33 @@ proveVarLLVMBlock x ps mb_bp = -- A central motivation of this algorithm is to do as little elimination on the -- left or introduction on the right as possible, in order to build the smallest -- derivation we can. The algorithm iterates through the block permissions on --- the right, trying for each of them to either match it up with a block --- permission on the left or simplify it to a non-block permission. The first --- stage of the algorithm attempts to break down permissions on the left that --- overlap with but are not contained in the current block permission on the --- right we are trying to prove, so that we end up with permissions on the left --- that are no bigger than the right. This stage is performed by --- 'proveVarLLVMBlocks1'. The algorithm then repeatedly breaks down the --- right-hand block permission we are trying to prove, going back to stage one --- if necessary if this leads to it being smaller than some left-hand +-- the right, trying for each of them to match it up with a block permission on +-- the left. The first stage of the algorithm attempts to break down permissions +-- on the left that overlap with but are not contained in the current block +-- permission on the right we are trying to prove, so that we end up with +-- permissions on the left that are no bigger than the right. This stage is +-- performed by 'proveVarLLVMBlocks1'. The algorithm then repeatedly breaks down +-- the right-hand block permission we are trying to prove, going back to stage +-- one if necessary if this leads to it being smaller than some left-hand -- permission, until we either get a precise match or we eventually break the --- right-hand permission down to a non-block permission. This stage is performed --- by 'proveVarLLVMBlocks2'. +-- right-hand permission down to block permission whose offset, size, and shape +-- matches one on the left. This stage is performed by 'proveVarLLVMBlocks2'. proveVarLLVMBlocks :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> PartialSubst vars -> - [Mb vars (LLVMBlockPerm w)] -> [Mb vars (AtomicPerm (LLVMPointerType w))] -> + [Mb vars (LLVMBlockPerm w)] -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -proveVarLLVMBlocks x ps psubst mb_bps mb_ps = +proveVarLLVMBlocks x ps psubst mb_bps = -- This substitution is to only print the existential vars once, on the -- outside; also, substituting here ensures that we only traverse the -- permissions once - mbSubstM (\s -> (map s mb_bps, map s mb_ps)) >>>= \mb_bps_ps -> + mbSubstM (\s -> map s mb_bps) >>>= \mb_bps' -> implTraceM (\i -> sep [pretty "proveVarLLVMBlocks", permPretty i x <> colon <> permPretty i ps, - pretty "-o", permPretty i mb_bps_ps]) >>> - proveVarLLVMBlocks1 x ps psubst mb_bps mb_ps + pretty "-o", permPretty i mb_bps']) >>> + proveVarLLVMBlocks1 x ps psubst mb_bps -- | Call 'proveVarLLVMBlock' in a context extended with a fresh existential @@ -5511,12 +5654,12 @@ proveVarLLVMBlocksExt1 :: (1 <= w, KnownNat w, KnownRepr TypeRepr tp, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> PartialSubst vars -> Mb (vars :> tp) (LLVMBlockPerm w) -> - [Mb vars (LLVMBlockPerm w)] -> [Mb vars (AtomicPerm (LLVMPointerType w))] -> + [Mb vars (LLVMBlockPerm w)] -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) (PermExpr tp) -proveVarLLVMBlocksExt1 x ps psubst mb_bp_ext mb_bps mb_ps = +proveVarLLVMBlocksExt1 x ps psubst mb_bp_ext mb_bps = fmap snd $ withExtVarsM $ proveVarLLVMBlocks x ps (extPSubst psubst) - (mb_bp_ext : map extMb mb_bps) (map extMb mb_ps) + (mb_bp_ext : map extMb mb_bps) -- | Like 'proveVarLLVMBlockExt1' but bind 2 existential variables, which can be -- used in 0 or more block permissions we want to prove @@ -5525,32 +5668,51 @@ proveVarLLVMBlocksExt2 :: KnownRepr TypeRepr tp2, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> PartialSubst vars -> Mb (vars :> tp1 :> tp2) [LLVMBlockPerm w] -> - [Mb vars (LLVMBlockPerm w)] -> [Mb vars (AtomicPerm (LLVMPointerType w))] -> + [Mb vars (LLVMBlockPerm w)] -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) (PermExpr tp1, PermExpr tp2) -proveVarLLVMBlocksExt2 x ps psubst mb_bps_ext mb_bps mb_ps = +proveVarLLVMBlocksExt2 x ps psubst mb_bps_ext mb_bps = withExtVarsM (withExtVarsM $ proveVarLLVMBlocks x ps (extPSubst $ extPSubst psubst) - (mbList mb_bps_ext ++ (map (extMb . extMb) mb_bps)) - (map (extMb . extMb) mb_ps)) >>= \((_,e2),e1) -> + (mbList mb_bps_ext ++ (map (extMb . extMb) mb_bps))) >>= \((_,e2),e1) -> pure (e1,e2) +-- | Assume the first block permission is on top of the stack, and attempt to +-- coerce its read-write modality and lifetime to those of the second, leaving +-- the resulting block permission on top of the stack. Return the resulting +-- block permission. +equalizeBlockModalities :: (1 <= w, KnownNat w, NuMatchingAny1 r) => + ExprVar (LLVMPointerType w) -> LLVMBlockPerm w -> + Mb vars (LLVMBlockPerm w) -> + ImplM vars s r + (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) + (LLVMBlockPerm w) +equalizeBlockModalities x bp mb_bp = + equalizeRWs x (\rw -> ValPerm_LLVMBlock $ bp { llvmBlockRW = rw }) + (llvmBlockRW bp) (mbLLVMBlockRW mb_bp) (SImpl_DemoteLLVMBlockRW x bp) + >>>= \rw -> + let bp' = bp { llvmBlockRW = rw } + (f, args) = blockToLTFunc bp' in + proveVarLifetimeFunctor x f args (llvmBlockLifetime bp) + (fmap llvmBlockLifetime mb_bp) >>>= \l -> + return (bp' { llvmBlockLifetime = l }) + -- | Stage 1 of 'proveVarLLVMBlocks'. See that comments on that function. proveVarLLVMBlocks1 :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> PartialSubst vars -> - [Mb vars (LLVMBlockPerm w)] -> [Mb vars (AtomicPerm (LLVMPointerType w))] -> + [Mb vars (LLVMBlockPerm w)] -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () --- If we are done with blocks, call proveVarConjImpl -proveVarLLVMBlocks1 x ps _ [] mb_ps = - mbSubstM (\s -> map s mb_ps) >>>= proveVarConjImpl x ps +-- We are done, yay! Pop ps and build a true permission +proveVarLLVMBlocks1 x ps _ [] = + implPopM x (ValPerm_Conj ps) >>> introConjM x -- If the offset, length, and shape of the top block matches one that we already -- have, just cast the rwmodality and lifetime and prove the remaining perms -proveVarLLVMBlocks1 x ps psubst (mb_bp:mb_bps) mb_ps +proveVarLLVMBlocks1 x ps psubst (mb_bp:mb_bps) | Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp , Just len <- partialSubst psubst $ fmap llvmBlockLen mb_bp , Just i <- findIndex (\case @@ -5562,45 +5724,28 @@ proveVarLLVMBlocks1 x ps psubst (mb_bp:mb_bps) mb_ps _ -> False) ps , Perm_LLVMBlock bp <- ps!!i = - -- Copy or extract the memblock perm we chose to the top of the stack - (if atomicPermIsCopyable (ps!!i) then - implCopySwapConjM x ps i >>> pure ps - else - implExtractSwapConjM x ps i >>> pure (deleteNth i ps)) >>>= \ps' -> - - -- Cast it to have the correct RW modality - (case (llvmBlockRW bp, fmap llvmBlockRW mb_bp) of - -- If the modalities are already equal, do nothing - (rw, mb_rw) | mbLift (fmap (== rw) mb_rw) -> pure () - (_, mbMatch -> [nuMP| PExpr_Read |]) -> - implSimplM Proxy (SImpl_DemoteLLVMBlockRW x bp) - _ -> - proveEqCast x (\rw -> ValPerm_LLVMBlock $ bp { llvmBlockRW = rw }) - (llvmBlockRW bp) (fmap llvmBlockRW mb_bp)) >>> - getTopDistPerm x >>>= \(ValPerm_LLVMBlock bp') -> + -- Move the memblock perm we chose to the top of the stack + implExtractSwapConjM x ps i >>> + let ps' = deleteNth i ps in - -- Get the lifetime correct - let (f, args) = blockToLTFunc bp' in - proveVarLifetimeFunctor x f args (llvmBlockLifetime bp) (fmap - llvmBlockLifetime - mb_bp) >>> - getTopDistPerm x >>>= \(ValPerm_LLVMBlock bp'') -> + -- Make the input block have the required modalities + equalizeBlockModalities x bp mb_bp >>>= \bp' -> -- Move it down below ps' - implSwapM x (ValPerm_Conj ps') x (ValPerm_LLVMBlock bp'') >>> + implSwapM x (ValPerm_Conj ps') x (ValPerm_LLVMBlock bp') >>> -- Recursively prove the remaining perms - proveVarLLVMBlocks x ps' psubst mb_bps mb_ps >>> + proveVarLLVMBlocks x ps' psubst mb_bps >>> getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> -- Finally, combine the one memblock perm we chose with the rest of them - implInsertConjM x (Perm_LLVMBlock bp'') ps_out 0 + implInsertConjM x (Perm_LLVMBlock bp') ps_out 0 -- If the offset and length of the top block matches one that we already have on -- the left, but the left-hand permission has a defined shape, unfold the -- defined shape -proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps +proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) | Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp , Just len <- partialSubst psubst $ fmap llvmBlockLen mb_bp , Just i <- findIndex @@ -5612,14 +5757,14 @@ proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps bvEq (llvmBlockLen bp) len _ -> False) ps = implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst mb_bps_in mb_ps + proveVarLLVMBlocks x ps' psubst mb_bps_in -- If the offset and length of the top block matches one that we already have on -- the left, but the left-hand permission has an unneeded empty shape at the -- end, i.e., is of the form sh;emptysh where the natural length of sh is the -- length of the left-hand permission, remove that trailing empty shape -proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps +proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) | Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp , Just len <- partialSubst psubst $ fmap llvmBlockLen mb_bp , Just i <- findIndex @@ -5632,7 +5777,7 @@ proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps bvEq len len' _ -> False) ps = implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst mb_bps_in mb_ps + proveVarLLVMBlocks x ps' psubst mb_bps_in -- If there is a left-hand permission with empty shape whose range overlaps with @@ -5640,7 +5785,7 @@ proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps -- in or disjoint from the range of mb_bp; i.e., split it at the beginning -- and/or end of mb_bp. We exclude mb_bp with length 0 as a pathological edge -- case. -proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps +proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) | Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp , Just len <- partialSubst psubst $ fmap llvmBlockLen mb_bp , rng <- BVRange off len @@ -5648,7 +5793,7 @@ proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps , Just i <- findIndex (\case Perm_LLVMBlock bp -> llvmBlockShape bp == PExpr_EmptyShape && - bvRangesCouldOverlap (llvmBlockRange bp) rng && + bvRangesOverlap (llvmBlockRange bp) rng && not (bvRangeSubset (llvmBlockRange bp) rng) _ -> False) ps , Perm_LLVMBlock bp <- ps!!i = @@ -5662,32 +5807,32 @@ proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps implSimplM Proxy (SImpl_SplitLLVMBlockEmpty x bp len1) >>> getTopDistPerm x >>>= \(ValPerm_Conj ps') -> implAppendConjsM x (deleteNth i ps) ps' >>> - proveVarLLVMBlocks x (deleteNth i ps ++ ps') psubst mb_bps_in mb_ps + proveVarLLVMBlocks x (deleteNth i ps ++ ps') psubst mb_bps_in -- If there is a left-hand permission whose range overlaps with but is not -- contained in that of mb_bp, eliminate it. Note that we exclude mb_bp with -- length 0 for this case, since eliminating on the left does not help prove -- these permissions. -proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) mb_ps - | Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp - , Just len <- partialSubst psubst $ fmap llvmBlockLen mb_bp +proveVarLLVMBlocks1 x ps psubst mb_bps_in@(mb_bp:_) + | Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp + , Just len <- partialSubst psubst $ mbLLVMBlockLen mb_bp , not (bvIsZero len) , rng <- BVRange off len , Just i <- findIndex (\case Perm_LLVMBlock bp -> - bvRangesCouldOverlap (llvmBlockRange bp) rng && + bvRangesOverlap (llvmBlockRange bp) rng && not (bvRangeSubset (llvmBlockRange bp) rng) _ -> False) ps = implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst mb_bps_in mb_ps + proveVarLLVMBlocks x ps' psubst mb_bps_in -- If none of the above cases match for stage 1, proceed to stage 2, which -- operates by induction on the shape -proveVarLLVMBlocks1 x ps psubst (mb_bp:mb_bps) mb_ps = +proveVarLLVMBlocks1 x ps psubst (mb_bp:mb_bps) = proveVarLLVMBlocks2 x ps psubst mb_bp (mbMatch $ - fmap llvmBlockShape mb_bp) mb_bps mb_ps + mbLLVMBlockShape mb_bp) mb_bps -- | Stage 2 of 'proveVarLLVMBlocks'. See that comments on that function. The @@ -5696,18 +5841,18 @@ proveVarLLVMBlocks2 :: (1 <= w, KnownNat w, NuMatchingAny1 r) => ExprVar (LLVMPointerType w) -> [AtomicPerm (LLVMPointerType w)] -> PartialSubst vars -> Mb vars (LLVMBlockPerm w) -> MatchedMb vars (PermExpr (LLVMShapeType w)) -> - [Mb vars (LLVMBlockPerm w)] -> [Mb vars (AtomicPerm (LLVMPointerType w))] -> + [Mb vars (LLVMBlockPerm w)] -> ImplM vars s r (ps :> LLVMPointerType w) (ps :> LLVMPointerType w) () -- If proving the empty shape for length 0, recursively prove everything else -- and then use the empty introduction rule -proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps | Just len <- partialSubst psubst $ fmap llvmBlockLen mb_bp , bvIsZero len = -- Do the recursive call without the empty shape and remember what -- permissions it proved - proveVarLLVMBlocks x ps psubst mb_bps mb_ps >>> + proveVarLLVMBlocks x ps psubst mb_bps >>> getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> -- Substitute into the required block perm and prove it with @@ -5724,12 +5869,12 @@ proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps mb_ps -- If proving the empty shape otherwise, prove an arbitrary memblock permission, -- i.e., with shape y for evar y, and coerce it to the empty shape -proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps mb_ps = +proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps = -- Locally bind z_sh for the shape of the memblock perm and recurse let mb_bp' = mbCombine RL.typeCtxProxies $ flip fmap mb_bp $ \bp -> nu $ \z_sh -> bp { llvmBlockShape = PExpr_Var z_sh } in - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps mb_ps >>> + proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>> -- Extract out the block perm we proved and coerce it to the empty shape getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> @@ -5746,7 +5891,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp [nuMP| PExpr_EmptyShape |] mb_bps mb_ps = -- not match the above cases) whose length is longer than the natural length of -- its shape, prove the memblock with the natural length as well as an -- additional memblock with empty shape and then sequence them together. -proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps | Just len <- partialSubst psubst (fmap llvmBlockLen mb_bp) , mbLift $ fmap (maybe False (`bvLt` len) . llvmShapeLength . llvmBlockShape) mb_bp = @@ -5761,7 +5906,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps mb_ps llvmBlockShape = PExpr_EmptyShape }]) mb_bp in -- Next, do the recursive call - proveVarLLVMBlocks x ps psubst (mbList mb_bps' ++ mb_bps) mb_ps >>> + proveVarLLVMBlocks x ps psubst (mbList mb_bps' ++ mb_bps) >>> -- Move the correctly-sized perm + the empty shape one to the top of the -- stack and sequence them, and then eliminate the empty shape at the end @@ -5779,7 +5924,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps mb_ps -- For an unfoldable named shape, prove its unfolding first and then fold it -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_NamedShape rw l nmsh args |] <- mb_sh , [nuMP| TrueRepr |] <- mbMatch $ fmap namedShapeCanUnfoldRepr nmsh , [nuMP| Just mb_sh' |] <- mbMatch $ (mbMap3 unfoldModalizeNamedShape rw l nmsh @@ -5789,7 +5934,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps else return ()) >>> let mb_bp' = mbMap2 (\bp sh' -> (bp { llvmBlockShape = sh' })) mb_bp mb_sh' in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) mb_ps >>> + proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> -- Extract out the block perm we proved getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> @@ -5810,7 +5955,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- permission is to have it on the left, but we don't have a memblock permission -- on the left with this exact offset, length, and shape, because it would have -- matched some previous case, so try to eliminate a memblock and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_NamedShape _ _ nmsh _ |] <- mb_sh , [nuMP| FalseRepr |] <- mbMatch $ fmap namedShapeCanUnfoldRepr nmsh , Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp @@ -5820,24 +5965,23 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps _ -> False) ps , Perm_LLVMBlock _ <- ps!!i = implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst (mb_bp:mb_bps) mb_ps + proveVarLLVMBlocks x ps' psubst (mb_bp:mb_bps) -- If proving an equality shape eqsh(z) for evar z which has already been set, -- substitute for z and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_EqShape (PExpr_Var mb_z) |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Just blk <- psubstLookup psubst memb = proveVarLLVMBlocks x ps psubst (fmap (\bp -> bp { llvmBlockShape = PExpr_EqShape blk }) mb_bp : mb_bps) - mb_ps -- If proving an equality shape eqsh(z) for unset evar z, prove any memblock -- perm with the given offset and length and eliminate it to an llvmblock with -- an equality shape -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_EqShape (PExpr_Var mb_z) |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Nothing <- psubstLookup psubst memb = @@ -5846,7 +5990,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps let mb_bp' = mbCombine RL.typeCtxProxies $ flip fmap mb_bp $ \bp -> nu $ \z_sh -> bp { llvmBlockShape = PExpr_Var z_sh } in - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps mb_ps >>> + proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>> -- Extract out the block perm we proved getTopDistPerm x >>>= \(ValPerm_Conj ps_out) -> @@ -5867,7 +6011,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- have it on the left, but we don't have a memblock permission on the left with -- this exactly offset, length, and shape, because it would have matched the -- first case above, so try to eliminate a memblock and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_EqShape (PExpr_Var mb_z) |] <- mb_sh , Right _ <- mbNameBoundP mb_z , Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp @@ -5877,97 +6021,75 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps _ -> False) ps , Perm_LLVMBlock _ <- ps!!i = implElimAppendIthLLVMBlock x ps i >>>= \ps' -> - proveVarLLVMBlocks x ps' psubst (mb_bp:mb_bps) mb_ps - - --- If proving a pointer shape, prove the required permission by adding it to ps; --- this requires the pointed-to shape to have a well-defined length -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps - | [nuMP| PExpr_PtrShape mb_rw mb_l mb_sh' |] <- mb_sh - , mbLift $ fmap (isJust . llvmShapeLength) mb_sh' = - - -- Add a permission for a pointer to the required shape to mb_ps, and - -- recursively call proveVarLLVMBlocks to prove it and everything else - let mb_p_ptr = - mbMap4 (\bp maybe_rw maybe_l sh -> - (llvmBlockPtrAtomicPerm $ - llvmBlockAdjustModalities maybe_rw maybe_l $ - bp { llvmBlockLen = fromJust (llvmShapeLength sh), - llvmBlockShape = sh })) - mb_bp mb_rw mb_l mb_sh' in - proveVarLLVMBlocks x ps psubst mb_bps (mb_p_ptr:mb_ps) >>> + proveVarLLVMBlocks x ps' psubst (mb_bp:mb_bps) + + +-- If proving a pointer shape, prove the 'llvmBlockPtrShapeUnfold' permission, +-- assuming it is defined +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps + | [nuMP| PExpr_PtrShape _ _ _ |] <- mb_sh + , [nuP| Just mb_bp' |] <- mbMapCl $(mkClosed + [| llvmBlockPtrShapeUnfold |]) mb_bp = + + -- Recursively prove the required field permission and all the other block + -- permissions + proveVarLLVMBlocks x ps psubst (mb_bp':mb_bps) >>> -- Move the pointer permission we proved to the top of the stack getTopDistPerm x >>>= \(ValPerm_Conj ps') -> - let i = length mb_bps in - implExtractSwapConjM x ps' i >>> + implExtractSwapConjM x ps' 0 >>> -- Use the SImpl_IntroLLVMBlockPtr rule to prove the required memblock perm partialSubstForceM mb_bp "proveVarLLVMBlocks" >>>= \bp -> - let PExpr_PtrShape maybe_rw maybe_l sh = llvmBlockShape bp in - let Just sh_len = llvmShapeLength sh in - implSimplM Proxy (SImpl_IntroLLVMBlockPtr x maybe_rw maybe_l $ - bp { llvmBlockLen = sh_len, llvmBlockShape = sh }) >>> + implSimplM Proxy (SImpl_IntroLLVMBlockPtr x bp) >>> -- Finally, move the memblock perm we proved back into position - implSwapInsertConjM x (Perm_LLVMBlock bp) (deleteNth i ps') 0 - + implSwapInsertConjM x (Perm_LLVMBlock bp) (tail ps') 0 --- If proving a field shape, prove the required permission by adding it to ps -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps - | [nuMP| PExpr_FieldShape (LLVMFieldShape mb_p) |] <- mb_sh = - -- Add the field permission to the required permission to mb_ps, and - -- recursively call proveVarLLVMBlocks to prove it and everything else - let mb_fp = - mbMap2 (\bp p -> - (llvmBlockPtrFieldPerm bp) { llvmFieldContents = p }) - mb_bp mb_p in - let mb_p' = fmap Perm_LLVMField mb_fp in - proveVarLLVMBlocks x ps psubst mb_bps (mb_p':mb_ps) >>> +-- If proving a field shape, prove the remaining blocks and then prove the +-- corresponding field permission +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps + | [nuMP| PExpr_FieldShape (LLVMFieldShape mb_p) |] <- mb_sh + , sz <- mbExprLLVMTypeWidth mb_p + , [nuP| Just mb_fp |] <- mbMapCl ($(mkClosed [| llvmBlockPermToField |]) + `clApply` toClosed sz) mb_bp = - -- Move the pointer permission we proved to the top of the stack + -- Recursively prove the remaining block permissions + proveVarLLVMBlocks x ps psubst mb_bps >>> getTopDistPerm x >>>= \(ValPerm_Conj ps') -> - let i = length mb_bps in - implExtractSwapConjM x ps' i >>> - -- Use the SImpl_IntroLLVMBlockField rule to prove the required memblock perm - partialSubstForceM (mbMap2 (,) - mb_bp mb_fp) "proveVarLLVMBlocks" >>>= \(bp,fp) -> + -- Prove the corresponding field permission + proveVarImplInt x (mbValPerm_LLVMField mb_fp) >>> + getTopDistPerm x >>>= \(ValPerm_LLVMField fp) -> + + -- Finally, convert the field perm to a block and move it into position implSimplM Proxy (SImpl_IntroLLVMBlockField x fp) >>> - - -- Finally, move the memblock perm we proved back into position - implSwapInsertConjM x (Perm_LLVMBlock bp) (deleteNth i ps') 0 + implSwapInsertConjM x (Perm_LLVMBlock $ llvmFieldPermToBlock fp) ps' 0 --- If proving an array shape, just like in the field case, prove the required --- array permission and then pad it out with an empty memblock permission -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +-- If proving a field shape, prove the remaining blocks and then prove the +-- corresponding array permission +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_ArrayShape _ _ _ |] <- mb_sh = - - -- Add the array permission to the required permission to mb_ps, and - -- recursively call proveVarLLVMBlocks to prove it and everything else - let mb_ap = fmap llvmArrayBlockToArrayPerm mb_bp in - let mb_p = fmap Perm_LLVMArray mb_ap in - proveVarLLVMBlocks x ps psubst mb_bps (mb_p:mb_ps) >>> - - -- Move the pointer permission we proved to the top of the stack + -- Recursively prove the remaining block permissions + proveVarLLVMBlocks x ps psubst mb_bps >>> getTopDistPerm x >>>= \(ValPerm_Conj ps') -> - let i = length mb_bps in - implExtractSwapConjM x ps' i >>> - -- Use the SImpl_IntroLLVMBlockArray rule to prove the memblock perm - partialSubstForceM (mbMap2 (,) - mb_bp mb_ap) "proveVarLLVMBlocks" >>>= \(bp,ap) -> + -- Prove the corresponding array permission + proveVarImplInt x (mbMapCl $(mkClosed [| ValPerm_LLVMArray . fromJust . + llvmBlockPermToArray |]) mb_bp) >>> + getTopDistPerm x >>>= \(ValPerm_LLVMArray ap) -> + + -- Finally, convert the array perm to a block and move it into position implSimplM Proxy (SImpl_IntroLLVMBlockArray x ap) >>> - - -- Finally, move the memblock perm we proved back into position - implSwapInsertConjM x (Perm_LLVMBlock bp) (deleteNth i ps') 0 + implSwapInsertConjM x (Perm_LLVMBlock $ fromJust $ + llvmArrayPermToBlock ap) ps' 0 -- If proving a sequence shape, prove the two shapes and combine them; this -- requires the first shape to have a well-defined length -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_SeqShape mb_sh1 _ |] <- mb_sh , mbLift $ fmap (isJust . llvmShapeLength) mb_sh1 = @@ -5980,7 +6102,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) len1, llvmBlockLen = bvSub (llvmBlockLen bp) len1, llvmBlockShape = sh2 }]) mb_bp in - proveVarLLVMBlocks x ps psubst (mbList mb_bps12 ++ mb_bps) mb_ps >>> + proveVarLLVMBlocks x ps psubst (mbList mb_bps12 ++ mb_bps) >>> -- Move the block permissions we proved to the top of the stack getTopDistPerm x >>>= \(ValPerm_Conj ps') -> @@ -5998,36 +6120,56 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps implSwapInsertConjM x (Perm_LLVMBlock bp) ps'' 0 --- If proving a tagged union shape where we have an equality permission on the --- left that matches one of the disjuncts, prove that disjunct and or it up with --- the other disjuncts -proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps mb_ps - | [nuMP| Just mb_tag_u |] <- mbMatch $ fmap (asTaggedUnionShape - . llvmBlockShape) mb_bp - , Just off <- partialSubst psubst $ fmap llvmBlockOffset mb_bp - , Just i <- mbLift $ fmap (findTaggedUnionIndexForPerms off ps) mb_tag_u - , mb_shs <- fmap taggedUnionDisjs mb_tag_u - , mb_sh <- fmap (!!i) mb_shs = +-- If proving a tagged union shape, first prove an equality permission for the +-- tag and then use that equality permission to +proveVarLLVMBlocks2 x ps psubst mb_bp _ mb_bps + | Just [nuP| SomeTaggedUnionShape mb_tag_u |] <- mbLLVMBlockToTaggedUnion mb_bp + , mb_shs <- mbTaggedUnionDisjs mb_tag_u + , mb_tag_fp <- mbTaggedUnionExTagPerm mb_bp + , Just off <- partialSubst psubst $ mbLLVMBlockOffset mb_bp = - -- Recursively prove the ith disjunct - proveVarLLVMBlocks x ps psubst - (mbMap2 (\bp sh -> bp { llvmBlockShape = sh }) mb_bp mb_sh : mb_bps) - mb_ps >>> + -- Prove permission x:ptr((R,off) |-> eq(z)) with existential variable z to + -- get the tag value for the tagged union, then take it off the stack + withExtVarsM (proveVarLLVMField x ps off mb_tag_fp) >>>= \((), e_tag) -> + getTopDistPerm x >>>= \p' -> + recombinePerm x p' >>> + + -- Find the disjunct corresponding to e_tag, if there is one; otherwise, we + -- don't know which disjunct to use, so return each of them in turn, + -- combining them with implCatchM + (getEqualsExpr e_tag >>>= \case + (bvMatchConst -> Just tag_bv) + | Just i <- mbFindTaggedUnionIndex tag_bv mb_tag_u -> return i + _ -> + let len = + mbLift $ mbMapCl $(mkClosed [| length . + taggedUnionDisjs |]) mb_tag_u in + foldr1 implCatchM $ map return [0..len-1]) >>>= \i -> + + -- Get the permissions we now have for x and push them back to the top of + -- the stack + getAtomicPerms x >>>= \ps' -> + implPushM x (ValPerm_Conj ps') >>> + + -- Recursively prove the ith disjunct and all the rest of mb_bps + let mb_sh = mbTaggedUnionNthDisj i mb_tag_u in + proveVarLLVMBlocks x ps' psubst + (mbMap2 (\bp sh -> bp { llvmBlockShape = sh }) mb_bp mb_sh : mb_bps) >>> -- Move the block permission with shape mb_sh to the top of the stack - getTopDistPerm x >>>= \(ValPerm_Conj ps') -> - implExtractSwapConjM x ps' 0 >>> + getTopDistPerm x >>>= \(ValPerm_Conj ps'') -> + implExtractSwapConjM x ps'' 0 >>> -- Finally, weaken the block permission to be the desired tagged union -- shape, and move it back into position partialSubstForceM mb_shs "proveVarLLVMBlock" >>>= \shs -> partialSubstForceM mb_bp "proveVarLLVMBlock" >>>= \bp -> implIntroOrShapeMultiM x bp shs i >>> - implSwapInsertConjM x (Perm_LLVMBlock bp) (tail ps') 0 + implSwapInsertConjM x (Perm_LLVMBlock bp) (tail ps'') 0 -- If proving a disjunctive shape, try to prove one of the disjuncts -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_OrShape mb_sh1 mb_sh2 |] <- mb_sh = -- Build a computation that tries returning True here, and if that fails @@ -6037,7 +6179,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- Prove the chosen shape by recursively calling proveVarLLVMBlocks let mb_sh' = if is_case1 then mb_sh1 else mb_sh2 in let mb_bp' = mbMap2 (\bp sh -> bp { llvmBlockShape = sh }) mb_bp mb_sh' in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) mb_ps >>> + proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) >>> -- Move the block permission we proved to the top of the stack getTopDistPerm x >>>= \(ValPerm_Conj ps') -> @@ -6058,7 +6200,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- If proving an existential shape, introduce an evar and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_ExShape mb_mb_sh' |] <- mb_sh = -- Prove the sub-shape in the context of a new existential variable @@ -6067,7 +6209,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps mbMap2 (\bp mb_sh' -> fmap (\sh -> bp { llvmBlockShape = sh }) mb_sh') mb_bp mb_mb_sh' in - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps mb_ps >>>= \e -> + proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>>= \e -> -- Move the block permission we proved to the top of the stack getTopDistPerm x >>>= \(ValPerm_Conj ps') -> @@ -6086,17 +6228,17 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- If proving an evar shape that has already been set, substitute and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_Var mb_z |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Just sh <- psubstLookup psubst memb = let mb_bp' = fmap (\bp -> bp { llvmBlockShape = sh }) mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) mb_ps + proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) -- If z is unset and len == 0, just set z to the empty shape and recurse in -- order to call the len == 0 empty shape case above -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_Var mb_z |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Nothing <- psubstLookup psubst memb @@ -6104,13 +6246,13 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps , bvIsZero len = setVarM memb PExpr_EmptyShape >>> let mb_bp' = fmap (\bp -> bp { llvmBlockShape = PExpr_EmptyShape }) mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) mb_ps + proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) -- If z is unset and there is a field permission with the required offset and -- length, set z to a field shape with equality permission to an existential -- variable, which is the most general field permission we can make -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_Var mb_z |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Nothing <- psubstLookup psubst memb @@ -6127,7 +6269,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps bp { llvmBlockShape = PExpr_FieldShape $ LLVMFieldShape $ ValPerm_Eq $ PExpr_Var y } in - proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps mb_ps >>>= \e -> + proveVarLLVMBlocksExt1 x ps psubst mb_bp' mb_bps >>>= \e -> -- Set z = fieldsh(eq(e)) where e was the value we determined for y; -- otherwise we are done, because our required block perm is already proved @@ -6138,7 +6280,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- If z is unset and there is an atomic permission with the required offset and -- length (which is not a field permission, because otherwise the previous case -- would match), set z to the shape of that atomic permission and recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_Var mb_z |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Nothing <- psubstLookup psubst memb @@ -6151,7 +6293,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps setVarM memb sh_lhs >>> let mb_bp' = fmap (\bp -> bp { llvmBlockShape = sh_lhs }) mb_bp in - proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) mb_ps + proveVarLLVMBlocks x ps psubst (mb_bp' : mb_bps) -- If z is unset and there is an atomic permission with the required offset (but @@ -6159,7 +6301,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps -- case), split our memblock permission into two memblock permissions with -- unknown shapes but where the first has the length of this atomic permission -- (so the previous case will match), and then recurse -proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps +proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps | [nuMP| PExpr_Var mb_z |] <- mb_sh , Left memb <- mbNameBoundP mb_z , Nothing <- psubstLookup psubst memb @@ -6178,7 +6320,7 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps bp { llvmBlockOffset = bvAdd (llvmBlockOffset bp) len1, llvmBlockLen = bvSub (llvmBlockLen bp) len1, llvmBlockShape = PExpr_Var z_sh2 }] in - proveVarLLVMBlocksExt2 x ps psubst mb_bps12 mb_bps mb_ps >>> + proveVarLLVMBlocksExt2 x ps psubst mb_bps12 mb_bps >>> -- Move the two block permissions we proved to the top of the stack getTopDistPerm x >>>= \(ValPerm_Conj ps_ret) -> @@ -6199,50 +6341,84 @@ proveVarLLVMBlocks2 x ps psubst mb_bp mb_sh mb_bps mb_ps implSwapInsertConjM x (Perm_LLVMBlock bp) ps_ret' 0 -proveVarLLVMBlocks2 x ps _ mb_bp _ mb_bps mb_ps = - mbSubstM (\s -> - ValPerm_Conj (map (Perm_LLVMBlock . s) (mb_bp:mb_bps) - ++ map s mb_ps)) >>>= \mb_bps_ps -> - implFailVarM "proveVarLLVMBlock" x (ValPerm_Conj ps) mb_bps_ps +proveVarLLVMBlocks2 x ps _ mb_bp _ mb_bps = + mbSubstM (\s -> ValPerm_Conj (map (Perm_LLVMBlock . s) + (mb_bp:mb_bps))) >>>= \mb_bps' -> + implFailVarM "proveVarLLVMBlock" x (ValPerm_Conj ps) mb_bps' ---------------------------------------------------------------------- -- * Proving and Eliminating Recursive Permissions ---------------------------------------------------------------------- --- | Prove @x:p1 |- x:p2@ by unfolding a foldable named permission in @p1@ and --- then recursively proving @x:p2@ from the resulting permissions. If an 'Int' --- @i@ is supplied, then @p1@ is a conjunctive permission whose @i@th conjunct --- is the named permisison to be unfolded; otherwise @p1@ itself is the named --- permission to be unfolded. Assume that @x:p1@ is on top of the stack. -proveVarImplUnfoldLeft :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> - Mb vars (ValuePerm a) -> - Maybe Int -> ImplM vars s r (ps :> a) (ps :> a) () - -proveVarImplUnfoldLeft x (ValPerm_Named npn args off) mb_p Nothing +-- | Assuming @x:p1@ is on top of the stack, unfold a foldable named permission +-- in @p1@. If an 'Int' @i@ is supplied, then @p1@ is a conjunctive permission +-- whose @i@th conjunct is the named permisison to be unfolded; otherwise @p1@ +-- itself is the named permission to be unfolded. Leave the resulting unfolded +-- permission on top of the stack, recombining any additional permissions (in +-- the former case, where a single conjunct is unfolded) back into the primary +-- permissions of @x@, and return that unfolded permission. +implUnfoldLeft :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> + Maybe Int -> ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) +implUnfoldLeft x (ValPerm_Named npn args off) Nothing | TrueRepr <- nameCanFoldRepr npn = (case namedPermNameSort npn of RecursiveSortRepr _ _ -> implSetRecRecurseLeftM _ -> pure ()) >>> implUnfoldNamedM x npn args off >>>= \p' -> - implPopM x p' >>> - proveVarImplInt x mb_p - -proveVarImplUnfoldLeft x (ValPerm_Conj ps) mb_p (Just i) + return p' +implUnfoldLeft x (ValPerm_Conj ps) (Just i) | i < length ps , Perm_NamedConj npn args off <- ps!!i , TrueRepr <- nameCanFoldRepr npn = (case namedPermNameSort npn of RecursiveSortRepr _ _ -> implSetRecRecurseLeftM _ -> pure ()) >>> - implExtractConjM x ps i >>> implPopM x (ValPerm_Conj $ deleteNth i ps) >>> + implExtractConjM x ps i >>> + recombinePerm x (ValPerm_Conj $ deleteNth i ps) >>> implNamedFromConjM x npn args off >>> implUnfoldNamedM x npn args off >>>= \p' -> - recombinePerm x p' >>> - proveVarImplInt x mb_p + return p' +implUnfoldLeft _ _ _ = error ("implUnfoldLeft: malformed inputs") + + +-- | Assume that @x:(p1 * ... * pn)@ is on top of the stack, and try to find +-- some @pi@ that can be unfolded. If successful, recombine the remaining @pj@ +-- to the primary permission for @x@, unfold @pi@, leave it on top of the stack, +-- and return its unfolded permission. Otherwise fail using 'implFailVarM', +-- citing the supplied permission in binding as the one we were trying to prove. +implUnfoldOrFail :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> + Mb vars (ValuePerm a) -> + ImplM vars s r (ps :> a) (ps :> a) (ValuePerm a) +implUnfoldOrFail x ps mb_p = + let p_l = ValPerm_Conj ps in + use implStateRecRecurseFlag >>= \flag -> + case () of + -- We can always unfold a defined name on the left + _ | Just i <- findIndex isDefinedConjPerm ps -> + implUnfoldLeft x p_l (Just i) -proveVarImplUnfoldLeft _ _ _ _ = - error ("proveVarImplUnfoldLeft: malformed inputs") + -- If flag allows it, we can unfold a recursive name on the left + _ | Just i <- findIndex isRecursiveConjPerm ps + , flag /= RecRight -> + implUnfoldLeft x p_l (Just i) + + -- Otherwise, we fail + _ -> implFailVarM "implUnfoldOrFail" x p_l mb_p + + +-- | Prove @x:p1 |- x:p2@ by unfolding a foldable named permission in @p1@ and +-- then recursively proving @x:p2@ from the resulting permissions. If an 'Int' +-- @i@ is supplied, then @p1@ is a conjunctive permission whose @i@th conjunct +-- is the named permisison to be unfolded; otherwise @p1@ itself is the named +-- permission to be unfolded. Assume that @x:p1@ is on top of the stack. +proveVarImplUnfoldLeft :: NuMatchingAny1 r => ExprVar a -> ValuePerm a -> + Mb vars (ValuePerm a) -> + Maybe Int -> ImplM vars s r (ps :> a) (ps :> a) () + +proveVarImplUnfoldLeft x p mb_p maybe_i = + implUnfoldLeft x p maybe_i >>>= \p' -> recombinePerm x p' >>> + proveVarImplInt x mb_p -- | Prove @x:p1 |- x:P\@off@ where @P@ is foldable by first proving the @@ -6278,21 +6454,9 @@ proveVarAtomicImplUnfoldOrFail :: NuMatchingAny1 r => ExprVar a -> [AtomicPerm a] -> Mb vars (AtomicPerm a) -> ImplM vars s r (ps :> a) (ps :> a) () proveVarAtomicImplUnfoldOrFail x ps mb_ap = - do let p_l = ValPerm_Conj ps - mb_p_r = fmap ValPerm_Conj1 mb_ap - flag <- use implStateRecRecurseFlag - case () of - -- We can always unfold a defined name on the left - _ | Just i <- findIndex isDefinedConjPerm ps -> - proveVarImplUnfoldLeft x p_l mb_p_r (Just i) - - -- If flag allows it, we can unfold a recursive name on the left - _ | Just i <- findIndex isRecursiveConjPerm ps - , flag /= RecRight -> - proveVarImplUnfoldLeft x p_l mb_p_r (Just i) - - -- Otherwise, we fail - _ -> implFailVarM "proveVarAtomicImpl" x p_l mb_p_r + let mb_p = mbValPerm_Conj1 mb_ap in + implUnfoldOrFail x ps mb_p >>>= \p' -> recombinePerm x p' >>> + proveVarImplInt x mb_p -- | Prove @x:(p1 * ... * pn) |- x:p@ for some atomic permission @p@, assuming @@ -6308,23 +6472,10 @@ proveVarAtomicImpl :: proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of [nuMP| Perm_LLVMField mb_fp |] -> - partialSubstForceM (fmap llvmFieldOffset mb_fp) "proveVarPtrPerms" >>>= \off -> - foldMapWithDefault implCatchM - (proveVarAtomicImplUnfoldOrFail x ps mb_p) - (\(i,_) -> proveVarLLVMField x ps i off mb_fp) $ - -- If there are any permissions that definitely contain off, use those, and - -- otherwise iterate through all those that could contain off - let ixs_props = findMaybeIndices (llvmPermContainsOffset off) ps in - case filter (\(_,props) -> all bvPropHolds props) ixs_props of - [] -> ixs_props - ixs_props_hold -> ixs_props_hold - - [nuMP| Perm_LLVMArray mb_ap |] -> - partialSubstForceM mb_ap "proveVarPtrPerms" >>>= \ap -> - proveVarLLVMArray x True ps ap - - [nuMP| Perm_LLVMBlock mb_bp |] -> - proveVarLLVMBlock x ps mb_bp + partialSubstForceM (mbLLVMFieldOffset mb_fp) "proveVarPtrPerms" >>>= \off -> + proveVarLLVMField x ps off mb_fp + [nuMP| Perm_LLVMArray mb_ap |] -> proveVarLLVMArray x True ps mb_ap + [nuMP| Perm_LLVMBlock mb_bp |] -> proveVarLLVMBlock x ps mb_bp [nuMP| Perm_LLVMFree mb_e |] -> partialSubstForceM mb_e "proveVarAtomicImpl" >>>= \e -> @@ -6417,9 +6568,6 @@ proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of let mb_ps_inL = fmap (const ps_inL) mb_ps_inR in solveForPermListImpl ps_inR mb_ps_inL >>>= \(Some neededs1) -> solveForPermListImpl ps_outL mb_ps_outR >>>= \(Some neededs2) -> - uses implStateVars cruCtxProxies >>>= \prxs -> - let mb_ps1 = neededPermsToExDistPerms prxs neededs1 - mb_ps2 = neededPermsToExDistPerms prxs neededs2 in -- Prove ps1 and ps2, which can have evars, and then look at the -- substitution instances of ps1 and ps2 that were actually proved on top @@ -6428,7 +6576,7 @@ proveVarAtomicImpl x ps mb_p = case mbMatch mb_p of -- on the LHSs and not arbitrary expressions getDistPerms >>>= \ps0_with_a -> let ps0 = RL.tail ps0_with_a in - proveVarsImplAppendInt (mbMap2 RL.append mb_ps1 mb_ps2) >>> + proveNeededPerms (RL.append neededs1 neededs2) >>> getTopDistPerms ps0_with_a (RL.append neededs1 neededs2) >>>= \ps12 -> let (ps1,ps2) = RL.split neededs1 neededs2 ps12 in partialSubstForceM mb_ps_outR "proveVarAtomicImpl" >>>= \ps_outR -> @@ -7094,9 +7242,8 @@ localProveVars ps_in ps_out = -- | Prove one sequence of permissions over an extended set of local variables -- from another and capture the proof as a 'LocalPermImpl' in a binding -localMbProveVars :: NuMatchingAny1 r => - Mb (ctx :: RList CrucibleType) (DistPerms ps_in) -> - Mb ctx (DistPerms ps_out) -> +localMbProveVars :: NuMatchingAny1 r => KnownRepr CruCtx ctx => + Mb ctx (DistPerms ps_in) -> Mb ctx (DistPerms ps_out) -> ImplM vars s r ps ps (Mb ctx (LocalPermImpl ps_in ps_out)) localMbProveVars mb_ps_in mb_ps_out = implTraceM (\i -> sep [pretty "localMbProveVars:", permPretty i mb_ps_in, diff --git a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs index d739d24ce8..f43ede3746 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/LLVMGlobalConst.hs @@ -87,16 +87,9 @@ translateLLVMValue w _ (L.ValSymbol sym) = return (PExpr_FieldShape (LLVMFieldShape p), t) translateLLVMValue w _ (L.ValArray tp elems) = do - -- First, translate the elements + -- First, translate the elements and their type ts <- map snd <$> mapM (translateLLVMValue w tp) elems - - -- Array shapes can only handle field shapes elements, so translate the - -- element type to and ensure it returns a field shape; FIXME: this could - -- actually handle sequences of field shapes if necessary (sh, saw_tp) <- translateLLVMType w tp - fsh <- case sh of - PExpr_FieldShape fsh -> return fsh - _ -> mzero -- Compute the array stride as the length of the element shape sh_len_expr <- lift $ llvmShapeLength sh @@ -108,7 +101,7 @@ translateLLVMValue w _ (L.ValArray tp elems) = (_,def_tm) <- translateLLVMValue w tp def_v -- Finally, build our array shape and SAW core value - return (PExpr_ArrayShape (bvInt $ fromIntegral $ length elems) sh_len [fsh], + return (PExpr_ArrayShape (bvInt $ fromIntegral $ length elems) sh_len sh, bvVecValueOpenTerm w saw_tp ts def_tm) translateLLVMValue w _ (L.ValPackedStruct elems) = mapM (translateLLVMTypedValue w) elems >>= \(unzip -> (shs,ts)) -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Parser.y b/heapster-saw/src/Verifier/SAW/Heapster/Parser.y index 643b9fcefc..b9b6d57cb5 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Parser.y +++ b/heapster-saw/src/Verifier/SAW/Heapster/Parser.y @@ -134,8 +134,8 @@ expr :: { AstExpr } | expr '+' expr { ExAdd (pos $2) $1 $3 } | expr '*' expr { ExMul (pos $2) $1 $3 } | 'struct' '(' list(expr) ')' { ExStruct (pos $1) $3 } - | 'array' '(' expr ',' '<' expr ',' '*' expr ',' '[' list(llvmFieldPermArray) ']' ')' - { ExArray (pos $1) $3 $6 $9 $12 } + | lifetime 'array' '(' expr ',' expr ',' '<' expr ',' '*' expr ',' expr ')' + { ExArray (pos $2) $1 $4 $6 $9 $12 $14 } | 'llvmword' '(' expr ')' { ExLlvmWord (pos $1) $3 } | 'llvmfunptr' '{' expr ',' expr '}' '(' funPerm ')' { ExLlvmFunPtr (pos $1) $3 $5 $8 } @@ -160,8 +160,8 @@ expr :: { AstExpr } | lifetime 'ptrsh' '(' expr ')' { ExPtrSh (pos $2) $1 Nothing $4 } | 'fieldsh' '(' expr ',' expr ')' { ExFieldSh (pos $1) (Just $3) $5 } | 'fieldsh' '(' expr ')' { ExFieldSh (pos $1) Nothing $3 } - | 'arraysh' '(' expr ',' expr ',' '[' list(shape) ']' ')' - { ExArraySh (pos $1) $3 $5 $8 } + | 'arraysh' '(' '<' expr ',' '*' expr ',' expr ')' + { ExArraySh (pos $1) $4 $7 $9 } | 'exsh' IDENT ':' type '.' expr { ExExSh (pos $1) (locThing $2) $4 $6 } -- Value Permissions @@ -195,10 +195,6 @@ expr :: { AstExpr } frameEntry :: { (AstExpr, Natural) } : expr ':' NAT { ($1, locThing $3) } -shape :: { (Maybe AstExpr, AstExpr) } - : expr { (Nothing, $1) } - | '(' expr ',' expr ')' { (Just $2, $4) } - identArgs :: { Maybe [AstExpr] } : { Nothing } | '<' list(expr) '>' { Just $2 } diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs index 26d6c8b8ba..3e18d2eb9b 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Permissions.hs @@ -83,6 +83,7 @@ import Verifier.SAW.OpenTerm import Verifier.SAW.Heapster.CruUtil +import GHC.Stack import Debug.Trace @@ -551,10 +552,13 @@ data PermExpr (a :: CrucibleType) where PExpr_FieldShape :: (1 <= w, KnownNat w) => LLVMFieldShape w -> PermExpr (LLVMShapeType w) - -- | A shape for an array with the given stride, length (in number of - -- elements = total length / stride), and fields + -- | A shape for an array of @len@ individual regions of memory, called "array + -- cells"; the size of each cell in bytes is given by the array stride, which + -- must be known statically, and each cell has shape given by the supplied + -- LLVM shape, also called the cell shape PExpr_ArrayShape :: (1 <= w, KnownNat w) => - PermExpr (BVType w) -> Bytes -> [LLVMFieldShape w] -> + PermExpr (BVType w) -> Bytes -> + PermExpr (LLVMShapeType w) -> PermExpr (LLVMShapeType w) -- | A sequence of two shapes @@ -633,6 +637,11 @@ bindingType _ = knownRepr exprLLVMTypeWidth :: KnownNat w => f (LLVMPointerType w) -> NatRepr w exprLLVMTypeWidth _ = knownNat +-- | Convenience function to get the bit width of an LLVM pointer type +mbExprLLVMTypeWidth :: KnownNat w => Mb ctx (f (LLVMPointerType w)) -> + NatRepr w +mbExprLLVMTypeWidth _ = knownNat + -- | Convenience function to get the bit width of an LLVM pointer type shapeLLVMTypeWidth :: KnownNat w => f (LLVMShapeType w) -> NatRepr w shapeLLVMTypeWidth _ = knownNat @@ -712,21 +721,6 @@ findAtomicPermInList x pred plist = foldPermListAtomic x (\p rest -> if pred p then Just p else rest) Nothing plist --- FIXME: move this down below the mkNuMatching calls or move --- llvmAtomicPermToBlock up before them... or just remove this function -{- --- | Find a permission on a specific variable in a permission list that is --- equivalent to a block permission -findBlockPermInList :: ExprVar (LLVMPointerType w) -> - (LLVMBlockPerm w -> Bool) -> - PermExpr PermListType -> Maybe (LLVMBlockPerm w) -findBlockPermInList x pred plist = - foldPermListAtomic x (\p rest -> - case llvmAtomicPermToBlock p of - Just bp | pred bp -> Just bp - _ -> rest) Nothing plist --} - -- | A bitvector variable, possibly multiplied by a constant data BVFactor w where -- | A variable of type @'BVType' w@ multiplied by a constant @i@, which @@ -813,8 +807,8 @@ instance Eq (PermExpr a) where (PExpr_FieldShape p1) == (PExpr_FieldShape p2) = p1 == p2 (PExpr_FieldShape _) == _ = False - (PExpr_ArrayShape len1 s1 flds1) == (PExpr_ArrayShape len2 s2 flds2) = - len1 == len2 && s1 == s2 && flds1 == flds2 + (PExpr_ArrayShape len1 s1 sh1) == (PExpr_ArrayShape len2 s2 sh2) = + len1 == len2 && s1 == s2 && sh1 == sh2 (PExpr_ArrayShape _ _ _) == _ = False (PExpr_SeqShape sh1 sh1') == (PExpr_SeqShape sh2 sh2') = @@ -881,12 +875,13 @@ instance PermPretty (PermExpr a) where return (l_pp <> pretty "ptrsh" <> parens (rw_pp <> sh_pp)) permPrettyM (PExpr_FieldShape fld) = (pretty "fieldsh" <>) <$> permPrettyM fld - permPrettyM (PExpr_ArrayShape len stride flds) = + permPrettyM (PExpr_ArrayShape len stride sh) = do len_pp <- permPrettyM len - flds_pp <- mapM permPrettyM flds + sh_pp <- permPrettyM sh let stride_pp = pretty (toInteger stride) - return (pretty "arraysh" <> tupled [len_pp, stride_pp, - ppEncList False flds_pp]) + return (pretty "arraysh" <> + ppEncList True [pretty "<" <> len_pp, + pretty "*" <> stride_pp, sh_pp]) permPrettyM (PExpr_SeqShape sh1 sh2) = do pp1 <- permPrettyM sh1 pp2 <- permPrettyM sh2 @@ -1089,7 +1084,7 @@ bvCouldEqual _ _ = True -- when the right-hand side is 0 and 'True' in all other cases except constant -- expressions @k1 >= k2@. bvCouldBeLt :: PermExpr (BVType w) -> PermExpr (BVType w) -> Bool -bvCouldBeLt _ (PExpr_BV [] (BV.BV 0)) = False +bvCouldBeLt _ (PExpr_BV [] (BV.BV 0)) = False bvCouldBeLt e1 e2 | bvEq e1 e2 = False bvCouldBeLt (PExpr_BV [] (BV.BV k1)) (PExpr_BV [] (BV.BV k2)) = k1 < k2 bvCouldBeLt _ _ = True @@ -1243,6 +1238,54 @@ bvRangeSub :: (1 <= w, KnownNat w) => BVRange w -> PermExpr (BVType w) -> BVRange w bvRangeSub (BVRange off len) x = BVRange (bvSub off x) len +-- | Delete all offsets from the first 'BVRange' that are definitely (in the +-- sense of 'bvPropHolds') in the second, returning a list of 'BVRange's that +-- together describe the remaining offsets +bvRangeDelete :: (1 <= w, KnownNat w) => BVRange w -> BVRange w -> [BVRange w] +bvRangeDelete rng1 rng2 + -- If rng1 is a subset of rng2, return the empty set + | bvRangeSubset rng1 rng2 = [] +bvRangeDelete rng1 rng2 + -- If both endpoints of rng1 are in rng2 but it is not a subset of rng2, then + -- one of the ranges wrapped, and we return the range from the end of rng2 to + -- its beginning again + | bvInRange (bvRangeOffset rng1) rng2 && + bvInRange (bvRangeEnd rng1) rng2 = + [BVRange (bvRangeEnd rng2) (bvSub (bvInt 0) (bvRangeLength rng2))] +bvRangeDelete rng1 rng2 + -- If the beginning of rng1 is in rng2 but the above cases don't hold, then + -- rng2 removes some prefix of rng1, so return the range from the end of rng2 + -- to the end of rng1 + | bvInRange (bvRangeOffset rng1) rng2 = + [bvRangeSuffix (bvRangeEnd rng2) rng1] +bvRangeDelete rng1 rng2 + -- If the end of rng1 is in rng2 but the above cases don't hold, then rng2 + -- removes some suffix of rng1, so return the range from the beginnning of + -- rng1 to the beginning of rng2 + | bvInRange (bvRangeEnd rng1) rng2 = + [BVRange (bvRangeOffset rng1) + (bvSub (bvRangeOffset rng2) (bvRangeOffset rng1))] +bvRangeDelete rng1 rng2 + -- If we get here then both endpoints of rng1 are not in rng2, but rng2 sits + -- inside of rng1, so return the prefix of rng1 before rng2 and the suffix of + -- rng1 after rng2 + | off1 <- bvRangeOffset rng1 + , off2 <- bvRangeOffset rng2 + , end1 <- bvRangeEnd rng1 + , end2 <- bvRangeEnd rng2 + , bvInRange off2 rng1 = + [BVRange off1 (bvSub off2 off1), BVRange end2 (bvSub end1 end2)] +bvRangeDelete rng1 _ = + -- If we get here, then rng2 is completely disjoint from rng1, so return rng1 + [rng1] + +-- | Delete all offsets in any of a list of ranges from a range, yielding a list +-- of ranges of the remaining offsets +bvRangesDelete :: (1 <= w, KnownNat w) => BVRange w -> [BVRange w] -> + [BVRange w] +bvRangesDelete rng_top = + foldr (\rng_del rngs -> concatMap (flip bvRangeDelete rng_del) rngs) [rng_top] + -- | Build a bitvector expression from an integer bvInt :: (1 <= w, KnownNat w) => Integer -> PermExpr (BVType w) bvInt i = PExpr_BV [] $ BV.mkBV knownNat i @@ -1506,6 +1549,10 @@ pattern ValPerm_True = ValPerm_Conj [] pattern ValPerm_Conj1 :: AtomicPerm a -> ValuePerm a pattern ValPerm_Conj1 p = ValPerm_Conj [p] +-- | The conjunction of exactly 1 atomic permission in a binding +mbValPerm_Conj1 :: Mb ctx (AtomicPerm a) -> Mb ctx (ValuePerm a) +mbValPerm_Conj1 = mbMapCl $(mkClosed [| ValPerm_Conj1 |]) + -- | The conjunction of exactly 1 field permission pattern ValPerm_LLVMField :: () => (a ~ LLVMPointerType w, 1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => @@ -1514,6 +1561,24 @@ pattern ValPerm_LLVMField fp <- ValPerm_Conj [Perm_LLVMField fp] where ValPerm_LLVMField fp = ValPerm_Conj [Perm_LLVMField fp] +{- FIXME: why doesn't this work? +-- | The conjunction of exactly 1 field permission in a binding +pattern MbValPerm_LLVMField :: () => (a ~ LLVMPointerType w, 1 <= w, KnownNat w, + 1 <= sz, KnownNat sz) => + Mb ctx (LLVMFieldPerm w sz) -> + Mb ctx (ValuePerm a) +pattern MbValPerm_LLVMField mb_fp <- [nuP| ValPerm_LLVMField mb_fp |] + where + MbValPerm_LLVMField mb_fp = + mbMapCl $(mkClosed [| ValPerm_LLVMField |]) mb_fp +-} + +-- | Build a 'ValPerm_LLVMField' in a binding +mbValPerm_LLVMField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => + Mb ctx (LLVMFieldPerm w sz) -> + Mb ctx (ValuePerm (LLVMPointerType w)) +mbValPerm_LLVMField = mbMapCl $(mkClosed [| ValPerm_LLVMField |]) + -- | The conjunction of exactly 1 array permission pattern ValPerm_LLVMArray :: () => (a ~ LLVMPointerType w, 1 <= w, KnownNat w) => LLVMArrayPerm w -> ValuePerm a @@ -1521,6 +1586,21 @@ pattern ValPerm_LLVMArray ap <- ValPerm_Conj [Perm_LLVMArray ap] where ValPerm_LLVMArray ap = ValPerm_Conj [Perm_LLVMArray ap] +{- FIXME: why doesn't this work? +-- | The conjunction of exactly 1 array permission +pattern MbValPerm_LLVMArray :: () => (a ~ LLVMPointerType w, 1 <= w, KnownNat w) => + Mb ctx (LLVMArrayPerm w) -> Mb ctx (ValuePerm a) +pattern MbValPerm_LLVMArray mb_ap <- [nuP| ValPerm_LLVMArray mb_ap |] + where + MbValPerm_LLVMArray mb_ap = + mbMapCl $(mkClosed [| ValPerm_LLVMArray |]) mb_ap +-} + +-- | Build a 'ValPerm_LLVMArray' in a binding +mbValPerm_LLVMArray :: (1 <= w, KnownNat w) => Mb ctx (LLVMArrayPerm w) -> + Mb ctx (ValuePerm (LLVMPointerType w)) +mbValPerm_LLVMArray = mbMapCl $(mkClosed [| ValPerm_LLVMArray |]) + -- | The conjunction of exactly 1 block permission pattern ValPerm_LLVMBlock :: () => (a ~ LLVMPointerType w, 1 <= w, KnownNat w) => LLVMBlockPerm w -> ValuePerm a @@ -1528,6 +1608,11 @@ pattern ValPerm_LLVMBlock bp <- ValPerm_Conj [Perm_LLVMBlock bp] where ValPerm_LLVMBlock bp = ValPerm_Conj [Perm_LLVMBlock bp] +-- | Build a 'ValPerm_LLVMBlock' in a binding +mbValPerm_LLVMBlock :: (1 <= w, KnownNat w) => Mb ctx (LLVMBlockPerm w) -> + Mb ctx (ValuePerm (LLVMPointerType w)) +mbValPerm_LLVMBlock = mbMapCl $(mkClosed [| ValPerm_LLVMBlock |]) + -- | The conjunction of exactly 1 block shape permission pattern ValPerm_LLVMBlockShape :: () => (a ~ LLVMBlockType w, b ~ LLVMShapeType w, 1 <= w, KnownNat w) => @@ -1613,7 +1698,7 @@ data LLVMFieldPerm w sz = LLVMFieldPerm { llvmFieldRW :: PermExpr RWModalityType, -- ^ Whether this is a read or write permission llvmFieldLifetime :: PermExpr LifetimeType, - -- ^ The lifetime during with this field permission is active + -- ^ The lifetime during which this field permission is active llvmFieldOffset :: PermExpr (BVType w), -- ^ The offset from the pointer in bytes of this field llvmFieldContents :: ValuePerm (LLVMPointerType sz) @@ -1625,60 +1710,56 @@ data LLVMFieldPerm w sz = llvmFieldSize :: KnownNat sz => LLVMFieldPerm w sz -> NatRepr sz llvmFieldSize _ = knownNat +-- | Helper to get a 'NatRepr' for the size of an 'LLVMFieldPerm' in a binding +mbLLVMFieldSize :: KnownNat sz => Mb ctx (LLVMFieldPerm w sz) -> NatRepr sz +mbLLVMFieldSize _ = knownNat + +-- | Get the rw-modality-in-binding of a field permission in binding +mbLLVMFieldRW :: Mb ctx (LLVMFieldPerm w sz) -> Mb ctx (PermExpr RWModalityType) +mbLLVMFieldRW = mbMapCl $(mkClosed [| llvmFieldRW |]) + +-- | Get the offset-in-binding of a field permission in binding +mbLLVMFieldOffset :: Mb ctx (LLVMFieldPerm w sz) -> Mb ctx (PermExpr (BVType w)) +mbLLVMFieldOffset = mbMapCl $(mkClosed [| llvmFieldOffset |]) + +-- | Get the contents-in-binding of a field permission in binding +mbLLVMFieldContents :: Mb ctx (LLVMFieldPerm w sz) -> + Mb ctx (ValuePerm (LLVMPointerType sz)) +mbLLVMFieldContents = mbMapCl $(mkClosed [| llvmFieldContents |]) + + -- | Helper type to represent byte offsets -- --- > 'machineWordBytes' * (stride * ix + fld_num) +-- > stride * ix + off -- --- from the beginning of an array permission. Such an expression refers to the --- array field @fld_num@, which must be a statically-known constant, in array --- cell @ix@. +-- from the beginning of an array permission. Such an expression refers to +-- offset @off@, which must be a statically-known constant, in array cell @ix@. data LLVMArrayIndex w = LLVMArrayIndex { llvmArrayIndexCell :: PermExpr (BVType w), - llvmArrayIndexFieldNum :: Int } + llvmArrayIndexOffset :: BV w } -- NOTE: we need a custom instance of Eq so we can use bvEq on the cell instance Eq (LLVMArrayIndex w) where LLVMArrayIndex e1 i1 == LLVMArrayIndex e2 i2 = bvEq e1 e2 && i1 == i2 --- | A single field in an array permission -data LLVMArrayField w = - forall sz. (1 <= sz, KnownNat sz) => LLVMArrayField (LLVMFieldPerm w sz) - -instance Eq (LLVMArrayField w) where - (LLVMArrayField fp1) == (LLVMArrayField fp2) - | Just Refl <- testEquality (llvmFieldSize fp1) (llvmFieldSize fp2) = - fp1 == fp2 - _ == _ = False - --- | Extract the offset from the field permission in an 'LLVMArrayField' -llvmArrayFieldOffset :: LLVMArrayField w -> PermExpr (BVType w) -llvmArrayFieldOffset (LLVMArrayField fp) = llvmFieldOffset fp - --- | Convert an 'LLVMArrayField' to an atomic permission -llvmArrayFieldToAtomicPerm :: (1 <= w, KnownNat w) => LLVMArrayField w -> - AtomicPerm (LLVMPointerType w) -llvmArrayFieldToAtomicPerm (LLVMArrayField fp) = Perm_LLVMField fp - --- | Get the length in bytes of an array field -llvmArrayFieldLen :: LLVMArrayField w -> Integer -llvmArrayFieldLen (LLVMArrayField fp) = intValue $ llvmFieldSize fp - --- | A permission to an array of repeated field permissions. An array permission --- is structured as zero or more cells, each of which are composed of one or --- more individual fields. The number of cells can be a dynamic expression, but --- the size in memory of each cell, called the /stride/ of the array, must be --- statically known and no less than the total size of the fields +-- | A permission to an array of @len@ individual regions of memory, called +-- "array cells". The size of each cell in bytes is given by the array /stride/, +-- which must be known statically, and each cell has shape given by the supplied +-- LLVM shape, also called the cell shape. data LLVMArrayPerm w = - LLVMArrayPerm { llvmArrayOffset :: PermExpr (BVType w), + LLVMArrayPerm { llvmArrayRW :: PermExpr RWModalityType, + -- ^ Whether this array gives read or write access + llvmArrayLifetime :: PermExpr LifetimeType, + -- ^ The lifetime during which this array permission is valid + llvmArrayOffset :: PermExpr (BVType w), -- ^ The offset from the pointer in bytes of this array llvmArrayLen :: PermExpr (BVType w), -- ^ The number of array blocks llvmArrayStride :: Bytes, -- ^ The array stride in bytes - llvmArrayFields :: [LLVMArrayField w], - -- ^ The fields in each element of this array; should have - -- length <= the stride + llvmArrayCellShape :: PermExpr (LLVMShapeType w), + -- ^ The shape of each cell in the array llvmArrayBorrows :: [LLVMArrayBorrow w] -- ^ Indices or index ranges that are missing from this array } @@ -1688,12 +1769,42 @@ data LLVMArrayPerm w = llvmArrayStrideBits :: LLVMArrayPerm w -> Integer llvmArrayStrideBits = toInteger . bytesToBits . llvmArrayStride +-- | Get the rw-modality-in-binding of an array permission in binding +mbLLVMArrayRW :: Mb ctx (LLVMArrayPerm w) -> Mb ctx (PermExpr RWModalityType) +mbLLVMArrayRW = mbMapCl $(mkClosed [| llvmArrayRW |]) + +-- | Get the lifetime-in-binding of an array permission in binding +mbLLVMArrayLifetime :: Mb ctx (LLVMArrayPerm w) -> + Mb ctx (PermExpr LifetimeType) +mbLLVMArrayLifetime = mbMapCl $(mkClosed [| llvmArrayLifetime |]) + +-- | Get the offset-in-binding of an array permission in binding +mbLLVMArrayOffset :: Mb ctx (LLVMArrayPerm w) -> Mb ctx (PermExpr (BVType w)) +mbLLVMArrayOffset = mbMapCl $(mkClosed [| llvmArrayOffset |]) + +-- | Get the length-in-binding of an array permission in binding +mbLLVMArrayLen :: Mb ctx (LLVMArrayPerm w) -> Mb ctx (PermExpr (BVType w)) +mbLLVMArrayLen = mbMapCl $(mkClosed [| llvmArrayLen |]) + +-- | Get the stride of an array permission in binding +mbLLVMArrayStride :: Mb ctx (LLVMArrayPerm w) -> Bytes +mbLLVMArrayStride = mbLift . mbMapCl $(mkClosed [| llvmArrayStride |]) + +-- | Get the cell-shape-in-binding of an array permission in binding +mbLLVMArrayCellShape :: Mb ctx (LLVMArrayPerm w) -> + Mb ctx (PermExpr (LLVMShapeType w)) +mbLLVMArrayCellShape = mbMapCl $(mkClosed [| llvmArrayCellShape |]) + +-- | Get the borrows in a binding for an array permission in binding +mbLLVMArrayBorrows :: Mb ctx (LLVMArrayPerm w) -> Mb ctx [LLVMArrayBorrow w] +mbLLVMArrayBorrows = mbMapCl $(mkClosed [| llvmArrayBorrows |]) + -- | An index or range of indices that are missing from an array perm -- -- FIXME: think about calling the just @LLVMArrayIndexSet@ data LLVMArrayBorrow w - = FieldBorrow (LLVMArrayIndex w) - -- ^ Borrow a specific field in a specific cell of an array permission + = FieldBorrow (PermExpr (BVType w)) + -- ^ Borrow a specific cell of an array permission | RangeBorrow (BVRange w) -- ^ Borrow a range of array cells, where each cell is 'llvmArrayStride' -- machine words long @@ -1716,13 +1827,27 @@ data LLVMBlockPerm w = } deriving Eq --- | Convenience function for building a single llvmblock permission -mkLLVMBlockPerm :: (1 <= w, KnownNat w) => - PermExpr RWModalityType -> PermExpr LifetimeType -> - PermExpr (BVType w) -> PermExpr (BVType w) -> - PermExpr (LLVMShapeType w) -> ValuePerm (LLVMPointerType w) -mkLLVMBlockPerm rw l off len sh = - ValPerm_Conj1 $ Perm_LLVMBlock $ LLVMBlockPerm rw l off len sh +-- | Get the rw-modality-in-binding of a block permission in binding +mbLLVMBlockRW :: Mb ctx (LLVMBlockPerm w) -> Mb ctx (PermExpr RWModalityType) +mbLLVMBlockRW = mbMapCl $(mkClosed [| llvmBlockRW |]) + +-- | Get the lifetime-in-binding of a block permission in binding +mbLLVMBlockLifetime :: Mb ctx (LLVMBlockPerm w) -> + Mb ctx (PermExpr LifetimeType) +mbLLVMBlockLifetime = mbMapCl $(mkClosed [| llvmBlockLifetime |]) + +-- | Get the offset-in-binding of a block permission in binding +mbLLVMBlockOffset :: Mb ctx (LLVMBlockPerm w) -> Mb ctx (PermExpr (BVType w)) +mbLLVMBlockOffset = mbMapCl $(mkClosed [| llvmBlockOffset |]) + +-- | Get the length-in-binding of a block permission in binding +mbLLVMBlockLen :: Mb ctx (LLVMBlockPerm w) -> Mb ctx (PermExpr (BVType w)) +mbLLVMBlockLen = mbMapCl $(mkClosed [| llvmBlockLen |]) + +-- | Get the shape-in-binding of a block permission in binding +mbLLVMBlockShape :: Mb ctx (LLVMBlockPerm w) -> + Mb ctx (PermExpr (LLVMShapeType w)) +mbLLVMBlockShape = mbMapCl $(mkClosed [| llvmBlockShape |]) -- | An LLVM shape for a single pointer field of unknown size data LLVMFieldShape w = @@ -1740,6 +1865,8 @@ data LOwnedPerm a where LOwnedPermField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => PermExpr (LLVMPointerType w) -> LLVMFieldPerm w sz -> LOwnedPerm (LLVMPointerType w) + LOwnedPermArray :: (1 <= w, KnownNat w) => PermExpr (LLVMPointerType w) -> + LLVMArrayPerm w -> LOwnedPerm (LLVMPointerType w) LOwnedPermBlock :: (1 <= w, KnownNat w) => PermExpr (LLVMPointerType w) -> LLVMBlockPerm w -> LOwnedPerm (LLVMPointerType w) @@ -1753,6 +1880,11 @@ instance TestEquality LOwnedPerm where , e1 == e2 && fp1 == fp2 = Just Refl testEquality (LOwnedPermField _ _) _ = Nothing + testEquality (LOwnedPermArray e1 ap1) (LOwnedPermArray e2 ap2) + | Just Refl <- testEquality (exprType e1) (exprType e2) + , e1 == e2 && ap1 == ap2 + = Just Refl + testEquality (LOwnedPermArray _ _) _ = Nothing testEquality (LOwnedPermBlock e1 bp1) (LOwnedPermBlock e2 bp2) | Just Refl <- testEquality (exprType e1) (exprType e2) , e1 == e2 && bp1 == bp2 @@ -1770,6 +1902,8 @@ instance Eq1 LOwnedPerm where lownedPermExprAndPerm :: LOwnedPerm a -> ExprAndPerm a lownedPermExprAndPerm (LOwnedPermField e fp) = ExprAndPerm e $ ValPerm_LLVMField fp +lownedPermExprAndPerm (LOwnedPermArray e ap) = + ExprAndPerm e $ ValPerm_LLVMArray ap lownedPermExprAndPerm (LOwnedPermBlock e bp) = ExprAndPerm e $ ValPerm_LLVMBlock bp @@ -1784,6 +1918,8 @@ lownedPermVarAndPerm _ = Nothing varAndPermLOwnedPerm :: VarAndPerm a -> Maybe (LOwnedPerm a) varAndPermLOwnedPerm (VarAndPerm x (ValPerm_LLVMField fp)) = Just $ LOwnedPermField (PExpr_Var x) fp +varAndPermLOwnedPerm (VarAndPerm x (ValPerm_LLVMArray ap)) = + Just $ LOwnedPermArray (PExpr_Var x) ap varAndPermLOwnedPerm (VarAndPerm x (ValPerm_LLVMBlock bp)) = Just $ LOwnedPermBlock (PExpr_Var x) bp varAndPermLOwnedPerm _ = Nothing @@ -1801,6 +1937,54 @@ lownedPermVar _ = Nothing lownedPermPerm :: LOwnedPerm a -> ValuePerm a lownedPermPerm = exprAndPermPerm . lownedPermExprAndPerm +-- | Convert the permission part of an 'LOwnedPerm' to a block permission on a +-- variable, if possible +lownedPermVarBlockPerm :: LOwnedPerm a -> Maybe (ExprVar a, SomeLLVMBlockPerm a) +lownedPermVarBlockPerm lop + | Just (x, perm_off) <- asVarOffset (lownedPermExpr lop) + , ValPerm_Conj1 p <- lownedPermPerm lop + , Just (SomeLLVMBlockPerm bp) <- llvmAtomicPermToSomeBlock p + , off <- llvmPermOffsetExpr perm_off = + Just (x, SomeLLVMBlockPerm (offsetLLVMBlockPerm off bp)) +lownedPermVarBlockPerm _ = Nothing + +-- | Convert the permission part of an 'LOwnedPerm' in a binding to a block +-- permission on a variable in a binding, if possible +mbLownedPermVarBlockPerm :: Mb ctx (LOwnedPerm a) -> + Maybe (Mb ctx (ExprVar a, SomeLLVMBlockPerm a)) +mbLownedPermVarBlockPerm = + mbMaybe . mbMapCl $(mkClosed [| lownedPermVarBlockPerm |]) + +-- | Get the read/write and lifetime modalities of an 'LOwnedPerm' of LLVM type +llvmLownedPermModalities :: LOwnedPerm (LLVMPointerType w) -> + (PermExpr RWModalityType, PermExpr LifetimeType) +llvmLownedPermModalities (LOwnedPermField _ fp) = + (llvmFieldRW fp, llvmFieldLifetime fp) +llvmLownedPermModalities (LOwnedPermArray _ ap) = + (llvmArrayRW ap, llvmArrayLifetime ap) +llvmLownedPermModalities (LOwnedPermBlock _ bp) = + (llvmBlockRW bp, llvmBlockLifetime bp) + +-- | Find an 'LOwnedPerm' for a particular variable in an 'LOwnedPerms' list +findLOwnedPermForVar :: ExprVar a -> LOwnedPerms ps -> Maybe (LOwnedPerm a) +findLOwnedPermForVar _ MNil = Nothing +findLOwnedPermForVar x (_ :>: lop) + | Just (y, _) <- asVarOffset (lownedPermExpr lop) + , Just Refl <- testEquality x y = Just lop +findLOwnedPermForVar x (lops :>: _) = findLOwnedPermForVar x lops + +-- | Find all 'LOwnedPerm's for a specific variable of LLVM pointer type in an +-- 'LOwnedPerms' list, and return the ranges of offsets that each of those cover +lownedPermsOffsetsForLLVMVar :: (1 <= w, KnownNat w) => + ExprVar (LLVMPointerType w) -> LOwnedPerms ps -> + [BVRange w] +lownedPermsOffsetsForLLVMVar _ MNil = [] +lownedPermsOffsetsForLLVMVar x (lops :>: lop) + | Just (y, SomeLLVMBlockPerm bp) <- lownedPermVarBlockPerm lop + , Just Refl <- testEquality x y = + llvmBlockRange bp : lownedPermsOffsetsForLLVMVar x lops +lownedPermsOffsetsForLLVMVar x (lops :>: _) = + lownedPermsOffsetsForLLVMVar x lops -- | A function permission is a set of input and output permissions inside a -- context of ghost variables @@ -2062,6 +2246,12 @@ mkLLVMPermOffset :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> mkLLVMPermOffset off | bvIsZero off = NoPermOffset mkLLVMPermOffset off = LLVMPermOffset off +-- | Extract a bitvector offset expression from a 'PermOffset' of pointer type +llvmPermOffsetExpr :: (1 <= w, KnownNat w) => PermOffset (LLVMPointerType w) -> + PermExpr (BVType w) +llvmPermOffsetExpr NoPermOffset = bvInt 0 +llvmPermOffsetExpr (LLVMPermOffset e) = e + -- | Test two 'PermOffset's for semantic, not just syntactic, equality offsetsEq :: PermOffset a -> PermOffset a -> Bool offsetsEq NoPermOffset NoPermOffset = True @@ -2433,6 +2623,12 @@ data LifetimeFunctor args a where PermExpr (BVType w) -> ValuePerm (LLVMPointerType sz) -> LifetimeFunctor (RNil :> RWModalityType) (LLVMPointerType w) + -- | The functor @\(l,rw) -> [l]array(rw,off, PermExpr (BVType w) -> + PermExpr (BVType w) -> Bytes -> + PermExpr (LLVMShapeType w) -> [LLVMArrayBorrow w] -> + LifetimeFunctor (RNil :> RWModalityType) (LLVMPointerType w) + -- | The functor @\(l,rw) -> [l]memblock(rw,off,len,sh) LTFunctorBlock :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> PermExpr (BVType w) -> @@ -2446,6 +2642,8 @@ ltFuncApply :: LifetimeFunctor args a -> PermExprs args -> PermExpr LifetimeType -> ValuePerm a ltFuncApply (LTFunctorField off p) (MNil :>: rw) l = ValPerm_LLVMField $ LLVMFieldPerm rw l off p +ltFuncApply (LTFunctorArray off len stride sh bs) (MNil :>: rw) l = + ValPerm_LLVMArray $ LLVMArrayPerm rw l off len stride sh bs ltFuncApply (LTFunctorBlock off len sh) (MNil :>: rw) l = ValPerm_LLVMBlock $ LLVMBlockPerm rw l off len sh @@ -2454,6 +2652,8 @@ ltFuncApplyLOP :: ExprVar a -> LifetimeFunctor args a -> PermExprs args -> PermExpr LifetimeType -> LOwnedPerm a ltFuncApplyLOP x (LTFunctorField off p) (MNil :>: rw) l = LOwnedPermField (PExpr_Var x) $ LLVMFieldPerm rw l off p +ltFuncApplyLOP x (LTFunctorArray off len stride sh bs) (MNil :>: rw) l = + LOwnedPermArray (PExpr_Var x) $ LLVMArrayPerm rw l off len stride sh bs ltFuncApplyLOP x (LTFunctorBlock off len sh) (MNil :>: rw) l = LOwnedPermBlock (PExpr_Var x) $ LLVMBlockPerm rw l off len sh @@ -2462,6 +2662,8 @@ ltFuncApplyLOP x (LTFunctorBlock off len sh) (MNil :>: rw) l = ltFuncMinApply :: LifetimeFunctor args a -> PermExpr LifetimeType -> ValuePerm a ltFuncMinApply (LTFunctorField off p) l = ValPerm_LLVMField $ LLVMFieldPerm PExpr_Read l off p +ltFuncMinApply (LTFunctorArray off len stride sh bs) l = + ValPerm_LLVMArray $ LLVMArrayPerm PExpr_Read l off len stride sh bs ltFuncMinApply (LTFunctorBlock off len sh) l = ValPerm_LLVMBlock $ LLVMBlockPerm PExpr_Read l off len sh @@ -2471,6 +2673,8 @@ ltFuncMinApplyLOP :: ExprVar a -> LifetimeFunctor args a -> PermExpr LifetimeType -> LOwnedPerm a ltFuncMinApplyLOP x (LTFunctorField off p) l = LOwnedPermField (PExpr_Var x) $ LLVMFieldPerm PExpr_Read l off p +ltFuncMinApplyLOP x (LTFunctorArray off len stride sh bs) l = + LOwnedPermArray (PExpr_Var x) $ LLVMArrayPerm PExpr_Read l off len stride sh bs ltFuncMinApplyLOP x (LTFunctorBlock off len sh) l = LOwnedPermBlock (PExpr_Var x) $ LLVMBlockPerm PExpr_Read l off len sh @@ -2482,6 +2686,13 @@ fieldToLTFunc :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => fieldToLTFunc fp = (LTFunctorField (llvmFieldOffset fp) (llvmFieldContents fp), MNil :>: llvmFieldRW fp) +-- | Convert an array permission to a lifetime functor and its arguments +arrayToLTFunc :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> + (LifetimeFunctor (RNil :> RWModalityType) (LLVMPointerType w), + PermExprs (RNil :> RWModalityType)) +arrayToLTFunc (LLVMArrayPerm rw _ off len stride sh bs) = + (LTFunctorArray off len stride sh bs, MNil :>: rw) + -- | Convert a block permission to a lifetime functor and its arguments blockToLTFunc :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> (LifetimeFunctor (RNil :> RWModalityType) (LLVMPointerType w), @@ -2649,20 +2860,19 @@ instance (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => PermPretty (LLVMFieldPerm w sz) where permPrettyM = permPrettyLLVMField False -instance KnownNat w => PermPretty (LLVMArrayField w) where - permPrettyM (LLVMArrayField fp) = permPrettyLLVMField True fp - instance (1 <= w, KnownNat w) => PermPretty (LLVMArrayPerm w) where permPrettyM (LLVMArrayPerm {..}) = - do pp_off <- permPrettyM llvmArrayOffset + do pp_l <- permPrettyLifetimePrefix llvmArrayLifetime + pp_rw <- permPrettyM llvmArrayRW + pp_off <- permPrettyM llvmArrayOffset pp_len <- permPrettyM llvmArrayLen let pp_stride = pretty (show llvmArrayStride) - pp_flds <- mapM permPrettyM llvmArrayFields + pp_sh <- permPrettyM llvmArrayCellShape pp_bs <- mapM permPrettyM llvmArrayBorrows - return $ PP.group (pretty "array" <> - ppEncList True [pp_off, pretty "<" <> pp_len, + return $ PP.group (pp_l <> pretty "array" <> + ppEncList True [pp_rw, pp_off, pretty "<" <> pp_len, pretty "*" <> pp_stride, - ppEncList False pp_flds, + pp_sh, ppEncList False pp_bs]) instance (1 <= w, KnownNat w) => PermPretty (LLVMBlockPerm w) where @@ -2758,10 +2968,7 @@ instance PermPretty (BVProp w) where <$> permPrettyM e1 <*> permPrettyM e2 <*> permPrettyM e3 instance PermPretty (LLVMArrayBorrow w) where - permPrettyM (FieldBorrow (LLVMArrayIndex ix fld_num)) = - do pp_ix <- permPrettyM ix - let pp_fld_num = pretty (show fld_num) - return (parens pp_ix <> pretty "." <> pp_fld_num) + permPrettyM (FieldBorrow ix) = permPrettyM ix permPrettyM (RangeBorrow rng) = permPrettyM rng instance PermPretty (VarAndPerm a) where @@ -2790,100 +2997,6 @@ instance PermPrettyF ExprAndPerm where permPrettyMF = permPrettyM -$(mkNuMatching [t| forall a . PermExpr a |]) -$(mkNuMatching [t| forall a . BVFactor a |]) -$(mkNuMatching [t| forall w. BVRange w |]) -$(mkNuMatching [t| forall w. BVProp w |]) -$(mkNuMatching [t| forall a . AtomicPerm a |]) -$(mkNuMatching [t| forall a . ValuePerm a |]) --- $(mkNuMatching [t| forall as. ValuePerms as |]) -$(mkNuMatching [t| forall a . VarAndPerm a |]) - -instance NuMatchingAny1 PermExpr where - nuMatchingAny1Proof = nuMatchingProof - -instance NuMatchingAny1 ValuePerm where - nuMatchingAny1Proof = nuMatchingProof - -instance NuMatchingAny1 VarAndPerm where - nuMatchingAny1Proof = nuMatchingProof - -$(mkNuMatching [t| forall w sz . LLVMFieldPerm w sz |]) -$(mkNuMatching [t| forall w . LLVMArrayPerm w |]) -$(mkNuMatching [t| forall w . LLVMBlockPerm w |]) -$(mkNuMatching [t| RWModality |]) -$(mkNuMatching [t| forall w . LLVMArrayIndex w |]) -$(mkNuMatching [t| forall w . LLVMArrayField w |]) -$(mkNuMatching [t| forall w . LLVMArrayBorrow w |]) -$(mkNuMatching [t| forall w . LLVMFieldShape w |]) -$(mkNuMatching [t| forall w . LOwnedPerm w |]) -$(mkNuMatching [t| forall ghosts args ret. FunPerm ghosts args ret |]) -$(mkNuMatching [t| forall args ret. SomeFunPerm args ret |]) -$(mkNuMatching [t| forall ns. NameSortRepr ns |]) -$(mkNuMatching [t| forall ns args a. NameReachConstr ns args a |]) -$(mkNuMatching [t| forall ns args a. NamedPermName ns args a |]) -$(mkNuMatching [t| SomeNamedPermName |]) -$(mkNuMatching [t| forall b args w. NamedShape b args w |]) -$(mkNuMatching [t| forall b args w. NamedShapeBody b args w |]) -$(mkNuMatching [t| forall a. PermOffset a |]) -$(mkNuMatching [t| forall ns args a. NamedPerm ns args a |]) -$(mkNuMatching [t| forall b args a. OpaquePerm b args a |]) -$(mkNuMatching [t| forall args a reach. ReachMethods args a reach |]) -$(mkNuMatching [t| forall b reach args a. RecPerm b reach args a |]) -$(mkNuMatching [t| forall b args a. DefinedPerm b args a |]) -$(mkNuMatching [t| forall args a. LifetimeFunctor args a |]) -$(mkNuMatching [t| forall ps. LifetimeCurrentPerms ps |]) - - - -instance NuMatchingAny1 LOwnedPerm where - nuMatchingAny1Proof = nuMatchingProof - -instance NuMatchingAny1 DistPerms where - nuMatchingAny1Proof = nuMatchingProof - -instance Liftable RWModality where - mbLift mb_rw = case mbMatch mb_rw of - [nuMP| Write |] -> Write - [nuMP| Read |] -> Read - -instance Closable RWModality where - toClosed Write = $(mkClosed [| Write |]) - toClosed Read = $(mkClosed [| Read |]) - -instance Closable (NameSortRepr ns) where - toClosed (DefinedSortRepr b) = - $(mkClosed [| DefinedSortRepr |]) `clApply` toClosed b - toClosed (OpaqueSortRepr b) = - $(mkClosed [| OpaqueSortRepr |]) `clApply` toClosed b - toClosed (RecursiveSortRepr b reach) = - $(mkClosed [| RecursiveSortRepr |]) - `clApply` toClosed b `clApply` toClosed reach - -instance Liftable (NameSortRepr ns) where - mbLift = unClosed . mbLift . fmap toClosed - -instance Closable (NameReachConstr ns args a) where - toClosed NameReachConstr = $(mkClosed [| NameReachConstr |]) - toClosed NameNonReachConstr = $(mkClosed [| NameNonReachConstr |]) - -instance Liftable (NameReachConstr ns args a) where - mbLift = unClosed . mbLift . fmap toClosed - -instance Liftable (NamedPermName ns args a) where - mbLift (mbMatch -> [nuMP| NamedPermName n tp args ns r |]) = - NamedPermName (mbLift n) (mbLift tp) (mbLift args) (mbLift ns) (mbLift r) - -instance Liftable SomeNamedPermName where - mbLift (mbMatch -> [nuMP| SomeNamedPermName rpn |]) = - SomeNamedPermName $ mbLift rpn - -instance Liftable (ReachMethods args a reach) where - mbLift mb_x = case mbMatch mb_x of - [nuMP| ReachMethods transIdent |] -> - ReachMethods (mbLift transIdent) - [nuMP| NoReachMethods |] -> NoReachMethods - -- | Embed a 'ValuePerm' in a 'PermExpr' - like 'PExpr_ValPerm' but maps -- 'ValPerm_Var's to 'PExpr_Var's permToExpr :: ValuePerm a -> PermExpr (ValuePermType a) @@ -3209,28 +3322,116 @@ llvmFieldPermToBlock fp = llvmBlockLen = llvmFieldLen fp, llvmBlockShape = PExpr_FieldShape (LLVMFieldShape $ llvmFieldContents fp) } +-- | Convert a block permission with field shape to a field permission +-- +-- NOTE: do not check that the length of the block equals that of the resulting +-- field permission, in case the length of the block has a free variable that +-- might be provably but not syntacitcally equal to the length +llvmBlockPermToField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => + NatRepr sz -> LLVMBlockPerm w -> + Maybe (LLVMFieldPerm w sz) +llvmBlockPermToField sz bp + | PExpr_FieldShape (LLVMFieldShape p) <- llvmBlockShape bp + , Just Refl <- testEquality sz (exprLLVMTypeWidth p) + = Just $ LLVMFieldPerm { llvmFieldRW = llvmBlockRW bp, + llvmFieldLifetime = llvmBlockLifetime bp, + llvmFieldOffset = llvmBlockOffset bp, + llvmFieldContents = p } +llvmBlockPermToField _ _ = Nothing + +-- | Convert an array permission with total size @sz@ bits to a field permission +-- of size @sz@ bits, assuming it has no borrows +llvmArrayToField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => + NatRepr sz -> LLVMArrayPerm w -> + Maybe (LLVMFieldPerm w sz) +llvmArrayToField sz ap + | bvEq (bvMult (llvmArrayStrideBits ap) (llvmArrayLen ap)) (bvInt $ + intValue sz) + , [] <- llvmArrayBorrows ap = + Just $ LLVMFieldPerm { llvmFieldRW = llvmArrayRW ap, + llvmFieldLifetime = llvmArrayLifetime ap, + llvmFieldOffset = llvmArrayOffset ap, + llvmFieldContents = ValPerm_True } +llvmArrayToField _ _ = Nothing + +-- | Convert an array permission with no borrows to a block permission +llvmArrayPermToBlock :: (1 <= w, KnownNat w) => + LLVMArrayPerm w -> Maybe (LLVMBlockPerm w) +llvmArrayPermToBlock ap + | [] <- llvmArrayBorrows ap = + Just $ LLVMBlockPerm + { llvmBlockRW = llvmArrayRW ap, + llvmBlockLifetime = llvmArrayLifetime ap, + llvmBlockOffset = llvmArrayOffset ap, + llvmBlockLen = bvMult (llvmArrayStride ap) (llvmArrayLen ap), + llvmBlockShape = + PExpr_ArrayShape (llvmArrayLen ap) (llvmArrayStride ap) + (llvmArrayCellShape ap) } +llvmArrayPermToBlock _ = Nothing + +-- | Convert a block permission with array shape to an array permission, +-- assuming the length of the block permission equals the size of the array +-- +-- NOTE: do not check that the length of the block equals that of the resulting +-- array permission, in case the length of the block has a free variable that +-- might be provably but not syntacitcally equal to the length +llvmBlockPermToArray :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> + Maybe (LLVMArrayPerm w) +llvmBlockPermToArray bp + | PExpr_ArrayShape len stride sh <- llvmBlockShape bp = + Just $ LLVMArrayPerm + { llvmArrayRW = llvmBlockRW bp, + llvmArrayLifetime = llvmBlockLifetime bp, + llvmArrayOffset = llvmBlockOffset bp, + llvmArrayLen = bvMult (toInteger stride) len, + llvmArrayStride = stride, + llvmArrayCellShape = sh, + llvmArrayBorrows = [] } +llvmBlockPermToArray _ = Nothing + +-- | Convert a block permission with statically-known length @len@ to an +-- equivalent array of length 1 with stride @len@ +llvmBlockPermToArray1 :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> + Maybe (LLVMArrayPerm w) +llvmBlockPermToArray1 bp + | Just stride <- bvMatchConstInt $ llvmBlockLen bp = + Just $ LLVMArrayPerm + { llvmArrayRW = llvmBlockRW bp, + llvmArrayLifetime = llvmBlockLifetime bp, + llvmArrayOffset = llvmBlockOffset bp, + llvmArrayLen = bvInt 1, + llvmArrayStride = fromInteger stride, + llvmArrayCellShape = llvmBlockShape bp, + llvmArrayBorrows = [] } +llvmBlockPermToArray1 _ = Nothing + +-- | Get the permission for a single cell of an array permission +llvmArrayCellPerm :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> + PermExpr (BVType w) -> LLVMBlockPerm w +llvmArrayCellPerm ap cell = + let off = bvAdd (llvmArrayOffset ap) (bvMult (llvmArrayStride ap) cell) in + LLVMBlockPerm { llvmBlockRW = llvmArrayRW ap, + llvmBlockLifetime = llvmArrayLifetime ap, + llvmBlockOffset = off, + llvmBlockLen = bvInt (toInteger $ llvmArrayStride ap), + llvmBlockShape = llvmArrayCellShape ap } + +-- | Get the permission for the first cell of an array permission +llvmArrayPermHead :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMBlockPerm w +llvmArrayPermHead ap = llvmArrayCellPerm ap (bvInt 0) + +-- | Get the permission for all of an array permission after the first cell +llvmArrayPermTail :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayPerm w +llvmArrayPermTail ap = + let off1 = bvInt $ bytesToInteger $ llvmArrayStride ap in + ap { llvmArrayOffset = bvAdd (llvmArrayOffset ap) off1, + llvmArrayLen = bvSub (llvmArrayLen ap) (bvInt 1) } + -- | Convert an atomic permission to a @memblock@, if possible llvmAtomicPermToBlock :: AtomicPerm (LLVMPointerType w) -> Maybe (LLVMBlockPerm w) llvmAtomicPermToBlock (Perm_LLVMField fp) = Just $ llvmFieldPermToBlock fp -llvmAtomicPermToBlock (Perm_LLVMArray ap) - | [] <- llvmArrayBorrows ap - , LLVMArrayField fp : _ <- llvmArrayFields ap - , Just shs <- - mapM (\case - LLVMArrayField fp' - | llvmFieldRW fp == llvmFieldRW fp' - , llvmFieldLifetime fp == llvmFieldLifetime fp' -> - Just $ LLVMFieldShape (llvmFieldContents fp') - _ -> Nothing) - (llvmArrayFields ap) - = Just $ LLVMBlockPerm - { llvmBlockRW = llvmFieldRW fp, - llvmBlockLifetime = llvmFieldLifetime fp, - llvmBlockOffset = llvmArrayOffset ap, - llvmBlockLen = llvmArrayLen ap, - llvmBlockShape = - PExpr_ArrayShape (llvmArrayLen ap) (llvmArrayStride ap) shs } +llvmAtomicPermToBlock (Perm_LLVMArray ap) = llvmArrayPermToBlock ap llvmAtomicPermToBlock (Perm_LLVMBlock bp) = Just bp llvmAtomicPermToBlock _ = Nothing @@ -3250,13 +3451,6 @@ llvmAtomicPermToSomeBlock (Perm_LLVMBlock bp) = Just $ SomeLLVMBlockPerm $ bp llvmAtomicPermToSomeBlock _ = Nothing --- | Get the lifetime of an atomic permission, if it has one -llvmAtomicPermLifetime :: AtomicPerm a -> Maybe (PermExpr LifetimeType) -llvmAtomicPermLifetime (llvmAtomicPermToSomeBlock -> - Just (SomeLLVMBlockPerm bp)) = - Just $ llvmBlockLifetime bp -llvmAtomicPermLifetime _ = Nothing - -- | Get the offset of an atomic permission, if it has one llvmAtomicPermOffset :: AtomicPerm (LLVMPointerType w) -> Maybe (PermExpr (BVType w)) @@ -3276,6 +3470,11 @@ llvmAtomicPermRange p = fmap llvmBlockRange $ llvmAtomicPermToBlock p llvmBlockRange :: LLVMBlockPerm w -> BVRange w llvmBlockRange bp = BVRange (llvmBlockOffset bp) (llvmBlockLen bp) +-- | Set the range of an 'LLVMBlock' +llvmBlockSetRange :: LLVMBlockPerm w -> BVRange w -> LLVMBlockPerm w +llvmBlockSetRange bp (BVRange off len) = + bp { llvmBlockOffset = off, llvmBlockLen = len } + -- | Get the ending offset of a block permission llvmBlockEndOffset :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> PermExpr (BVType w) @@ -3307,7 +3506,7 @@ llvmShapeLength (PExpr_PtrShape _ _ sh) | otherwise = Nothing llvmShapeLength (PExpr_FieldShape fsh) = Just $ bvInt $ llvmFieldShapeLength fsh -llvmShapeLength (PExpr_ArrayShape len _ _) = Just len +llvmShapeLength (PExpr_ArrayShape len stride _) = Just $ bvMult stride len llvmShapeLength (PExpr_SeqShape sh1 sh2) = liftA2 bvAdd (llvmShapeLength sh1) (llvmShapeLength sh2) llvmShapeLength (PExpr_OrShape sh1 sh2) = @@ -3326,37 +3525,6 @@ llvmShapeLength (PExpr_ExShape mb_sh) = partialSubst (emptyPSubst $ singletonCruCtx $ knownRepr) mb_len _ -> Nothing --- | Convert an 'LLVMFieldShape' inside (i.e., with all the other components of) --- a @memblock@ permission to an 'LLVMArrayField' and its length -llvmFieldShapePermToArrayField :: (1 <= w, KnownNat w) => PermExpr RWModalityType -> - PermExpr LifetimeType -> PermExpr (BVType w) -> - LLVMFieldShape w -> - (LLVMArrayField w, PermExpr (BVType w)) -llvmFieldShapePermToArrayField rw l off (LLVMFieldShape p) = - (LLVMArrayField (LLVMFieldPerm rw l off p), exprLLVMTypeBytesExpr p) - --- | Convert a @memblock@ permission with array shape to an array permission -llvmArrayBlockToArrayPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - LLVMArrayPerm w -llvmArrayBlockToArrayPerm bp - | PExpr_ArrayShape len stride fshs <- llvmBlockShape bp - , rw <- llvmBlockRW bp - , l <- llvmBlockLifetime bp = - LLVMArrayPerm - { llvmArrayOffset = llvmBlockOffset bp, - llvmArrayLen = bvMult (toInteger stride) len, - llvmArrayStride = stride, - llvmArrayBorrows = [], - llvmArrayFields = - snd $ - foldl (\(off,flds) sh -> - let (fld, sz) = llvmFieldShapePermToArrayField rw l off sh in - (bvAdd off sz, flds ++ [fld])) - (bvInt 0, []) - fshs } -llvmArrayBlockToArrayPerm _ = - error "llvmArrayBlockToArrayPerm: block perm not of array shape" - -- | Adjust the read/write and lifetime modalities of a block permission by -- setting those modalities that are supplied as arguments llvmBlockAdjustModalities :: Maybe (PermExpr RWModalityType) -> @@ -3367,36 +3535,32 @@ llvmBlockAdjustModalities maybe_rw maybe_l bp = l = maybe (llvmBlockLifetime bp) id maybe_l in bp { llvmBlockRW = rw, llvmBlockLifetime = l } --- | Create a field permission for a pointer to a block permission which uses --- the offset, read/write modality, and lifetime of the block permission; that --- is, return +-- | Convert a block permission of pointer shape to the block permission of +-- field shape that it represents. That is, convert the block permission -- --- > [l]ptr((rw,off) |-> [l]memblock(rw,0,len,sh)) -llvmBlockPtrFieldPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - LLVMFieldPerm w w -llvmBlockPtrFieldPerm bp = - LLVMFieldPerm - { llvmFieldRW = llvmBlockRW bp, - llvmFieldLifetime = llvmBlockLifetime bp, - llvmFieldOffset = llvmBlockOffset bp, - llvmFieldContents = ValPerm_LLVMBlock (bp { llvmBlockOffset = bvInt 0 }) } - --- | Create a pointer atomic permission to a block permission which uses the --- offset, read/write modality, and lifetime of the block permission; that is, --- return +-- > [l]memblock(rw,off,w/8,[l2]ptrsh(rw2,sh)) -- --- > [l]ptr((rw,off) |-> [l]memblock(rw,0,len,sh)) -llvmBlockPtrAtomicPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - AtomicPerm (LLVMPointerType w) -llvmBlockPtrAtomicPerm bp = Perm_LLVMField $ llvmBlockPtrFieldPerm bp - --- | Create a pointer permission to a block permission which uses the offset, --- read/write modality, and lifetime of the block permission; that is, return +-- to -- --- > [l]ptr((rw,off) |-> [l]memblock(rw,0,len,sh)) -llvmBlockPtrPerm :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> - ValuePerm (LLVMPointerType w) -llvmBlockPtrPerm bp = ValPerm_Conj1 $ llvmBlockPtrAtomicPerm bp +-- > [l]memblock(rw,off,w/8,fieldsh([l2]memblock(rw2,0,sh_len,sh))) +-- +-- where @sh_len@ is the 'llvmShapeLength' of @sh@. It is an error if the input +-- block permission does not have the required form displayed above. +llvmBlockPtrShapeUnfold :: (1 <= w, KnownNat w) => LLVMBlockPerm w -> + Maybe (LLVMBlockPerm w) +llvmBlockPtrShapeUnfold bp + | PExpr_PtrShape maybe_rw maybe_l sh <- llvmBlockShape bp + , Just sh_len <- llvmShapeLength sh + , bvEq (llvmBlockLen bp) (bvInt $ machineWordBytes bp) = + Just $ bp { llvmBlockShape = + PExpr_FieldShape $ LLVMFieldShape $ ValPerm_LLVMBlock $ + LLVMBlockPerm + { llvmBlockRW = maybe (llvmBlockRW bp) id maybe_rw, + llvmBlockLifetime = maybe (llvmBlockLifetime bp) id maybe_l, + llvmBlockOffset = bvInt 0, + llvmBlockLen = sh_len, + llvmBlockShape = sh } } +llvmBlockPtrShapeUnfold _ = Nothing -- | Create a read block permission with shape @sh@, i.e., the 'LLVMBlockPerm' -- corresponding to the permission @memblock(R,0,'llvmShapeLength'(sh),sh)@ @@ -3517,16 +3681,16 @@ splitLLVMBlockPerm _ (llvmBlockShape -> PExpr_NamedShape _ _ _ _) = Nothing splitLLVMBlockPerm _ (llvmBlockShape -> PExpr_EqShape _) = Nothing splitLLVMBlockPerm _ (llvmBlockShape -> PExpr_PtrShape _ _ _) = Nothing splitLLVMBlockPerm _ (llvmBlockShape -> PExpr_FieldShape _) = Nothing -splitLLVMBlockPerm off bp@(llvmBlockShape -> PExpr_ArrayShape len stride flds) +splitLLVMBlockPerm off bp@(llvmBlockShape -> PExpr_ArrayShape len stride sh) | Just (ix, BV.BV 0) <- bvMatchFactorPlusConst (bytesToInteger stride) (bvSub off $ llvmBlockOffset bp) , off_diff <- bvSub off (llvmBlockOffset bp) = Just (bp { llvmBlockLen = off_diff, - llvmBlockShape = PExpr_ArrayShape ix stride flds }, + llvmBlockShape = PExpr_ArrayShape ix stride sh }, bp { llvmBlockOffset = off, llvmBlockLen = bvSub (llvmBlockLen bp) off_diff, - llvmBlockShape = PExpr_ArrayShape (bvSub len ix) stride flds }) + llvmBlockShape = PExpr_ArrayShape (bvSub len ix) stride sh }) splitLLVMBlockPerm off bp@(llvmBlockShape -> PExpr_SeqShape sh1 sh2) | Just sh1_len <- llvmShapeLength sh1 , off_diff <- bvSub off (llvmBlockOffset bp) @@ -3598,17 +3762,48 @@ remLLVMBLockPermRange rng bp = -- determines which disjunct should be used. These shapes are represented as a -- list of the disjuncts, which are tagged with the bitvector values @bvi@ used -- in the equality permission. -data TaggedUnionShape w +data TaggedUnionShape w sz + = TaggedUnionShape (NonEmpty (BV sz, PermExpr (LLVMShapeType w))) + +-- | A 'TaggedUnionShape' with existentially quantified tag size +data SomeTaggedUnionShape w = forall sz. (1 <= sz, KnownNat sz) => - TaggedUnionShape (NonEmpty (BV sz, PermExpr (LLVMShapeType w))) + SomeTaggedUnionShape (TaggedUnionShape w sz) -- | Extract the disjunctive shapes from a 'TaggedUnionShape' -taggedUnionDisjs :: TaggedUnionShape w -> [PermExpr (LLVMShapeType w)] +taggedUnionDisjs :: TaggedUnionShape w sz -> [PermExpr (LLVMShapeType w)] taggedUnionDisjs (TaggedUnionShape disjs) = map snd $ NonEmpty.toList disjs +-- | Extract the disjunctive shapes from a 'TaggedUnionShape' in a binding +mbTaggedUnionDisjs :: Mb ctx (TaggedUnionShape w sz) -> + Mb ctx [PermExpr (LLVMShapeType w)] +mbTaggedUnionDisjs = mbMapCl $(mkClosed [| taggedUnionDisjs |]) + +-- | Get the @n@th disjunct of a 'TaggedUnionShape' in a binding +mbTaggedUnionNthDisj :: Int -> Mb ctx (TaggedUnionShape w sz) -> + Mb ctx (PermExpr (LLVMShapeType w)) +mbTaggedUnionNthDisj n_top = + mbMapCl ($(mkClosed [| \n -> (!!n) . taggedUnionDisjs |]) + `clApply` toClosed n_top) + +-- | Get the tags from a 'TaggedUnionShape' +taggedUnionTags :: TaggedUnionShape w sz -> [BV sz] +taggedUnionTags (TaggedUnionShape disjs) = map fst $ NonEmpty.toList disjs + +-- | Build a 'TaggedUnionShape' with a single disjunct +taggedUnionSingle :: BV sz -> PermExpr (LLVMShapeType w) -> + TaggedUnionShape w sz +taggedUnionSingle tag sh = TaggedUnionShape ((tag,sh) :| []) + +-- | Add a disjunct to the front of a 'TaggedUnionShape' +taggedUnionCons :: BV sz -> PermExpr (LLVMShapeType w) -> + TaggedUnionShape w sz -> TaggedUnionShape w sz +taggedUnionCons tag sh (TaggedUnionShape disjs) = + TaggedUnionShape $ NonEmpty.cons (tag,sh) disjs + -- | Convert a 'TaggedUnionShape' to the shape it represents -taggedUnionToShape :: TaggedUnionShape w -> PermExpr (LLVMShapeType w) +taggedUnionToShape :: TaggedUnionShape w sz -> PermExpr (LLVMShapeType w) taggedUnionToShape (TaggedUnionShape disjs) = foldr1 PExpr_OrShape $ NonEmpty.map snd disjs @@ -3633,17 +3828,56 @@ getShapeBVTag _ = Nothing -- | Test if a shape is a tagged union shape and, if so, convert it to the -- 'TaggedUnionShape' representation -asTaggedUnionShape :: PermExpr (LLVMShapeType w) -> Maybe (TaggedUnionShape w) +asTaggedUnionShape :: PermExpr (LLVMShapeType w) -> + Maybe (SomeTaggedUnionShape w) asTaggedUnionShape (PExpr_OrShape sh1 sh2) - | Just (SomeBV bv1) <- getShapeBVTag sh1 - , Just (TaggedUnionShape disjs2@((bv2,_) :| _)) <- asTaggedUnionShape sh2 - , Just Refl <- testEquality (natRepr bv1) (natRepr bv2) = - Just (TaggedUnionShape (NonEmpty.cons (bv1,sh1) disjs2)) + | Just (SomeBV tag1) <- getShapeBVTag sh1 + , Just (SomeTaggedUnionShape tag_u2) <- asTaggedUnionShape sh2 + , Just Refl <- testEquality (natRepr tag1) (natRepr tag_u2) = + Just $ SomeTaggedUnionShape $ taggedUnionCons tag1 sh1 tag_u2 asTaggedUnionShape sh - | Just (SomeBV bv) <- getShapeBVTag sh = - Just (TaggedUnionShape ((bv,sh) :| [])) + | Just (SomeBV tag) <- getShapeBVTag sh = + Just $ SomeTaggedUnionShape $ taggedUnionSingle tag sh asTaggedUnionShape _ = Nothing +-- | Try to convert a @memblock@ permission in a binding to a tagged union shape +-- in a binding +mbLLVMBlockToTaggedUnion :: Mb ctx (LLVMBlockPerm w) -> + Maybe (Mb ctx (SomeTaggedUnionShape w)) +mbLLVMBlockToTaggedUnion = + mbMaybe . mbMapCl $(mkClosed [| asTaggedUnionShape . llvmBlockShape |]) + +-- | Convert a @memblock@ permission with a union shape to a field permission +-- with an equality permission @eq(z)@ with evar @z@ for the tag +taggedUnionExTagPerm :: (1 <= sz, KnownNat sz) => LLVMBlockPerm w -> + Binding (BVType sz) (LLVMFieldPerm w sz) +taggedUnionExTagPerm bp = + nu $ \z -> LLVMFieldPerm { llvmFieldRW = llvmBlockRW bp, + llvmFieldLifetime = llvmBlockLifetime bp, + llvmFieldOffset = llvmBlockOffset bp, + llvmFieldContents = + ValPerm_Eq (PExpr_LLVMWord $ PExpr_Var z) } + +-- | Convert a tagged union shape in a binding to +mbTaggedUnionExTagPerm :: (1 <= sz, KnownNat sz) => Mb ctx (LLVMBlockPerm w) -> + Mb (ctx :> BVType sz) (LLVMFieldPerm w sz) +mbTaggedUnionExTagPerm = + mbCombine RL.typeCtxProxies . mbMapCl $(mkClosed [| taggedUnionExTagPerm |]) + +-- | Find a disjunct in a 'TaggedUnionShape' with the given tag +findTaggedUnionIndex :: BV.BV sz -> TaggedUnionShape w sz -> Maybe Int +findTaggedUnionIndex tag_bv (TaggedUnionShape disjs) = + findIndex (== tag_bv) $ map fst $ NonEmpty.toList disjs + +-- | Find a disjunct in a 'TaggedUnionShape' in a binding with the given tag +mbFindTaggedUnionIndex :: BV.BV sz -> Mb ctx (TaggedUnionShape w sz) -> + Maybe Int +mbFindTaggedUnionIndex tag_bv = + mbLift . mbMapCl ($(mkClosed [| findTaggedUnionIndex |]) + `clApply` toClosed tag_bv) + +-- FIXME: delete these? +{- -- | Find a disjunct in a 'TaggedUnionShape' that could be proven at the given -- offset from the given atomic permission, by checking if it is a field or -- block permission containing an equality permission to one of the tags. If @@ -3670,15 +3904,24 @@ findTaggedUnionIndexForPerms :: PermExpr (BVType w) -> TaggedUnionShape w -> Maybe Int findTaggedUnionIndexForPerms off ps tag_un = asum $ map (\p -> findTaggedUnionIndexForPerm off p tag_un) ps +-} -- | Convert an array cell number @cell@ to the byte offset for that cell, given --- by @stride * cell + field_num@ +-- by @stride * cell@ llvmArrayCellToOffset :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> PermExpr (BVType w) -> PermExpr (BVType w) llvmArrayCellToOffset ap cell = bvMult (bytesToInteger $ llvmArrayStride ap) cell +-- | Convert an array cell number @cell@ to the "absolute" byte offset for that +-- cell, given by @off + stride * cell@, where @off@ is the offset of the +-- supplied array permission +llvmArrayCellToAbsOffset :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) +llvmArrayCellToAbsOffset ap cell = + bvAdd (llvmArrayOffset ap) (llvmArrayCellToOffset ap cell) + -- | Convert a range of cell numbers to a range of byte offsets from the -- beginning of the array permission llvmArrayCellsToOffsets :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> @@ -3716,8 +3959,8 @@ prevMachineWord w n = (bytesToMachineWords w n - 1) * machineWordBytes w -- that is the sub-array permission with no borrows of its own. permForLLVMArrayBorrow :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayBorrow w -> ValuePerm (LLVMPointerType w) -permForLLVMArrayBorrow ap (FieldBorrow ix) = - ValPerm_Conj1 $ llvmArrayFieldToAtomicPerm $ llvmArrayFieldWithOffset ap ix +permForLLVMArrayBorrow ap (FieldBorrow cell) = + ValPerm_LLVMBlock $ llvmArrayCellPerm ap cell permForLLVMArrayBorrow ap (RangeBorrow (BVRange off len)) = ValPerm_Conj1 $ Perm_LLVMArray $ ap { llvmArrayOffset = llvmArrayCellToOffset ap off, @@ -3745,31 +3988,36 @@ llvmArrayAddArrayBorrows _ _ = error "llvmArrayAddArrayBorrows" -- | Find the position in the list of borrows of an 'LLVMArrayPerm' of a -- specific borrow -llvmArrayFindBorrow :: LLVMArrayBorrow w -> LLVMArrayPerm w -> Int +llvmArrayFindBorrow :: HasCallStack => LLVMArrayBorrow w -> LLVMArrayPerm w -> + Int llvmArrayFindBorrow b ap = case findIndex (== b) (llvmArrayBorrows ap) of Just i -> i Nothing -> error "llvmArrayFindBorrow: borrow not found" -- | Remove a borrow from an 'LLVMArrayPerm' -llvmArrayRemBorrow :: LLVMArrayBorrow w -> LLVMArrayPerm w -> LLVMArrayPerm w +llvmArrayRemBorrow :: HasCallStack => LLVMArrayBorrow w -> LLVMArrayPerm w -> + LLVMArrayPerm w llvmArrayRemBorrow b ap = ap { llvmArrayBorrows = deleteNth (llvmArrayFindBorrow b ap) (llvmArrayBorrows ap) } -- | Remove a sequence of borrows from an 'LLVMArrayPerm' -llvmArrayRemBorrows :: [LLVMArrayBorrow w] -> LLVMArrayPerm w -> LLVMArrayPerm w +llvmArrayRemBorrows :: HasCallStack => [LLVMArrayBorrow w] -> LLVMArrayPerm w -> + LLVMArrayPerm w llvmArrayRemBorrows bs ap = foldr llvmArrayRemBorrow ap bs -- | Remove all borrows from the second array to the first, assuming the one is -- an offset array as in 'llvmArrayIsOffsetArray' -llvmArrayRemArrayBorrows :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayPerm w -> LLVMArrayPerm w +llvmArrayRemArrayBorrows :: HasCallStack => (1 <= w, KnownNat w) => + LLVMArrayPerm w -> LLVMArrayPerm w -> + LLVMArrayPerm w llvmArrayRemArrayBorrows ap sub_ap | Just cell_num <- llvmArrayIsOffsetArray ap sub_ap = - llvmArrayRemBorrows - (map (cellOffsetLLVMArrayBorrow cell_num) (llvmArrayBorrows sub_ap)) - ap + let sub_bs = + map (cellOffsetLLVMArrayBorrow cell_num) (llvmArrayBorrows sub_ap) + bs' = filter (flip notElem sub_bs) $ llvmArrayBorrows ap in + ap { llvmArrayBorrows = bs' } llvmArrayRemArrayBorrows _ _ = error "llvmArrayRemArrayBorrows" -- | Test if the borrows of an array can be permuted to another order @@ -3783,62 +4031,48 @@ llvmArrayBorrowsPermuteTo ap bs = -- be relative to an array with that many more cells added to the front cellOffsetLLVMArrayBorrow :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> LLVMArrayBorrow w -> LLVMArrayBorrow w -cellOffsetLLVMArrayBorrow off (FieldBorrow (LLVMArrayIndex ix fld_num)) = - FieldBorrow (LLVMArrayIndex (bvAdd ix off) fld_num) +cellOffsetLLVMArrayBorrow off (FieldBorrow ix) = + FieldBorrow (bvAdd ix off) cellOffsetLLVMArrayBorrow off (RangeBorrow rng) = RangeBorrow $ offsetBVRange off rng --- | Convert an array permission into a field permission of the same size with a --- @true@ permission, if possible -llvmArrayToField :: (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => - NatRepr sz -> LLVMArrayPerm w -> Maybe (LLVMFieldPerm w sz) -llvmArrayToField sz ap - | LLVMArrayField fp : _ <- llvmArrayFields ap - , (rw,l) <- (llvmFieldRW fp, llvmFieldLifetime fp) - , all (\(LLVMArrayField fp') -> rw == llvmFieldRW fp' && - l == llvmFieldLifetime fp') - (llvmArrayFields ap) - , [] <- llvmArrayBorrows ap - , bvEq (bvMult (bytesToBits $ - llvmArrayStride ap) (llvmArrayLen ap)) (bvInt $ intValue sz) = - Just $ LLVMFieldPerm { llvmFieldRW = rw, llvmFieldLifetime = l, - llvmFieldOffset = llvmArrayOffset ap, - llvmFieldContents = ValPerm_True } -llvmArrayToField _ _ = Nothing - --- | Test if a byte offset @o@ statically aligns with a field in an array, i.e., --- whether +-- | Test if a byte offset @o@ statically aligns with a statically-known offset +-- into some array cell, i.e., whether -- --- > o - off = stride*ix + 'llvmFieldOffset' (fields !! fld_num) +-- > o - off = stride*ix + cell_off -- --- for some @ix@ and @fld_num@, where @off@ is the array offset, @stride@ is the --- array stride, and @fields@ is the array fields. Return @ix@ and @fld_num@ on +-- for some @ix@ and @cell_off@, where @off@ is the array offset and @stride@ is +-- the array stride. Return @ix@ and @cell_off@ as an 'LLVMArrayIndex' on -- success. -matchLLVMArrayField :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> +matchLLVMArrayIndex :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> PermExpr (BVType w) -> Maybe (LLVMArrayIndex w) -matchLLVMArrayField ap o - | rel_off <- bvSub o (llvmArrayOffset ap) = - do (ix, fld_off) <- - bvMatchFactorPlusConst (bytesToInteger $ llvmArrayStride ap) rel_off - fld_num <- - findIndex (\case LLVMArrayField fp -> - bvEq (llvmFieldOffset fp) (bvBV fld_off)) - (llvmArrayFields ap) - return $ LLVMArrayIndex ix fld_num - --- | Return a list 'BVProp' stating that the field(s) represented by an array --- borrow are in the "base" set of fields in an array, before the borrows are --- considered. We assume that the borrow is statically well-formed for that --- array, meaning that the static field number of a 'FieldBorrow' refers to a --- valid field in the array perm. +matchLLVMArrayIndex ap o = + do let rel_off = bvSub o (llvmArrayOffset ap) + (ix, cell_off) <- + bvMatchFactorPlusConst (bytesToInteger $ llvmArrayStride ap) rel_off + return $ LLVMArrayIndex ix cell_off + +-- | Test if a byte offset @o@ statically aligns with a cell boundary in an +-- array, i.e., whether +-- +-- > o - off = stride*cell +-- +-- for some @cell@. Return @cell@ on success. +matchLLVMArrayCell :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> + PermExpr (BVType w) -> Maybe (PermExpr (BVType w)) +matchLLVMArrayCell ap off + | Just (LLVMArrayIndex cell (BV.BV 0)) <- matchLLVMArrayIndex ap off = + Just cell +matchLLVMArrayCell _ _ = Nothing + +-- | Return a list 'BVProp' stating that the cell(s) represented by an array +-- borrow are in the "base" set of cells in an array, before the borrows are +-- considered llvmArrayBorrowInArrayBase :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayBorrow w -> [BVProp w] -llvmArrayBorrowInArrayBase ap (FieldBorrow ix) - | llvmArrayIndexFieldNum ix >= length (llvmArrayFields ap) = - error "llvmArrayBorrowInArrayBase: invalid index" llvmArrayBorrowInArrayBase ap (FieldBorrow ix) = - [bvPropInRange (llvmArrayIndexCell ix) (llvmArrayCells ap)] + [bvPropInRange ix (llvmArrayCells ap)] llvmArrayBorrowInArrayBase ap (RangeBorrow rng) = bvPropRangeSubset rng (llvmArrayCells ap) @@ -3847,18 +4081,16 @@ llvmArrayBorrowInArrayBase ap (RangeBorrow rng) = -- statically distinct field numbers. llvmArrayBorrowsDisjoint :: (1 <= w, KnownNat w) => LLVMArrayBorrow w -> LLVMArrayBorrow w -> [BVProp w] -llvmArrayBorrowsDisjoint (FieldBorrow ix1) (FieldBorrow ix2) - | llvmArrayIndexFieldNum ix1 == llvmArrayIndexFieldNum ix2 - = [BVProp_Neq (llvmArrayIndexCell ix1) (llvmArrayIndexCell ix2)] -llvmArrayBorrowsDisjoint (FieldBorrow _) (FieldBorrow _) = [] +llvmArrayBorrowsDisjoint (FieldBorrow ix1) (FieldBorrow ix2) = + [BVProp_Neq ix1 ix2] llvmArrayBorrowsDisjoint (FieldBorrow ix) (RangeBorrow rng) = - [bvPropNotInRange (llvmArrayIndexCell ix) rng] + [bvPropNotInRange ix rng] llvmArrayBorrowsDisjoint (RangeBorrow rng) (FieldBorrow ix) = - [bvPropNotInRange (llvmArrayIndexCell ix) rng] + [bvPropNotInRange ix rng] llvmArrayBorrowsDisjoint (RangeBorrow rng1) (RangeBorrow rng2) = bvPropRangesDisjoint rng1 rng2 --- | Return a list of propositions stating that the field(s) represented by an +-- | Return a list of propositions stating that the cell(s) represented by an -- array borrow are in the set of fields of an array permission. This takes into -- account the current borrows on the array permission, which are fields that -- are /not/ currently in that array permission. @@ -3871,7 +4103,14 @@ llvmArrayBorrowInArray ap b = -- | Shorthand for 'llvmArrayBorrowInArray' with a single index llvmArrayIndexInArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayIndex w -> [BVProp w] -llvmArrayIndexInArray ap ix = llvmArrayBorrowInArray ap (FieldBorrow ix) +llvmArrayIndexInArray ap ix = + llvmArrayBorrowInArray ap (FieldBorrow $ llvmArrayIndexCell ix) + +-- | Test if a cell is in an array permission and is not currently being +-- borrowed +llvmArrayCellInArray :: (1 <= w, KnownNat w) => + LLVMArrayPerm w -> PermExpr (BVType w) -> [BVProp w] +llvmArrayCellInArray ap cell = llvmArrayBorrowInArray ap (FieldBorrow cell) -- | Test if all cell numbers in a 'BVRange' are in an array permission and are -- not currently being borrowed @@ -3886,9 +4125,8 @@ llvmArrayCellsInArray ap rng = llvmArrayBorrowInArray ap (RangeBorrow rng) llvmArrayIsOffsetArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayPerm w -> Maybe (PermExpr (BVType w)) llvmArrayIsOffsetArray ap1 ap2 - | llvmArrayStride ap1 == llvmArrayStride ap2 - , Just (LLVMArrayIndex cell_num 0) <- - matchLLVMArrayField ap1 (llvmArrayOffset ap2) = Just cell_num + | llvmArrayStride ap1 == llvmArrayStride ap2 = + matchLLVMArrayCell ap1 (llvmArrayOffset ap2) llvmArrayIsOffsetArray _ _ = Nothing -- | Build a 'BVRange' for the cells of a sub-array @ap2@ in @ap1@ @@ -3921,110 +4159,91 @@ llvmArrayContainsArray ap sub_ap = (llvmArrayRemArrayBorrows ap sub_ap) (llvmSubArrayRange ap sub_ap) +-- | Build a sub-array of an array permission at a given offset with a given +-- length, keeping only those borrows from the original array that could (in the +-- sense of 'bvPropCouldHold') overlap with the range of the sub-array. This +-- means that the borrows in the returned sub-array are an over-approximation of +-- the borrows that overlap with it, i.e., there could be borrows in the +-- returned sub-array permission that are not in its range. +llvmMakeSubArray :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> + PermExpr (BVType w) -> PermExpr (BVType w) -> + LLVMArrayPerm w +llvmMakeSubArray ap off len + | Just cell <- matchLLVMArrayCell ap off + , cell_rng <- BVRange cell len = + ap { llvmArrayOffset = off, llvmArrayLen = len, + llvmArrayBorrows = + filter (not . all bvPropHolds . + llvmArrayBorrowsDisjoint (RangeBorrow cell_rng)) $ + llvmArrayBorrows ap } +llvmMakeSubArray _ _ _ = error "llvmMakeSubArray" + -- | Test if an atomic LLVM permission potentially allows a read or write of a -- given offset. If so, return a list of the propositions required for the read --- to be allowed. For LLVM field permissions, the offset of the field must --- statically match the supplied offset, so the list of propositions will be --- empty, while for arrays, the offset must only /not/ match any outstanding --- borrows, and the propositions returned codify that as well as the requirement --- that the offset is in the array range. +-- to be allowed, and whether the propositions definitely hold (as in +-- 'bvPropHolds') or only could hold (as in 'bvPropCouldHold'). For LLVM field +-- permissions, the offset of the field must statically match the supplied +-- offset, so the list of propositions will be empty, while for arrays, the +-- offset must only /not/ match any outstanding borrows, and the propositions +-- returned codify that as well as the requirement that the offset is in the +-- array range. llvmPermContainsOffset :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - AtomicPerm (LLVMPointerType w) -> Maybe [BVProp w] + AtomicPerm (LLVMPointerType w) -> + Maybe ([BVProp w], Bool) llvmPermContainsOffset off (Perm_LLVMField fp) - | bvEq (llvmFieldOffset fp) off = Just [] + | bvEq (llvmFieldOffset fp) off = Just ([], True) llvmPermContainsOffset off (Perm_LLVMArray ap) - | Just ix <- matchLLVMArrayField ap off + | Just ix <- matchLLVMArrayIndex ap off , props <- llvmArrayIndexInArray ap ix , all bvPropCouldHold props = - Just props + Just (props, all bvPropHolds props) llvmPermContainsOffset off (Perm_LLVMBlock bp) | prop <- bvPropInRange off (llvmBlockRange bp) , bvPropCouldHold prop = - Just [prop] + Just ([prop], bvPropHolds prop) llvmPermContainsOffset _ _ = Nothing +-- | Search through a list of permissions for either some permission that +-- definitely contains (as in 'bvPropHolds') the given offset or, failing that, +-- and if the supplied 'Bool' flag is 'True', for all permissions that could (as +-- in 'bvPropCouldHold') contain the given offset. Return the indices in the +-- list for the permissions that were found. +llvmPermIndicesForOffset :: (1 <= w, KnownNat w) => + [AtomicPerm (LLVMPointerType w)] -> Bool -> + PermExpr (BVType w) -> [Int] +llvmPermIndicesForOffset ps imprecise_p off = + let ixs_props = findMaybeIndices (llvmPermContainsOffset off) ps in + case find (\(_,(_,holds)) -> holds) ixs_props of + Just (i,_) -> [i] + Nothing | imprecise_p -> map fst ixs_props + Nothing -> [] + -- | Return the total length of an LLVM array permission in bytes llvmArrayLengthBytes :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> PermExpr (BVType w) -llvmArrayLengthBytes ap = - llvmArrayIndexByteOffset ap (LLVMArrayIndex (llvmArrayLen ap) 0) +llvmArrayLengthBytes ap = llvmArrayCellToOffset ap (llvmArrayLen ap) -- | Return the byte offset of an array index from the beginning of the array llvmArrayIndexByteOffset :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayIndex w -> PermExpr (BVType w) -llvmArrayIndexByteOffset ap (LLVMArrayIndex cell fld_num) = - bvAdd (llvmArrayCellToOffset ap cell) - (llvmArrayFieldOffset (llvmArrayFields ap !! fld_num)) - --- | Return the field permission corresponding to the given index an array --- permission, offset by the array offset plus the byte offset of the field -llvmArrayFieldWithOffset :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - LLVMArrayIndex w -> LLVMArrayField w -llvmArrayFieldWithOffset ap ix = - if llvmArrayIndexFieldNum ix < length (llvmArrayFields ap) then - offsetLLVMArrayField - (bvAdd (llvmArrayOffset ap) (llvmArrayIndexByteOffset ap ix)) - (llvmArrayFields ap !! llvmArrayIndexFieldNum ix) - else - error "llvmArrayFieldWithOffset: index out of bounds" - --- | Get a list of all the fields in cell 0 of an array permission -llvmArrayHeadFields :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - [LLVMArrayField w] -llvmArrayHeadFields ap = - map (\i -> llvmArrayFieldWithOffset ap (LLVMArrayIndex (bvInt 0) i)) $ - [0 .. length (llvmArrayFields ap) - 1] - --- | Test if an array permission @ap@ is equivalent to a finite, --- statically-known list of field permissions. This is the case iff the array --- permission has a static constant length, in which case its field permissions --- are all of the permissions returned by 'llvmArrayFieldWithOffset' for array --- indices that are not borrowed in @ap@. --- --- In order to make the translation work, we also need there to be at least one --- complete array cell that is not borrowed. --- --- If all this is satisfied by @ap@, return the field permissions it is equal --- to, where those that comprise the un-borrowed cell are returned as the first --- element of the returned pair and the rest are the second. -llvmArrayAsFields :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - Maybe ([LLVMArrayField w], [LLVMArrayField w]) --- FIXME: this code is terrible! Simplify it! -llvmArrayAsFields ap - | Just len <- bvMatchConstInt (llvmArrayLen ap) - , Just cell <- - find (\i -> - not $ any (bvRangesCouldOverlap - (llvmArrayBorrowOffsets ap $ - RangeBorrow $ BVRange (bvInt i) $ bvInt 1) - . llvmArrayBorrowOffsets ap) $ llvmArrayBorrows ap) - [0 .. len-1] - , fld_nums <- [0 .. length (llvmArrayFields ap) - 1] - , all_ixs <- - concatMap (\cell' -> - map (LLVMArrayIndex $ bvInt cell') fld_nums) [0 .. len - 1] - = Just ( map (llvmArrayFieldWithOffset ap) $ - filter (bvEq (bvInt cell) . llvmArrayIndexCell) all_ixs - , map (llvmArrayFieldWithOffset ap) $ - filter (\ix -> - not (bvEq (bvInt cell) (llvmArrayIndexCell ix)) && - not (any (bvRangesCouldOverlap - (llvmArrayBorrowOffsets ap $ FieldBorrow ix) - . llvmArrayBorrowOffsets ap) $ llvmArrayBorrows ap)) - all_ixs) -llvmArrayAsFields _ = Nothing - --- | Map an offset to a borrow from an array, if possible -offsetToLLVMArrayBorrow :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - PermExpr (BVType w) -> Maybe (LLVMArrayBorrow w) -offsetToLLVMArrayBorrow ap off = FieldBorrow <$> matchLLVMArrayField ap off +llvmArrayIndexByteOffset ap (LLVMArrayIndex cell cell_off) = + bvAdd (llvmArrayCellToOffset ap cell) (bvBV cell_off) + +-- | Convert an array permission with a statically-known size @N@ to a list of +-- @memblock@ permissions for cells @0@ through @N-1@ +llvmArrayToBlocks :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> + Maybe [LLVMBlockPerm w] +llvmArrayToBlocks ap + | Just len <- bvMatchConstInt $ llvmArrayLen ap = + Just $ map (llvmArrayCellPerm ap . bvInt) [0..len-1] +llvmArrayToBlocks _ = Nothing -- | Get the range of byte offsets represented by an array borrow relative to -- the beginning of the array permission llvmArrayBorrowOffsets :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> LLVMArrayBorrow w -> BVRange w llvmArrayBorrowOffsets ap (FieldBorrow ix) = - bvRangeOfIndex $ llvmArrayIndexByteOffset ap ix + bvRangeOfIndex $ llvmArrayCellToOffset ap ix llvmArrayBorrowOffsets ap (RangeBorrow r) = llvmArrayCellsToOffsets ap r -- | Get the range of byte offsets represented by an array borrow relative to @@ -4058,69 +4277,26 @@ llvmArrayPermDivide ap len = filter (not . borrow_in_first) (llvmArrayBorrows ap) }) -{- FIXME HERE: remove these...? - --- | Test if a specific range of byte offsets from the beginning of an array --- corresponds to a borrow already on an array -llvmArrayRangeIsBorrowed :: (1 <= w, KnownNat w) => - LLVMArrayPerm w -> BVRange w -> Bool -llvmArrayRangeIsBorrowed ap rng = - elem rng (map (llvmArrayBorrowOffsets ap) $ llvmArrayBorrows ap) - --- | Test if a specific array index and field number correspond to a borrow --- already on an array -llvmArrayIndexIsBorrowed :: (1 <= w, KnownNat w) => LLVMArrayPerm w -> - PermExpr (BVType w) -> Int -> Bool -llvmArrayIndexIsBorrowed ap ix fld_num = - llvmArrayRangeIsBorrowed ap $ llvmArrayIndexToRange ap ix fld_num - --- | Build 'BVProp's stating that each borrow in an array permission is disjoint --- from an index or range -llvmArrayBorrowsDisjoint :: (1 <= w, KnownNat w) => - LLVMArrayPerm w -> BVRange w -> [BVProp w] -llvmArrayBorrowsDisjoint ap range = - map (BVProp_RangesDisjoint range . llvmArrayBorrowOffsets ap) $ - llvmArrayBorrows ap - --- | Search through a list of atomic permissions to see if one of them is an --- LLVM array permission where the given field has been borrowed. If so, return --- the index of the array permission in the list, the array permission itself, --- and the index and field number of the field in the array -findLLVMArrayWithFieldBorrow :: (1 <= w, KnownNat w) => LLVMFieldPerm w -> - [AtomicPerm (LLVMPointerType w)] -> - Maybe (Int, LLVMArrayPerm w, - PermExpr (BVType w), Int) -findLLVMArrayWithFieldBorrow _ [] = Nothing -findLLVMArrayWithFieldBorrow fp (Perm_LLVMArray ap : _) - | Just (ix, fromInteger -> fld_num) <- - bvMatchFactorPlusConst (llvmArrayStride ap) - (bvSub (llvmFieldOffset fp) (llvmArrayOffset ap)) - , llvmArrayIndexIsBorrowed ap ix fld_num = - Just (0, ap, ix, fld_num) -findLLVMArrayWithFieldBorrow fp (_ : ps) = - fmap (\(i, ap, ix, fld_num) -> (i+1, ap, ix, fld_num)) $ - findLLVMArrayWithFieldBorrow fp ps --} - --- | Create a list of field permissions the cover @N@ bytes: +-- | Create a list of field permissions that cover @N@ bytes: -- -- > ptr((W,0) |-> true, (W,M) |-> true, (W,2*M) |-> true, -- > ..., (W, (i-1)*M, 8*(sz-(i-1)*M)) |-> true) -- -- where @sz@ is the number of bytes allocated, @M@ is the machine word size in -- bytes, and @i@ is the greatest natural number such that @(i-1)*M < sz@ -llvmFieldsOfSize :: (1 <= w, KnownNat w) => f w -> Integer -> [LLVMArrayField w] +llvmFieldsOfSize :: (1 <= w, KnownNat w) => f w -> Integer -> + [AtomicPerm (LLVMPointerType w)] llvmFieldsOfSize (w :: f w) sz | sz_last_int <- 8 * (sz - prevMachineWord w sz) , Just (Some sz_last) <- someNat sz_last_int , Left LeqProof <- decideLeq (knownNat @1) sz_last = withKnownNat sz_last $ - map (\i -> LLVMArrayField $ + map (\i -> Perm_LLVMField $ (llvmFieldWrite0True @w) { llvmFieldOffset = bvInt (i * machineWordBytes w) }) [0 .. bytesToMachineWords w sz - 2] ++ - [LLVMArrayField $ + [Perm_LLVMField $ (llvmSizedFieldWrite0True w sz_last) { llvmFieldOffset = bvInt ((bytesToMachineWords w sz - 1) * machineWordBytes w) }] @@ -4130,8 +4306,13 @@ llvmFieldsOfSize (w :: f w) sz -- 'llvmFieldsOfSize' llvmFieldsPermOfSize :: (1 <= w, KnownNat w) => f w -> Integer -> ValuePerm (LLVMPointerType w) -llvmFieldsPermOfSize w n = - ValPerm_Conj $ map llvmArrayFieldToAtomicPerm $ llvmFieldsOfSize w n +llvmFieldsPermOfSize w n = ValPerm_Conj $ llvmFieldsOfSize w n + +-- | Create an LLVM shape for a single byte with @true@ permissions +llvmByteTrueShape :: (1 <= w, KnownNat w) => PermExpr (LLVMShapeType w) +llvmByteTrueShape = + PExpr_FieldShape $ LLVMFieldShape (ValPerm_True + :: ValuePerm (LLVMPointerType 8)) -- | Create an 'LLVMArrayPerm' for an array of uninitialized bytes llvmByteArrayArrayPerm :: (1 <= w, KnownNat w) => @@ -4139,18 +4320,10 @@ llvmByteArrayArrayPerm :: (1 <= w, KnownNat w) => PermExpr RWModalityType -> PermExpr LifetimeType -> LLVMArrayPerm w llvmByteArrayArrayPerm off len rw l = - LLVMArrayPerm { - llvmArrayOffset = off, - llvmArrayLen = len, - llvmArrayStride = 1, - llvmArrayFields = - [LLVMArrayField $ LLVMFieldPerm { - llvmFieldRW = rw, - llvmFieldLifetime = l, - llvmFieldOffset = bvInt 0, - llvmFieldContents = (ValPerm_True - :: ValuePerm (LLVMPointerType 8)) }], - llvmArrayBorrows = [] } + LLVMArrayPerm { llvmArrayRW = rw, llvmArrayLifetime = l, + llvmArrayOffset = off, llvmArrayLen = len, + llvmArrayStride = 1, llvmArrayCellShape = llvmByteTrueShape, + llvmArrayBorrows = [] } -- | Create a permission for an array of bytes llvmByteArrayPerm :: (1 <= w, KnownNat w) => @@ -4224,12 +4397,6 @@ offsetLLVMFieldPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> offsetLLVMFieldPerm off (LLVMFieldPerm {..}) = LLVMFieldPerm { llvmFieldOffset = bvAdd llvmFieldOffset off, ..} --- | Add an offset to an array field -offsetLLVMArrayField :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> - LLVMArrayField w -> LLVMArrayField w -offsetLLVMArrayField off (LLVMArrayField fp) = - LLVMArrayField $ offsetLLVMFieldPerm off fp - -- | Add an offset to an array permission offsetLLVMArrayPerm :: (1 <= w, KnownNat w) => PermExpr (BVType w) -> LLVMArrayPerm w -> LLVMArrayPerm w @@ -4481,9 +4648,8 @@ atomicPermIsCopyable (Perm_LLVMField llvmFieldContents = p })) = permIsCopyable p atomicPermIsCopyable (Perm_LLVMField _) = False -atomicPermIsCopyable (Perm_LLVMArray - (LLVMArrayPerm { llvmArrayFields = fs })) = - all (atomicPermIsCopyable . llvmArrayFieldToAtomicPerm) fs +atomicPermIsCopyable (Perm_LLVMArray (LLVMArrayPerm {..})) = + llvmArrayRW == PExpr_Read && shapeIsCopyable llvmArrayRW llvmArrayCellShape atomicPermIsCopyable (Perm_LLVMBlock (LLVMBlockPerm {..})) = llvmBlockRW == PExpr_Read && shapeIsCopyable llvmBlockRW llvmBlockShape atomicPermIsCopyable (Perm_LLVMFree _) = True @@ -4537,8 +4703,7 @@ shapeIsCopyable rw (PExpr_PtrShape maybe_rw' _ sh) = let rw' = maybe rw id maybe_rw' in rw' == PExpr_Read && shapeIsCopyable rw' sh shapeIsCopyable _ (PExpr_FieldShape (LLVMFieldShape p)) = permIsCopyable p -shapeIsCopyable _ (PExpr_ArrayShape _ _ flds) = - all (\(LLVMFieldShape p) -> permIsCopyable p) flds +shapeIsCopyable rw (PExpr_ArrayShape _ _ sh) = shapeIsCopyable rw sh shapeIsCopyable rw (PExpr_SeqShape sh1 sh2) = shapeIsCopyable rw sh1 && shapeIsCopyable rw sh2 shapeIsCopyable rw (PExpr_OrShape sh1 sh2) = @@ -4568,6 +4733,11 @@ lownedPermCouldProve (LOwnedPermField (PExpr_Var x) fp) ps = bvCouldBeInRange (llvmFieldOffset fp) rng _ -> False) $ varAtomicPermsInDistPerms x ps +lownedPermCouldProve (LOwnedPermArray (PExpr_Var x) ap) ps = + any (\case (llvmAtomicPermRange -> Just rng) -> + bvRangesCouldOverlap (llvmArrayAbsOffsets ap) rng + _ -> False) $ + varAtomicPermsInDistPerms x ps lownedPermCouldProve (LOwnedPermBlock (PExpr_Var x) bp) ps = any (\case (llvmAtomicPermRange -> Just rng) -> bvRangesCouldOverlap (llvmBlockRange bp) rng @@ -4696,8 +4866,8 @@ instance FreeVars (PermExpr a) where freeVars (PExpr_PtrShape maybe_rw maybe_l sh) = NameSet.unions [freeVars maybe_rw, freeVars maybe_l, freeVars sh] freeVars (PExpr_FieldShape fld) = freeVars fld - freeVars (PExpr_ArrayShape len _ flds) = - NameSet.union (freeVars len) (freeVars flds) + freeVars (PExpr_ArrayShape len _ sh) = + NameSet.union (freeVars len) (freeVars sh) freeVars (PExpr_SeqShape sh1 sh2) = NameSet.union (freeVars sh1) (freeVars sh2) freeVars (PExpr_OrShape sh1 sh2) = @@ -4764,14 +4934,13 @@ instance FreeVars (LLVMFieldPerm w sz) where NameSet.unions [freeVars llvmFieldRW, freeVars llvmFieldLifetime, freeVars llvmFieldOffset, freeVars llvmFieldContents] -instance FreeVars (LLVMArrayField w) where - freeVars (LLVMArrayField fp) = freeVars fp - instance FreeVars (LLVMArrayPerm w) where freeVars (LLVMArrayPerm {..}) = - NameSet.unions [freeVars llvmArrayOffset, + NameSet.unions [freeVars llvmArrayRW, + freeVars llvmArrayLifetime, + freeVars llvmArrayOffset, freeVars llvmArrayLen, - freeVars llvmArrayFields, + freeVars llvmArrayCellShape, freeVars llvmArrayBorrows] instance FreeVars (LLVMArrayIndex w) where @@ -4793,6 +4962,8 @@ instance FreeVars (PermOffset tp) where instance FreeVars (LOwnedPerm a) where freeVars (LOwnedPermField e fp) = NameSet.unions [freeVars e, freeVars fp] + freeVars (LOwnedPermArray e ap) = + NameSet.unions [freeVars e, freeVars ap] freeVars (LOwnedPermBlock e bp) = NameSet.unions [freeVars e, freeVars bp] @@ -4866,13 +5037,11 @@ instance NeededVars (LLVMFieldPerm w sz) where NameSet.unions [freeVars llvmFieldOffset, neededVars llvmFieldRW, neededVars llvmFieldLifetime, neededVars llvmFieldContents] -instance NeededVars (LLVMArrayField w) where - neededVars (LLVMArrayField fp) = neededVars fp - instance NeededVars (LLVMArrayPerm w) where neededVars (LLVMArrayPerm {..}) = - NameSet.unions [freeVars llvmArrayOffset, freeVars llvmArrayLen, - freeVars llvmArrayBorrows, neededVars llvmArrayFields] + NameSet.unions [neededVars llvmArrayRW, neededVars llvmArrayLifetime, + freeVars llvmArrayOffset, freeVars llvmArrayLen, + freeVars llvmArrayBorrows, neededVars llvmArrayCellShape] instance NeededVars (LLVMBlockPerm w) where neededVars (LLVMBlockPerm {..}) = @@ -4903,10 +5072,8 @@ readOnlyShape e@(PExpr_PtrShape _ (Just _) _) = e readOnlyShape (PExpr_PtrShape _ Nothing sh) = PExpr_PtrShape (Just PExpr_Read) Nothing $ readOnlyShape sh readOnlyShape e@(PExpr_FieldShape _) = e -readOnlyShape e@(PExpr_ArrayShape _ _ _) = - -- FIXME: when array shapes contain lists of shapes instead of lists of - -- permissions, this needs to map readOnlyShape to all of those shapes - e +readOnlyShape (PExpr_ArrayShape len stride sh) = + PExpr_ArrayShape len stride $ readOnlyShape sh readOnlyShape (PExpr_SeqShape sh1 sh2) = PExpr_SeqShape (readOnlyShape sh1) (readOnlyShape sh2) readOnlyShape (PExpr_OrShape sh1 sh2) = @@ -5089,9 +5256,9 @@ instance SubstVar s m => Substable s (PermExpr a) m where <*> genSubst s sh [nuMP| PExpr_FieldShape sh |] -> PExpr_FieldShape <$> genSubst s sh - [nuMP| PExpr_ArrayShape len stride flds |] -> + [nuMP| PExpr_ArrayShape len stride sh |] -> PExpr_ArrayShape <$> genSubst s len <*> return (mbLift stride) - <*> genSubst s flds + <*> genSubst s sh [nuMP| PExpr_SeqShape sh1 sh2 |] -> PExpr_SeqShape <$> genSubst s sh1 <*> genSubst s sh2 [nuMP| PExpr_OrShape sh1 sh2 |] -> @@ -5226,19 +5393,15 @@ instance SubstVar s m => Substable s (LLVMFieldPerm w sz) m where LLVMFieldPerm <$> genSubst s rw <*> genSubst s ls <*> genSubst s off <*> genSubst s p -instance SubstVar s m => Substable s (LLVMArrayField w) m where - genSubst s (mbMatch -> [nuMP| LLVMArrayField fp |]) = - LLVMArrayField <$> genSubst s fp - instance SubstVar s m => Substable s (LLVMArrayPerm w) m where - genSubst s (mbMatch -> [nuMP| LLVMArrayPerm off len stride pps bs |]) = - LLVMArrayPerm <$> genSubst s off <*> genSubst s len <*> - return (mbLift stride) <*> mapM (genSubst s) (mbList pps) - <*> mapM (genSubst s) (mbList bs) + genSubst s (mbMatch -> [nuMP| LLVMArrayPerm rw l off len stride sh bs |]) = + LLVMArrayPerm <$> genSubst s rw <*> genSubst s l <*> genSubst s off + <*> genSubst s len <*> return (mbLift stride) <*> genSubst s sh + <*> genSubst s bs instance SubstVar s m => Substable s (LLVMArrayIndex w) m where - genSubst s (mbMatch -> [nuMP| LLVMArrayIndex ix fld_num |]) = - LLVMArrayIndex <$> genSubst s ix <*> return (mbLift fld_num) + genSubst s (mbMatch -> [nuMP| LLVMArrayIndex ix off |]) = + LLVMArrayIndex <$> genSubst s ix <*> return (mbLift off) instance SubstVar s m => Substable s (LLVMArrayBorrow w) m where genSubst s mb_borrow = case mbMatch mb_borrow of @@ -5258,6 +5421,8 @@ instance SubstVar s m => Substable s (LOwnedPerm a) m where genSubst s mb_x = case mbMatch mb_x of [nuMP| LOwnedPermField e fp |] -> LOwnedPermField <$> genSubst s e <*> genSubst s fp + [nuMP| LOwnedPermArray e ap |] -> + LOwnedPermArray <$> genSubst s e <*> genSubst s ap [nuMP| LOwnedPermBlock e bp |] -> LOwnedPermBlock <$> genSubst s e <*> genSubst s bp @@ -5311,6 +5476,9 @@ instance SubstVar s m => Substable s (LifetimeFunctor args a) m where genSubst s mb_x = case mbMatch mb_x of [nuMP| LTFunctorField off p |] -> LTFunctorField <$> genSubst s off <*> genSubst s p + [nuMP| LTFunctorArray off len stride sh bs |] -> + LTFunctorArray <$> genSubst s off <*> genSubst s len <*> + return (mbLift stride) <*> genSubst s sh <*> genSubst s bs [nuMP| LTFunctorBlock off len sh |] -> LTFunctorBlock <$> genSubst s off <*> genSubst s len <*> genSubst s sh @@ -5827,11 +5995,11 @@ instance AbstractVars (PermExpr a) where abstractPEVars ns1 ns2 (PExpr_FieldShape fsh) = absVarsReturnH ns1 ns2 ($(mkClosed [| PExpr_FieldShape |])) `clMbMbApplyM` abstractPEVars ns1 ns2 fsh - abstractPEVars ns1 ns2 (PExpr_ArrayShape len stride flds) = + abstractPEVars ns1 ns2 (PExpr_ArrayShape len stride sh) = absVarsReturnH ns1 ns2 ($(mkClosed [| flip PExpr_ArrayShape |]) `clApply` toClosed stride) `clMbMbApplyM` abstractPEVars ns1 ns2 len - `clMbMbApplyM` abstractPEVars ns1 ns2 flds + `clMbMbApplyM` abstractPEVars ns1 ns2 sh abstractPEVars ns1 ns2 (PExpr_SeqShape sh1 sh2) = absVarsReturnH ns1 ns2 $(mkClosed [| PExpr_SeqShape |]) `clMbMbApplyM` abstractPEVars ns1 ns2 sh1 @@ -5986,14 +6154,11 @@ instance AbstractVars (LLVMFieldPerm w sz) where `clMbMbApplyM` abstractPEVars ns1 ns2 off `clMbMbApplyM` abstractPEVars ns1 ns2 p -instance AbstractVars (LLVMArrayField w) where - abstractPEVars ns1 ns2 (LLVMArrayField fp) = - absVarsReturnH ns1 ns2 $(mkClosed [| LLVMArrayField |]) - `clMbMbApplyM` abstractPEVars ns1 ns2 fp - instance AbstractVars (LLVMArrayPerm w) where - abstractPEVars ns1 ns2 (LLVMArrayPerm off len str flds bs) = + abstractPEVars ns1 ns2 (LLVMArrayPerm rw l off len str flds bs) = absVarsReturnH ns1 ns2 $(mkClosed [| LLVMArrayPerm |]) + `clMbMbApplyM` abstractPEVars ns1 ns2 rw + `clMbMbApplyM` abstractPEVars ns1 ns2 l `clMbMbApplyM` abstractPEVars ns1 ns2 off `clMbMbApplyM` abstractPEVars ns1 ns2 len `clMbMbApplyM` abstractPEVars ns1 ns2 str @@ -6001,12 +6166,10 @@ instance AbstractVars (LLVMArrayPerm w) where `clMbMbApplyM` abstractPEVars ns1 ns2 bs instance AbstractVars (LLVMArrayIndex w) where - abstractPEVars ns1 ns2 (LLVMArrayIndex ix fld_num) = - absVarsReturnH ns1 ns2 $(mkClosed - [| \ix' fld_num' -> - LLVMArrayIndex ix' $ fromInteger fld_num' |]) + abstractPEVars ns1 ns2 (LLVMArrayIndex ix off) = + absVarsReturnH ns1 ns2 $(mkClosed [| LLVMArrayIndex |]) `clMbMbApplyM` abstractPEVars ns1 ns2 ix - `clMbMbApplyM` abstractPEVars ns1 ns2 (toInteger fld_num) + `clMbMbApplyM` abstractPEVars ns1 ns2 off instance AbstractVars (PermOffset a) where abstractPEVars ns1 ns2 NoPermOffset = @@ -6050,6 +6213,10 @@ instance AbstractVars (LOwnedPerm a) where absVarsReturnH ns1 ns2 $(mkClosed [| LOwnedPermField |]) `clMbMbApplyM` abstractPEVars ns1 ns2 e `clMbMbApplyM` abstractPEVars ns1 ns2 fp + abstractPEVars ns1 ns2 (LOwnedPermArray e ap) = + absVarsReturnH ns1 ns2 $(mkClosed [| LOwnedPermArray |]) + `clMbMbApplyM` abstractPEVars ns1 ns2 e + `clMbMbApplyM` abstractPEVars ns1 ns2 ap abstractPEVars ns1 ns2 (LOwnedPermBlock e bp) = absVarsReturnH ns1 ns2 $(mkClosed [| LOwnedPermBlock |]) `clMbMbApplyM` abstractPEVars ns1 ns2 e @@ -6181,8 +6348,8 @@ instance AbstractNamedShape w (PermExpr a) where abstractNSM (PExpr_PtrShape rw l sh) = mbMap3 PExpr_PtrShape <$> abstractNSM rw <*> abstractNSM l <*> abstractNSM sh abstractNSM (PExpr_FieldShape fsh) = fmap PExpr_FieldShape <$> abstractNSM fsh - abstractNSM (PExpr_ArrayShape len s flds) = - mbMap3 PExpr_ArrayShape <$> abstractNSM len <*> pureBindingM s <*> abstractNSM flds + abstractNSM (PExpr_ArrayShape len s sh) = + mbMap3 PExpr_ArrayShape <$> abstractNSM len <*> pureBindingM s <*> abstractNSM sh abstractNSM (PExpr_SeqShape sh1 sh2) = mbMap2 PExpr_SeqShape <$> abstractNSM sh1 <*> abstractNSM sh2 abstractNSM (PExpr_OrShape sh1 sh2) = @@ -6238,18 +6405,19 @@ instance AbstractNamedShape w' (LLVMFieldPerm w sz) where mbMap4 LLVMFieldPerm <$> abstractNSM rw <*> abstractNSM l <*> abstractNSM off <*> abstractNSM p -instance AbstractNamedShape w' (LLVMArrayPerm w) where - abstractNSM (LLVMArrayPerm off len s pps bs) = - mbMap5 LLVMArrayPerm <$> abstractNSM off <*> abstractNSM len - <*> pureBindingM s <*> abstractNSM pps - <*> abstractNSM bs +-- | FIXME: move this to Hobbits? +mbApplyM :: Applicative m => m (Mb ctx (a -> b)) -> m (Mb ctx a) -> m (Mb ctx b) +mbApplyM f x = mbApply <$> f <*> x -instance AbstractNamedShape w' (LLVMArrayField w) where - abstractNSM (LLVMArrayField fp) = fmap LLVMArrayField <$> abstractNSM fp +instance AbstractNamedShape w' (LLVMArrayPerm w) where + abstractNSM (LLVMArrayPerm rw l off len stride sh bs) = + pureBindingM LLVMArrayPerm `mbApplyM` abstractNSM rw + `mbApplyM` abstractNSM l `mbApplyM` abstractNSM off + `mbApplyM` abstractNSM len `mbApplyM` pureBindingM stride + `mbApplyM` abstractNSM sh `mbApplyM` abstractNSM bs instance AbstractNamedShape w' (LLVMArrayBorrow w) where - abstractNSM (FieldBorrow (LLVMArrayIndex e i)) = - fmap (\e' -> FieldBorrow (LLVMArrayIndex e' i)) <$> abstractNSM e + abstractNSM (FieldBorrow ix) = fmap FieldBorrow <$> abstractNSM ix abstractNSM (RangeBorrow rng) = pureBindingM (RangeBorrow rng) instance AbstractNamedShape w' (LLVMBlockPerm w) where @@ -6265,6 +6433,8 @@ instance AbstractNamedShape w (LOwnedPerms ps) where instance AbstractNamedShape w (LOwnedPerm a) where abstractNSM (LOwnedPermField e fp) = mbMap2 LOwnedPermField <$> abstractNSM e <*> abstractNSM fp + abstractNSM (LOwnedPermArray e ap) = + mbMap2 LOwnedPermArray <$> abstractNSM e <*> abstractNSM ap abstractNSM (LOwnedPermBlock e bp) = mbMap2 LOwnedPermBlock <$> abstractNSM e <*> abstractNSM bp @@ -6279,6 +6449,99 @@ instance AbstractNamedShape w (FunPerm ghosts args ret) where <*> abstractNSM perms_out +$(mkNuMatching [t| forall a . PermExpr a |]) +$(mkNuMatching [t| forall a . BVFactor a |]) +$(mkNuMatching [t| forall w. BVRange w |]) +$(mkNuMatching [t| forall w. BVProp w |]) +$(mkNuMatching [t| forall a . AtomicPerm a |]) +$(mkNuMatching [t| forall a . ValuePerm a |]) +-- $(mkNuMatching [t| forall as. ValuePerms as |]) +$(mkNuMatching [t| forall a . VarAndPerm a |]) + +instance NuMatchingAny1 PermExpr where + nuMatchingAny1Proof = nuMatchingProof + +instance NuMatchingAny1 ValuePerm where + nuMatchingAny1Proof = nuMatchingProof + +instance NuMatchingAny1 VarAndPerm where + nuMatchingAny1Proof = nuMatchingProof + +$(mkNuMatching [t| forall w sz . LLVMFieldPerm w sz |]) +$(mkNuMatching [t| forall w . LLVMArrayPerm w |]) +$(mkNuMatching [t| forall w . LLVMBlockPerm w |]) +$(mkNuMatching [t| RWModality |]) +$(mkNuMatching [t| forall w . LLVMArrayIndex w |]) +$(mkNuMatching [t| forall w . LLVMArrayBorrow w |]) +$(mkNuMatching [t| forall w . LLVMFieldShape w |]) +$(mkNuMatching [t| forall w . LOwnedPerm w |]) +$(mkNuMatching [t| forall ghosts args ret. FunPerm ghosts args ret |]) +$(mkNuMatching [t| forall args ret. SomeFunPerm args ret |]) +$(mkNuMatching [t| forall ns. NameSortRepr ns |]) +$(mkNuMatching [t| forall ns args a. NameReachConstr ns args a |]) +$(mkNuMatching [t| forall ns args a. NamedPermName ns args a |]) +$(mkNuMatching [t| SomeNamedPermName |]) +$(mkNuMatching [t| forall b args w. NamedShape b args w |]) +$(mkNuMatching [t| forall b args w. NamedShapeBody b args w |]) +$(mkNuMatching [t| forall a. PermOffset a |]) +$(mkNuMatching [t| forall ns args a. NamedPerm ns args a |]) +$(mkNuMatching [t| forall b args a. OpaquePerm b args a |]) +$(mkNuMatching [t| forall args a reach. ReachMethods args a reach |]) +$(mkNuMatching [t| forall b reach args a. RecPerm b reach args a |]) +$(mkNuMatching [t| forall b args a. DefinedPerm b args a |]) +$(mkNuMatching [t| forall args a. LifetimeFunctor args a |]) +$(mkNuMatching [t| forall ps. LifetimeCurrentPerms ps |]) +$(mkNuMatching [t| forall a. SomeLLVMBlockPerm a |]) + +instance NuMatchingAny1 LOwnedPerm where + nuMatchingAny1Proof = nuMatchingProof + +instance NuMatchingAny1 DistPerms where + nuMatchingAny1Proof = nuMatchingProof + +instance Liftable RWModality where + mbLift mb_rw = case mbMatch mb_rw of + [nuMP| Write |] -> Write + [nuMP| Read |] -> Read + +instance Closable RWModality where + toClosed Write = $(mkClosed [| Write |]) + toClosed Read = $(mkClosed [| Read |]) + +instance Closable (NameSortRepr ns) where + toClosed (DefinedSortRepr b) = + $(mkClosed [| DefinedSortRepr |]) `clApply` toClosed b + toClosed (OpaqueSortRepr b) = + $(mkClosed [| OpaqueSortRepr |]) `clApply` toClosed b + toClosed (RecursiveSortRepr b reach) = + $(mkClosed [| RecursiveSortRepr |]) + `clApply` toClosed b `clApply` toClosed reach + +instance Liftable (NameSortRepr ns) where + mbLift = unClosed . mbLift . fmap toClosed + +instance Closable (NameReachConstr ns args a) where + toClosed NameReachConstr = $(mkClosed [| NameReachConstr |]) + toClosed NameNonReachConstr = $(mkClosed [| NameNonReachConstr |]) + +instance Liftable (NameReachConstr ns args a) where + mbLift = unClosed . mbLift . fmap toClosed + +instance Liftable (NamedPermName ns args a) where + mbLift (mbMatch -> [nuMP| NamedPermName n tp args ns r |]) = + NamedPermName (mbLift n) (mbLift tp) (mbLift args) (mbLift ns) (mbLift r) + +instance Liftable SomeNamedPermName where + mbLift (mbMatch -> [nuMP| SomeNamedPermName rpn |]) = + SomeNamedPermName $ mbLift rpn + +instance Liftable (ReachMethods args a reach) where + mbLift mb_x = case mbMatch mb_x of + [nuMP| ReachMethods transIdent |] -> + ReachMethods (mbLift transIdent) + [nuMP| NoReachMethods |] -> NoReachMethods + + ---------------------------------------------------------------------- -- * Permission Environments ---------------------------------------------------------------------- @@ -6361,7 +6624,8 @@ data PermEnv = PermEnv { permEnvHints :: [Hint] } -$(mkNuMatching [t| forall w. TaggedUnionShape w |]) +$(mkNuMatching [t| forall w sz. TaggedUnionShape w sz |]) +$(mkNuMatching [t| forall w. SomeTaggedUnionShape w |]) $(mkNuMatching [t| forall ctx. PermVarSubst ctx |]) $(mkNuMatching [t| PermEnvFunEntry |]) $(mkNuMatching [t| SomeNamedPerm |]) @@ -6775,15 +7039,14 @@ instance (1 <= w, KnownNat w, 1 <= sz, KnownNat sz) => getDetVarsClauses llvmFieldLifetime, getDetVarsClauses llvmFieldContents] -instance (1 <= w, KnownNat w) => GetDetVarsClauses (LLVMArrayField w) where - getDetVarsClauses (LLVMArrayField fp) = getDetVarsClauses fp - instance (1 <= w, KnownNat w) => GetDetVarsClauses (LLVMArrayPerm w) where getDetVarsClauses (LLVMArrayPerm {..}) = map (detVarsClauseAddLHS $ NameSet.unions [freeVars llvmArrayOffset, freeVars llvmArrayLen, - freeVars llvmArrayBorrows]) <$> - concat <$> mapM getDetVarsClauses llvmArrayFields + freeVars llvmArrayBorrows]) <$> concat <$> + sequence [getDetVarsClauses llvmArrayRW, + getDetVarsClauses llvmArrayLifetime, + getDetVarsClauses llvmArrayCellShape] instance (1 <= w, KnownNat w) => GetDetVarsClauses (LLVMBlockPerm w) where getDetVarsClauses (LLVMBlockPerm {..}) = @@ -6810,9 +7073,8 @@ getShapeDetVarsClauses (PExpr_PtrShape _ _ sh) = -- FIXME: maybe also include the variables determined by the modalities? getShapeDetVarsClauses sh getShapeDetVarsClauses (PExpr_FieldShape fldsh) = getDetVarsClauses fldsh -getShapeDetVarsClauses (PExpr_ArrayShape len _ fldshs) = - map (detVarsClauseAddLHS (freeVars len)) <$> - getDetVarsClauses fldshs +getShapeDetVarsClauses (PExpr_ArrayShape len _ sh) = + map (detVarsClauseAddLHS (freeVars len)) <$> getDetVarsClauses sh getShapeDetVarsClauses (PExpr_SeqShape sh1 sh2) | isJust $ llvmShapeLength sh1 = (++) <$> getDetVarsClauses sh1 <*> getDetVarsClauses sh2 diff --git a/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs b/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs index 05910c3aae..86e944900f 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/RustTypes.hs @@ -240,40 +240,6 @@ namedShapeShapeFun w (SomeNamedShape nmsh) = pretty "Expected:" <+> pretty (intValue w), pretty "Actual:" <+> pretty (intValue (natRepr nmsh))] --- | A table for converting Rust base types to shapes -namedTypeTable :: (1 <= w, KnownNat w) => prx w -> [(String,SomeShapeFun w)] -namedTypeTable w = - [("bool", sizedIntShapeFun @_ @1 w Proxy), - ("i8", sizedIntShapeFun @_ @8 w Proxy), - ("u8", sizedIntShapeFun @_ @8 w Proxy), - ("i16", sizedIntShapeFun @_ @16 w Proxy), - ("u16", sizedIntShapeFun @_ @16 w Proxy), - ("i32", sizedIntShapeFun @_ @32 w Proxy), - ("u32", sizedIntShapeFun @_ @32 w Proxy), - ("i64", sizedIntShapeFun @_ @64 w Proxy), - ("u64", sizedIntShapeFun @_ @64 w Proxy), - - -- isize and usize are the same size as pointers, which is w - ("isize", sizedIntShapeFun w w), - ("usize", sizedIntShapeFun w w), - - -- Strings contain three fields: a pointer, a length, and a capacity - ("String", - constShapeFun (PExpr_ExShape $ nu $ \cap -> - (PExpr_SeqShape - -- The pointer to an array of bytes - (PExpr_PtrShape Nothing Nothing $ - PExpr_ArrayShape (PExpr_Var cap) 1 - [LLVMFieldShape $ ValPerm_Exists $ llvmExEqWord $ Proxy @8]) - (PExpr_SeqShape - -- The length value - (PExpr_FieldShape $ LLVMFieldShape $ - ValPerm_Exists $ llvmExEqWord w) - -- The capacity - (PExpr_FieldShape $ LLVMFieldShape $ ValPerm_Eq $ - PExpr_LLVMWord $ PExpr_Var cap))))) - ] - -- | A fully qualified Rust path without any of the parameters; e.g., -- @Foo::Bar::Baz@ just becomes @[Foo,Bar,Baz]@ newtype RustName = RustName [Ident] deriving (Eq) @@ -339,11 +305,12 @@ withRecType rust_n rust_ns rec_n = local (\info -> info { rciRecType = Just (rus -- the stride and the fields of the slice, where the latter can have the length -- free matchSliceShape :: PermExpr (LLVMShapeType w) -> - Maybe (Bytes, Binding (BVType w) [LLVMFieldShape w]) + Maybe (Bytes, + Binding (BVType w) (PermExpr (LLVMShapeType w))) matchSliceShape (PExpr_ExShape - [nuP| PExpr_ArrayShape (PExpr_Var len) stride fshs |]) + [nuP| PExpr_ArrayShape (PExpr_Var len) stride mb_sh |]) | Left Member_Base <- mbNameBoundP len = - Just (mbLift stride, fshs) + Just (mbLift stride, mb_sh) matchSliceShape (PExpr_NamedShape _ _ nmsh@(NamedShape _ _ (DefinedShapeBody _)) args) = matchSliceShape (unfoldNamedShape nmsh args) @@ -379,15 +346,13 @@ instance RsConvert w [PathParameters Span] (Some TypedPermExprs) where instance RsConvert w (Ty Span) (PermExpr (LLVMShapeType w)) where rsConvert w (Slice tp _) = do sh <- rsConvert w tp - case matchLLVMFieldShapeSeq sh of - Just fshs -> + case llvmShapeLength sh of + Just (bvMatchConstInt -> Just stride) -> return (PExpr_ExShape $ nu $ \n -> - PExpr_ArrayShape (PExpr_Var n) - (fromIntegral $ sum $ map llvmFieldShapeLength fshs) - fshs) + PExpr_ArrayShape (PExpr_Var n) (fromInteger stride) sh) _ -> rsPPInfo >>= \ppInfo -> - fail ("rsConvert: slices not yet supported of type: " + fail ("rsConvert: slices not supported for dynamically-sized type: " ++ show (RustPP.pretty tp) ++ " with translation:\n" ++ renderDoc (permPretty ppInfo sh)) rsConvert _ (Rptr Nothing _ _ _) = @@ -398,13 +363,13 @@ instance RsConvert w (Ty Span) (PermExpr (LLVMShapeType w)) where rw <- rsConvert w mut case sh of -- Test if sh is a slice type = an array of existential length - (matchSliceShape -> Just (stride,fshs)) -> + (matchSliceShape -> Just (stride,mb_sh)) -> -- If so, build a "fat pointer" = a pair of a pointer to our array -- shape plus a length value return $ PExpr_ExShape $ nu $ \n -> PExpr_SeqShape (PExpr_PtrShape rw Nothing $ PExpr_ArrayShape (PExpr_Var n) stride $ - subst1 (PExpr_Var n) fshs) + subst1 (PExpr_Var n) mb_sh) (PExpr_FieldShape $ LLVMFieldShape $ ValPerm_Eq $ PExpr_LLVMWord $ PExpr_Var n) @@ -1073,6 +1038,15 @@ abstractMbLOPsModalities mb_lops = case mbMatch mb_lops of LOwnedPermField e (fp { llvmFieldRW = PExpr_Var rw, llvmFieldLifetime = PExpr_Var l })) mb_e mb_fp) + [nuMP| lops :>: LOwnedPermArray mb_e mb_arrp |] -> + liftA2 (mbMap2 (:>:)) + (abstractMbLOPsModalities lops) + (SomeTypedMb (CruCtxCons (CruCtxCons CruCtxNil RWModalityRepr) LifetimeRepr) $ + nuMulti (MNil :>: Proxy :>: Proxy) $ \(_ :>: rw :>: l) -> + mbMap2 (\e arrp -> + LOwnedPermArray e (arrp { llvmArrayRW = PExpr_Var rw, + llvmArrayLifetime = PExpr_Var l })) + mb_e mb_arrp) [nuMP| lops :>: LOwnedPermBlock mb_e mb_bp |] -> liftA2 (mbMap2 (:>:)) (abstractMbLOPsModalities lops) diff --git a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs index b2beb6506d..35b23a423c 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/SAWTranslation.hs @@ -106,7 +106,14 @@ nlPrettyCallStack = ("\n" ++) . prettyCallStack -- construct in Haskell. data TypeTrans tr = TypeTrans { typeTransTypes :: [OpenTerm], - typeTransF :: [OpenTerm] -> tr } + typeTransFun :: [OpenTerm] -> tr } + +-- | Apply the 'typeTransFun' of a 'TypeTrans' with the call stack +typeTransF :: HasCallStack => TypeTrans tr -> [OpenTerm] -> tr +typeTransF (TypeTrans tps f) ts | length tps == length ts = f ts +typeTransF (TypeTrans tps _) ts = + error ("Type translation expected " ++ show (length tps) ++ + " arguments, but got " ++ show (length ts)) instance Functor TypeTrans where fmap f (TypeTrans ts tp_f) = TypeTrans ts (f . tp_f) @@ -840,11 +847,11 @@ instance TransInfo info => [nuMP| PExpr_PtrShape _ _ sh |] -> translate sh [nuMP| PExpr_FieldShape fsh |] -> ETrans_Term <$> tupleOfTypes <$> translate fsh - [nuMP| PExpr_ArrayShape mb_len _ mb_fshs |] -> + [nuMP| PExpr_ArrayShape mb_len _ mb_sh |] -> do let w = natVal4 mb_len let w_term = natOpenTerm w len_term <- translate1 mb_len - elem_tp <- tupleOfTypes <$> concat <$> translate mb_fshs + elem_tp <- translate1 mb_sh return $ ETrans_Term $ applyOpenTermMulti (globalOpenTerm "Prelude.BVVec") [w_term, len_term, elem_tp] @@ -1030,26 +1037,21 @@ bvRangeTransLen :: BVRangeTrans ctx w -> ExprTrans (BVType w) bvRangeTransLen (BVRangeTrans _ _ len) = len -- | The translation of an LLVM array permission is a SAW term of @BVVec@ type, --- along with a type translation for its fields and proof terms stating that all --- of the borrows are in the array. Note that the type translation for the --- fields is always a 'tupleTypeTrans', i.e., has at most one SAW type. +-- along with a SAW term for its length as a bitvector and the type translation +-- for a @memblock@ permission to its head cell, which can be offset to get a +-- @memblock@ permission for any of its cells. data LLVMArrayPermTrans ctx w = LLVMArrayPermTrans { llvmArrayTransPerm :: Mb ctx (LLVMArrayPerm w), llvmArrayTransLen :: OpenTerm, - llvmArrayTransFields :: TypeTrans [AtomicPermTrans ctx (LLVMPointerType w)], + llvmArrayTransHeadCell :: TypeTrans (AtomicPermTrans ctx (LLVMPointerType w)), -- llvmArrayTransBorrows :: [LLVMArrayBorrowTrans ctx w], llvmArrayTransTerm :: OpenTerm } --- | The translation of an LLVM array index is the translation of the cell --- number plus the field number (which is statically known) -data LLVMArrayIndexTrans ctx w = - LLVMArrayIndexTrans (Mb ctx (PermExpr (BVType w))) OpenTerm Int +-- | Get the SAW type of the cells of the translation of an array permission +llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> OpenTerm +llvmArrayTransCellType = typeTransType1 . llvmArrayTransHeadCell --- | Get back the 'LLVMArrayIndex' from an 'LLVMArrayIndexTrans' -llvmArrayIndexUnTrans :: LLVMArrayIndexTrans ctx w -> Mb ctx (LLVMArrayIndex w) -llvmArrayIndexUnTrans (LLVMArrayIndexTrans mb_i _ j) = - fmap (flip LLVMArrayIndex j) mb_i -- | The translation of an 'LLVMArrayBorrow' is an element / proof of the -- translation of the the 'BVProp' returned by 'llvmArrayBorrowInArrayBase' @@ -1278,8 +1280,8 @@ instance ExtPermTrans AtomicPermTrans where APTrans_BVProp $ extPermTrans prop_trans instance ExtPermTrans LLVMArrayPermTrans where - extPermTrans (LLVMArrayPermTrans ap len flds {- bs -} t) = - LLVMArrayPermTrans (extMb ap) len (fmap (map extPermTrans) flds) + extPermTrans (LLVMArrayPermTrans ap len sh {- bs -} t) = + LLVMArrayPermTrans (extMb ap) len (fmap extPermTrans sh) {- (map extPermTrans bs) -} t {- @@ -1313,9 +1315,9 @@ offsetLLVMAtomicPermTrans mb_off ptrans offsetLLVMAtomicPermTrans mb_off (APTrans_LLVMField fld ptrans) = Just $ APTrans_LLVMField (mbMap2 offsetLLVMFieldPerm mb_off fld) ptrans offsetLLVMAtomicPermTrans mb_off (APTrans_LLVMArray - (LLVMArrayPermTrans ap len flds {- bs -} t)) = + (LLVMArrayPermTrans ap len sh {- bs -} t)) = Just $ APTrans_LLVMArray $ - LLVMArrayPermTrans (mbMap2 offsetLLVMArrayPerm mb_off ap) len flds {- bs -} t + LLVMArrayPermTrans (mbMap2 offsetLLVMArrayPerm mb_off ap) len sh {- bs -} t offsetLLVMAtomicPermTrans mb_off (APTrans_LLVMBlock mb_bp t) = Just $ APTrans_LLVMBlock (mbMap2 (\off bp -> @@ -1345,7 +1347,8 @@ offsetLLVMPermTrans mb_off (PTrans_Conj ps) = PTrans_Conj $ mapMaybe (offsetLLVMAtomicPermTrans mb_off) ps offsetLLVMPermTrans mb_off (PTrans_Defined n args off ptrans) = PTrans_Defined n args (mbMap2 addPermOffsets off - (fmap mkLLVMPermOffset mb_off)) ptrans + (fmap mkLLVMPermOffset mb_off)) $ + offsetLLVMPermTrans mb_off ptrans offsetLLVMPermTrans mb_off (PTrans_Term mb_p t) = PTrans_Term (mbMap2 offsetLLVMPerm mb_off mb_p) t @@ -1356,11 +1359,6 @@ offsetPermTrans mb_off = case mbMatch mb_off of [nuMP| NoPermOffset |] -> id [nuMP| LLVMPermOffset off |] -> offsetLLVMPermTrans off --- | Get the SAW type of the cells (= lists of fields) of the translation of an --- LLVM array permission -llvmArrayTransCellType :: LLVMArrayPermTrans ctx w -> OpenTerm -llvmArrayTransCellType = typeTransType1 . llvmArrayTransFields - {- -- | Add a borrow to an LLVM array permission translation llvmArrayTransAddBorrow :: LLVMArrayBorrowTrans ctx w -> @@ -1398,100 +1396,42 @@ llvmArrayTransRemBorrow b_trans arr_trans = (llvmArrayTransBorrows arr_trans) } -} --- | Read an array cell (= list of fields) of the translation of an LLVM array --- permission at a given index, given proofs of the propositions that the index --- is in the array as returned by 'llvmArrayIndexInArray'. Note that the first --- proposition should always be that the cell number is <= the array length. +-- | Read an array cell of the translation of an LLVM array permission at a +-- given index, given proofs of the propositions that the index is in the array +-- as returned by 'llvmArrayIndexInArray'. Note that the first proposition +-- should always be that the cell number is <= the array length. getLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayIndexTrans ctx w -> [BVPropTrans ctx w] -> - [AtomicPermTrans ctx (LLVMPointerType w)] -getLLVMArrayTransCell arr_trans ix@(LLVMArrayIndexTrans _ i_trans _) - (BVPropTrans _ in_rng_term:_) = + Mb ctx (PermExpr (BVType w)) -> OpenTerm -> + [BVPropTrans ctx w] -> + AtomicPermTrans ctx (LLVMPointerType w) +getLLVMArrayTransCell arr_trans mb_cell cell_tm (BVPropTrans _ in_rng_pf:_) = let w = fromInteger $ natVal arr_trans in - mapMaybe (offsetLLVMAtomicPermTrans $ - mbMap2 (\ap ix' -> - bvAdd (llvmArrayOffset ap) (llvmArrayIndexByteOffset ap ix')) - (llvmArrayTransPerm arr_trans) (llvmArrayIndexUnTrans ix)) $ - typeTransF (llvmArrayTransFields arr_trans) + fromJust $ + offsetLLVMAtomicPermTrans (mbMap2 llvmArrayCellToOffset + (llvmArrayTransPerm arr_trans) mb_cell) $ + typeTransF (llvmArrayTransHeadCell arr_trans) [applyOpenTermMulti (globalOpenTerm "Prelude.atBVVec") [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - i_trans, in_rng_term]] -getLLVMArrayTransCell _ _ [] = - error "getLLVMArrayTransCell: first proposition is not a BVProp" + cell_tm, in_rng_pf]] +getLLVMArrayTransCell _ _ _ _ = + error "getLLVMArrayTransCell: malformed arguments" -{- --- | Write an array cell (= list of fields) of the translation of an LLVM array --- permission at a given index, given proofs of the propositions that the index --- is in the array + +-- | Write an array cell of the translation of an LLVM array permission at a +-- given index setLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayIndexTrans ctx w -> [BVPropTrans ctx w] -> - [AtomicPermTrans ctx (LLVMPointerType w)] -> + OpenTerm -> AtomicPermTrans ctx (LLVMPointerType w) -> LLVMArrayPermTrans ctx w -setLLVMArrayTransCell arr_trans (LLVMArrayIndexTrans _ i_trans _) - (BVPropTrans _ in_rng_term:_) cell = +setLLVMArrayTransCell arr_trans cell_tm cell_value = let w = fromInteger $ natVal arr_trans in arr_trans { llvmArrayTransTerm = applyOpenTermMulti (globalOpenTerm "Prelude.updBVVec") [natOpenTerm w, llvmArrayTransLen arr_trans, llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - i_trans, in_rng_term, transTupleTerm cell] } --} + cell_tm, transTerm1 cell_value] } --- | Adjust an array cell (= list of fields) of the translation of an LLVM array --- permission at a given index by applying a function to it -adjustLLVMArrayTransCell :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - OpenTerm -> LLVMArrayIndexTrans ctx w -> - LLVMArrayPermTrans ctx w -adjustLLVMArrayTransCell arr_trans f_trm (LLVMArrayIndexTrans _ i_trans _) = - let w = fromInteger $ natVal arr_trans in - arr_trans { - llvmArrayTransTerm = - applyOpenTermMulti (globalOpenTerm "Prelude.adjustBVVec") - [natOpenTerm w, llvmArrayTransLen arr_trans, - llvmArrayTransCellType arr_trans, llvmArrayTransTerm arr_trans, - f_trm, i_trans] } - --- | Read a field (= element of a cell) of the translation of an LLVM array --- permission at a given index, given proofs of the propositions that the index --- is in the array -getLLVMArrayTransField :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayIndexTrans ctx w -> [BVPropTrans ctx w] -> - AtomicPermTrans ctx (LLVMPointerType w) -getLLVMArrayTransField arr_trans ix_trans@(LLVMArrayIndexTrans - _ _ j) prop_transs = - let cell = getLLVMArrayTransCell arr_trans ix_trans prop_transs in - if j < length cell then cell !! j else - error "getLLVMArrayTransField: index too large" - --- | Write a field (= element of a cell) of the translation of an LLVM array --- permission at a given index -setLLVMArrayTransField :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayIndexTrans ctx w -> - AtomicPermTrans ctx (LLVMPointerType w) -> - LLVMArrayPermTrans ctx w -setLLVMArrayTransField arr_trans ix_trans fld = - let LLVMArrayIndexTrans _ _ j = ix_trans in - let f_trm = - lambdaTrans "fld" (llvmArrayTransFields arr_trans) - (transTupleTerm . replaceNth j fld) in - adjustLLVMArrayTransCell arr_trans f_trm ix_trans - -{- --- | Write a field (= element of a cell) of the translation of an LLVM array --- permission at a given index, given proofs of the propositions that the index --- is in the array -setLLVMArrayTransField :: (1 <= w, KnownNat w) => LLVMArrayPermTrans ctx w -> - LLVMArrayIndexTrans ctx w -> [BVPropTrans ctx w] -> - AtomicPermTrans ctx (LLVMPointerType w) -> - LLVMArrayPermTrans ctx w -setLLVMArrayTransField arr_trans ix_trans@(LLVMArrayIndexTrans - _ _ j) prop_transs fld' = - let flds = getLLVMArrayTransCell arr_trans ix_trans prop_transs in - setLLVMArrayTransCell arr_trans ix_trans prop_transs - (replaceNth j fld' flds) --} -- | Read a slice (= a sub-array) of the translation of an LLVM array permission -- for the supplied 'BVRange', given the translation of the sub-array permission @@ -1661,11 +1601,6 @@ instance (1 <= w, KnownNat w, TransInfo info) => len_tm <- translate len return $ BVRangeTrans rng off_tm len_tm -instance (1 <= w, KnownNat w, TransInfo info) => - Translate info ctx (LLVMArrayIndex w) (LLVMArrayIndexTrans ctx w) where - translate (mbMatch -> [nuMP| LLVMArrayIndex mb_i mb_j |]) = - LLVMArrayIndexTrans mb_i <$> translate1 mb_i <*> return (mbLift mb_j) - -- [| p :: ValuePerm |] = type of the impl translation of reg with perms p instance TransInfo info => Translate info ctx (ValuePerm a) (TypeTrans (PermTrans ctx a)) where @@ -1769,11 +1704,10 @@ translateLLVMArrayPerm :: (1 <= w, KnownNat w, TransInfo info) => translateLLVMArrayPerm mb_ap = do let w = natVal2 mb_ap let w_term = natOpenTerm w - let mb_len = fmap llvmArrayLen mb_ap - let mb_flds = fmap llvmArrayFields mb_ap - flds_trans <- tupleTypeTrans <$> listTypeTrans <$> translate mb_flds - len_term <- translate1 mb_len - let elem_tp = typeTransType1 flds_trans + sh_trans <- translate $ mbMapCl $(mkClosed [| Perm_LLVMBlock . + llvmArrayPermHead |]) mb_ap + let elem_tp = typeTransType1 sh_trans + len_term <- translate1 $ mbLLVMArrayLen mb_ap {- bs_trans <- listTypeTrans <$> mapM (translateLLVMArrayBorrow ap) (mbList bs) -} @@ -1782,7 +1716,7 @@ translateLLVMArrayPerm mb_ap = [w_term, len_term, elem_tp] return (w_term, len_term, elem_tp, mkTypeTrans1 arr_tp ({- flip $ -} - LLVMArrayPermTrans mb_ap len_term flds_trans) + LLVMArrayPermTrans mb_ap len_term sh_trans) {- <*> bs_trans -} ) instance (1 <= w, KnownNat w, TransInfo info) => @@ -1825,13 +1759,6 @@ instance TransInfo info => (PermTransCtx ctx ps)) where translate = translate . mbDistPermsToValuePerms . fmap unTypeDistPerms -instance (TransInfo info, 1 <= w, KnownNat w) => - Translate info ctx (LLVMArrayField w) (TypeTrans - (AtomicPermTrans ctx - (LLVMPointerType w))) where - translate = translate . fmap llvmArrayFieldToAtomicPerm - - -- LOwnedPerms translate to a single tuple type, because lowned permissions -- translate to functions with one argument and one return value instance TransInfo info => @@ -2449,8 +2376,19 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of ptrans']) m - [nuMP| SImpl_LLVMArrayCopy _ mb_ap mb_sub_ap |] -> - do let _w = natVal2 mb_ap + [nuMP| SImpl_DemoteLLVMArrayRW _ _ |] -> + do ttrans <- translateSimplImplOutHead mb_simpl + withPermStackM id + (\(pctx :>: ptrans) -> + pctx :>: typeTransF ttrans (transTerms ptrans)) + m + + [nuMP| SImpl_LLVMArrayCopy _ mb_ap _ _ |] -> + do let mb_sub_ap = + case mbSimplImplOut mb_simpl of + [nuP| _ :>: VarAndPerm _ (ValPerm_LLVMArray sub_ap) :>: _ |] -> + sub_ap + _ -> error "translateSimplImpl: SImpl_LLVMArrayCopy: unexpected perms" sub_ap_tp_trans <- translate mb_sub_ap rng_trans <- translate $ mbMap2 llvmSubArrayRange mb_ap mb_sub_ap -- let mb_sub_borrows = fmap llvmArrayBorrows mb_sub_ap @@ -2469,8 +2407,13 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of :>: ptrans_array) m - [nuMP| SImpl_LLVMArrayBorrow _ mb_ap mb_sub_ap |] -> - do sub_ap_tp_trans <- translate mb_sub_ap + [nuMP| SImpl_LLVMArrayBorrow _ mb_ap _ _ |] -> + do let mb_sub_ap = + case mbSimplImplOut mb_simpl of + [nuP| _ :>: VarAndPerm _ (ValPerm_LLVMArray sub_ap) :>: _ |] -> + sub_ap + _ -> error "translateSimplImpl: SImpl_LLVMArrayCopy: unexpected perms" + sub_ap_tp_trans <- translate mb_sub_ap let mb_rng = mbMap2 llvmSubArrayRange mb_ap mb_sub_ap rng_trans <- translate mb_rng -- let mb_sub_borrows = fmap llvmArrayBorrows mb_sub_ap @@ -2548,7 +2491,7 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of LLVMArrayPermTrans { llvmArrayTransPerm = mb_ap_out , llvmArrayTransLen = bvAddOpenTerm w len1 len2 - , llvmArrayTransFields = llvmArrayTransFields array_trans1 + , llvmArrayTransHeadCell = llvmArrayTransHeadCell array_trans1 , llvmArrayTransTerm = applyOpenTermMulti (globalOpenTerm "Prelude.appendBVVec") [natOpenTerm w, len1, len2, llvmArrayTransTerm array_trans1, @@ -2580,101 +2523,110 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m - [nuMP| SImpl_LLVMArrayOneCell _ mb_ap |] -> - do (w_term, len_term, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap + [nuMP| SImpl_LLVMArrayFromBlock _ _ |] -> + do mb_ap <- + case mbSimplImplOut mb_simpl of + [nuP| DistPermsCons _ _ (ValPerm_LLVMArray mb_ap) |] -> return mb_ap + _ -> error ("translateSimplImpl: SImpl_LLVMArrayFromBlock: " + ++ "unexpected form of output permission") + (w_term, len_term, elem_tp, ap_tp_trans) <- translateLLVMArrayPerm mb_ap withPermStackM id - (\(pctx :>: ptrans_flds) -> + (\(pctx :>: ptrans_cell) -> let arr_term = - applyOpenTermMulti (globalOpenTerm "Prelude.repeatBVVec") - [w_term, len_term, elem_tp, transTupleTerm ptrans_flds] in + applyOpenTermMulti (globalOpenTerm "Prelude.singletonBVVec") + [w_term, len_term, elem_tp, transTerm1 ptrans_cell] in pctx :>: PTrans_Conj [APTrans_LLVMArray $ typeTransF ap_tp_trans [arr_term]]) m - [nuMP| SImpl_LLVMArrayIndexCopy _ _ mb_ix |] -> + [nuMP| SImpl_LLVMArrayCellCopy _ _ mb_cell |] -> do (_ :>: ptrans_array :>: ptrans_props) <- itiPermStack <$> ask let arr_trans = unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayIndexCopy" ptrans_array + "translateSimplImpl: SImpl_LLVMArrayCellCopy" ptrans_array let prop_transs = unPTransBVProps - "translateSimplImpl: SImpl_LLVMArrayIndexCopy" ptrans_props - ix_trans <- translate mb_ix - let fld_ptrans = getLLVMArrayTransField arr_trans ix_trans prop_transs + "translateSimplImpl: SImpl_LLVMArrayCellCopy" ptrans_props + cell_tm <- translate1 mb_cell + let cell_ptrans = + getLLVMArrayTransCell arr_trans mb_cell cell_tm prop_transs withPermStackM id (\(pctx :>: _ :>: _) -> - pctx :>: PTrans_Conj [fld_ptrans] :>: ptrans_array) + pctx :>: PTrans_Conj [cell_ptrans] :>: ptrans_array) m - [nuMP| SImpl_LLVMArrayIndexBorrow _ mb_ap mb_ix |] -> + [nuMP| SImpl_LLVMArrayCellBorrow _ mb_ap mb_cell |] -> do (_ :>: ptrans_array :>: ptrans_props) <- itiPermStack <$> ask let arr_trans = unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayIndexBorrow" ptrans_array + "translateSimplImpl: SImpl_LLVMArrayCellBorrow" ptrans_array let prop_transs = unPTransBVProps - "translateSimplImpl: SImpl_LLVMArrayIndexBorrow" ptrans_props - ix_trans <- translate mb_ix - let fld_ptrans = getLLVMArrayTransField arr_trans ix_trans prop_transs + "translateSimplImpl: SImpl_LLVMArrayCellBorrow" ptrans_props + cell_tm <- translate1 mb_cell + let cell_ptrans = + getLLVMArrayTransCell arr_trans mb_cell cell_tm prop_transs {- let b = LLVMArrayBorrowTrans (fmap FieldBorrow ix) prop_transs -} let arr_trans' = arr_trans { llvmArrayTransPerm = - mbMap2 (\ap ix -> - llvmArrayAddBorrow (FieldBorrow ix) ap) - mb_ap mb_ix } + mbMap2 (\ap cell -> + llvmArrayAddBorrow (FieldBorrow cell) ap) + mb_ap mb_cell } withPermStackM id (\(pctx :>: _ :>: _) -> - pctx :>: PTrans_Conj [fld_ptrans] :>: + pctx :>: PTrans_Conj [cell_ptrans] :>: PTrans_Conj [APTrans_LLVMArray arr_trans']) m - [nuMP| SImpl_LLVMArrayIndexReturn _ mb_ap mb_ix |] -> - do (_ :>: ptrans_fld :>: ptrans_array) <- itiPermStack <$> ask - let aptrans_fld = case ptrans_fld of - PTrans_Conj [ap] -> ap - _ -> error ("translateSimplImpl: SImpl_LLVMArrayIndexReturn: " + [nuMP| SImpl_LLVMArrayCellReturn _ mb_ap mb_cell |] -> + do (_ :>: ptrans_cell :>: ptrans_array) <- itiPermStack <$> ask + let aptrans_cell = case ptrans_cell of + PTrans_Conj [aptrans] -> aptrans + _ -> error ("translateSimplImpl: SImpl_LLVMArrayCellReturn: " ++ "found non-field perm where field perm was expected") let arr_trans = unPTransLLVMArray - "translateSimplImpl: SImpl_LLVMArrayIndexCopy" ptrans_array - {- let b_trans = llvmArrayTransFindBorrow (fmap FieldBorrow ix) arr_trans -} - ix_trans <- translate mb_ix + "translateSimplImpl: SImpl_LLVMArrayCellCopy" ptrans_array + {- let b_trans = llvmArrayTransFindBorrow (fmap FieldBorrow cell) arr_trans -} + cell_tm <- translate1 mb_cell let arr_trans' = - (setLLVMArrayTransField arr_trans ix_trans - {- (llvmArrayBorrowTransProps b_trans) -} aptrans_fld) + (setLLVMArrayTransCell arr_trans cell_tm + {- (llvmArrayBorrowTransProps b_trans) -} aptrans_cell) { llvmArrayTransPerm = - mbMap2 (\ap ix -> - llvmArrayRemBorrow (FieldBorrow ix) ap) mb_ap mb_ix } + mbMap2 (\ap cell -> + llvmArrayRemBorrow (FieldBorrow cell) ap) mb_ap mb_cell } withPermStackM RL.tail (\(pctx :>: _ :>: _) -> pctx :>: PTrans_Conj [APTrans_LLVMArray arr_trans']) m - [nuMP| SImpl_LLVMArrayContents _ ap flds' impl |] -> + [nuMP| SImpl_LLVMArrayContents _ mb_ap mb_sh impl |] -> do p_out_trans <- translateSimplImplOutHead mb_simpl - (w_term, len_term, elem_tp, _) <- translateLLVMArrayPerm ap - flds_in_trans <- - fmap tupleTypeTrans $ translate $ - fmap (ValPerm_Conj . map llvmArrayFieldToAtomicPerm . llvmArrayFields) ap - flds_out_trans <- - fmap tupleTypeTrans $ translate $ - fmap (ValPerm_Conj . map llvmArrayFieldToAtomicPerm) flds' + (w_term, len_term, elem_tp, _) <- translateLLVMArrayPerm mb_ap + cell_in_trans <- + translate $ mbMapCl $(mkClosed [| ValPerm_LLVMBlock . + llvmArrayPermHead |]) mb_ap + cell_out_trans <- + translate $ mbMap2 (\ap sh -> ValPerm_LLVMBlock $ llvmArrayPermHead $ + ap { llvmArrayCellShape = sh }) + mb_ap mb_sh impl_tm <- -- FIXME: this code just fabricates a pretend LLVM value for the - -- arbitrary field of the array, which seems like a hack + -- arbitrary cell of the array that is used to substitute for the + -- variable bound by the LocalPermImpl, which seems like a hack... inExtTransM ETrans_LLVM $ - translateCurryLocalPermImpl "Error mapping array field permissions:" + translateCurryLocalPermImpl "Error mapping array cell permissions:" (mbCombine RL.typeCtxProxies impl) MNil MNil - (fmap ((MNil :>:) . extPermTrans) flds_in_trans) (MNil :>: Member_Base) - (fmap ((MNil :>:) . extPermTrans) flds_out_trans) + (fmap ((MNil :>:) . extPermTrans) cell_in_trans) (MNil :>: Member_Base) + (fmap ((MNil :>:) . extPermTrans) cell_out_trans) -- Build the computation that maps impl_tm over the input array using the -- mapBVVecM monadic combinator ptrans_arr <- getTopPermM let arr_out_comp_tm = applyOpenTermMulti (globalOpenTerm "Prelude.mapBVVecM") - [elem_tp, typeTransType1 flds_out_trans, impl_tm, + [elem_tp, typeTransType1 cell_out_trans, impl_tm, w_term, len_term, transTerm1 ptrans_arr] -- Now use bindM to bind the result of arr_out_comp_tm in the remaining -- computation @@ -2979,14 +2931,14 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [transTerm1 ptrans]) m - [nuMP| SImpl_IntroLLVMBlockPtr _ _ _ _ |] -> + [nuMP| SImpl_IntroLLVMBlockPtr _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> pctx :>: typeTransF ttrans (transTerms ptrans)) m - [nuMP| SImpl_ElimLLVMBlockPtr _ _ _ _ |] -> + [nuMP| SImpl_ElimLLVMBlockPtr _ _ |] -> do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> @@ -3000,17 +2952,11 @@ translateSimplImpl (ps0 :: Proxy ps0) mb_simpl m = case mbMatch mb_simpl of pctx :>: typeTransF ttrans [transTupleTerm ptrans]) m - [nuMP| SImpl_ElimLLVMBlockField _ _ _ |] -> - do let mb_ps = fmap ((\case ValPerm_Conj ps -> ps - _ -> error "translateSimplImpl: SImpl_ElimLLVMBlockField, VPerm_Conj required" - ). distPermsHeadPerm . simplImplOut) mb_simpl - ttrans1 <- translate $ fmap (!!0) mb_ps - ttrans2 <- translate $ fmap (!!1) mb_ps + [nuMP| SImpl_ElimLLVMBlockField _ _ |] -> + do ttrans <- translateSimplImplOutHead mb_simpl withPermStackM id (\(pctx :>: ptrans) -> - pctx :>: - PTrans_Conj [typeTransF (tupleTypeTrans ttrans1) [transTerm1 ptrans], - typeTransF ttrans2 [unitOpenTerm]]) + pctx :>: typeTransF (tupleTypeTrans ttrans) [transTerm1 ptrans]) m [nuMP| SImpl_IntroLLVMBlockArray _ _ |] -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs index 872509124f..5e3275f2da 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypeChecker.hs @@ -431,11 +431,11 @@ tcLLVMShape (ExPtrSh _ maybe_l maybe_rw sh) = <*> traverse tcKExpr maybe_rw <*> tcKExpr sh tcLLVMShape (ExFieldSh _ w fld) = PExpr_FieldShape <$> tcLLVMFieldShape_ w fld -tcLLVMShape (ExArraySh _ len stride flds) = +tcLLVMShape (ExArraySh _ len stride sh) = PExpr_ArrayShape <$> tcKExpr len <*> (Bytes . fromIntegral <$> tcNatural stride) - <*> traverse (uncurry tcLLVMFieldShape_) flds + <*> tcKExpr sh tcLLVMShape e = tcError (pos e) "Expected shape" -- | Field and array helper for 'tcLLVMShape' @@ -524,11 +524,23 @@ tcAtomicPerm (StructRepr tys) e = tcStructAtomic tys e tcAtomicPerm LifetimeRepr e = tcLifetimeAtomic e tcAtomicPerm _ e = tcError (pos e) "Expected perm" +-- | Build a field permission using an 'LLVMFieldShape' +fieldPermFromShape :: (KnownNat w, 1 <= w) => PermExpr RWModalityType -> + PermExpr LifetimeType -> PermExpr (BVType w) -> + LLVMFieldShape w -> AtomicPerm (LLVMPointerType w) +fieldPermFromShape rw l off (LLVMFieldShape p) = + Perm_LLVMField $ LLVMFieldPerm rw l off p + -- | Check an LLVM pointer atomic permission expression tcPointerAtomic :: (KnownNat w, 1 <= w) => AstExpr -> Tc (AtomicPerm (LLVMPointerType w)) -tcPointerAtomic (ExPtr p l rw off sz c) = - llvmArrayFieldToAtomicPerm <$> tcArrayFieldPerm (ArrayPerm p l rw off sz c) -tcPointerAtomic (ExArray _ x y z w) = Perm_LLVMArray <$> tcArrayAtomic x y z w +tcPointerAtomic (ExPtr _ l rw off sz c) = + fieldPermFromShape + <$> tcKExpr rw + <*> tcOptLifetime l + <*> tcKExpr off + <*> tcLLVMFieldShape_ sz c +tcPointerAtomic (ExArray _ l rw off len stride sh) = + Perm_LLVMArray <$> tcArrayAtomic l rw off len stride sh tcPointerAtomic (ExMemblock _ l rw off len sh) = Perm_LLVMBlock <$> tcMemblock l rw off len sh tcPointerAtomic (ExFree _ x ) = Perm_LLVMFree <$> tcKExpr x tcPointerAtomic (ExLlvmFunPtr _ n w f) = tcFunPtrAtomic n w f @@ -564,27 +576,18 @@ tcMemblock l rw off len sh = -- | Check an atomic array permission literal tcArrayAtomic :: - (KnownNat w, 1 <= w) => AstExpr -> AstExpr -> AstExpr -> [ArrayPerm] -> Tc (LLVMArrayPerm w) -tcArrayAtomic off len stride fields = + (KnownNat w, 1 <= w) => Maybe AstExpr -> AstExpr -> AstExpr -> AstExpr -> + AstExpr -> AstExpr -> Tc (LLVMArrayPerm w) +tcArrayAtomic l rw off len stride sh = LLVMArrayPerm - <$> tcKExpr off + <$> tcKExpr rw + <*> tcOptLifetime l + <*> tcKExpr off <*> tcKExpr len <*> (Bytes . fromIntegral <$> tcNatural stride) - <*> traverse tcArrayFieldPerm fields + <*> tcKExpr sh <*> pure [] --- | Check a single field of an array permission -tcArrayFieldPerm :: forall w. (KnownNat w, 1 <= w) => ArrayPerm -> Tc (LLVMArrayField w) -tcArrayFieldPerm (ArrayPerm _ l rw off sz c) = - do llvmFieldLifetime <- tcOptLifetime l - llvmFieldRW <- tcExpr RWModalityRepr rw - llvmFieldOffset <- tcKExpr off :: Tc (PermExpr (BVType w)) - Some (Pair w LeqProof) <- maybe (pure (Some (Pair (knownNat :: NatRepr w) LeqProof))) - tcPositive sz - withKnownNat w do - llvmFieldContents <- withKnownNat w (tcValPerm (LLVMPointerRepr w) c) - pure (LLVMArrayField LLVMFieldPerm{..}) - -- | Check a frame permission literal tcFrameAtomic :: (KnownNat w, 1 <= w) => AstExpr -> Tc (AtomicPerm (LLVMFrameType w)) tcFrameAtomic (ExLlvmFrame _ xs) = diff --git a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs index e096e0687a..80071e8ceb 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/TypedCrucible.hs @@ -3280,10 +3280,11 @@ tcEmitLLVMStmt arch ctx loc (LLVM_MemClear _ (ptr :: Reg ctx (LLVMPointerType wp -- For each field perm, prove it and write 0 to it (forM_ @_ @_ @_ @() flds $ \case - LLVMArrayField fp -> + Perm_LLVMField fp -> stmtProvePerm tptr (emptyMb $ ValPerm_Conj1 $ Perm_LLVMField fp) >>> emitTypedLLVMStore arch Nothing loc tptr fp (PExpr_LLVMWord (bvInt 0)) DistPermsNil >>> - stmtRecombinePerms) >>> + stmtRecombinePerms + _ -> error "Unexpected return value from llvmFieldsOfSize") >>> -- Return a fresh unit variable dbgNames >>= \names -> @@ -4079,7 +4080,8 @@ visitEntry names can_widen blk entry = mapM (traverseF $ visitCallSite entry) (typedEntryCallers entry) >>= \callers -> - debugTrace dlevel ("can_widen: " ++ show can_widen ++ ", any_fails: " ++ show (any (anyF typedCallSiteImplFails) callers)) $ + debugTrace dlevel ("can_widen: " ++ show can_widen ++ ", any_fails: " + ++ show (any (anyF typedCallSiteImplFails) callers)) $ if can_widen && any (anyF typedCallSiteImplFails) callers then case widenEntry dlevel env entry of Some entry' -> diff --git a/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs b/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs index 5716636ad2..e87b38a845 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/UntypedAST.hs @@ -61,7 +61,7 @@ data AstExpr | ExExSh Pos String AstType AstExpr -- ^ existentially quantified shape | ExFieldSh Pos (Maybe AstExpr) AstExpr -- ^ field shape | ExPtrSh Pos (Maybe AstExpr) (Maybe AstExpr) AstExpr -- ^ pointer shape - | ExArraySh Pos AstExpr AstExpr [(Maybe AstExpr, AstExpr)] -- array shape + | ExArraySh Pos AstExpr AstExpr AstExpr -- ^ array shape | ExEqual Pos AstExpr AstExpr -- ^ equal bitvector proposition | ExNotEqual Pos AstExpr AstExpr -- ^ not-equal bitvector proposition @@ -77,7 +77,7 @@ data AstExpr | ExPtr Pos (Maybe AstExpr) AstExpr AstExpr (Maybe AstExpr) AstExpr -- ^ pointer permission | ExMemblock Pos (Maybe AstExpr) AstExpr AstExpr AstExpr AstExpr -- ^ memblock permission | ExLlvmFunPtr Pos AstExpr AstExpr AstFunPerm -- ^ function pointer permission - | ExArray Pos AstExpr AstExpr AstExpr [ArrayPerm] -- array permission + | ExArray Pos (Maybe AstExpr) AstExpr AstExpr AstExpr AstExpr AstExpr -- ^ array permission deriving Show -- | Returns outermost position @@ -116,7 +116,7 @@ instance HasPos AstExpr where pos (ExMemblock p _ _ _ _ _) = p pos (ExLlvmFunPtr p _ _ _ ) = p pos (ExLlvmFrame p _ ) = p - pos (ExArray p _ _ _ _ ) = p + pos (ExArray p _ _ _ _ _ _) = p pos (ExArraySh p _ _ _ ) = p -- | Returns outermost position diff --git a/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs b/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs index a2f862ea24..c7405b15da 100644 --- a/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs +++ b/heapster-saw/src/Verifier/SAW/Heapster/Widening.hs @@ -102,6 +102,14 @@ wnMapExtWidFun :: WidNameMap -> ExtVarPermsFun vars wnMapExtWidFun wnmap = ExtVarPermsFun $ \ns -> ExtVarPerms_Base $ RL.map (flip wnMapGetPerm wnmap) ns +-- | Assign the trivial @true@ permission to any variable that has not yet been +-- visited +wnMapDropUnvisiteds :: WidNameMap -> WidNameMap +wnMapDropUnvisiteds = + NameMap.map $ \case + p@(Pair _ (Constant True)) -> p + (Pair _ (Constant False)) -> Pair ValPerm_True (Constant False) + newtype PolyContT r m a = PolyContT { runPolyContT :: forall x. (forall y. a -> m (r y)) -> m (r x) } @@ -402,21 +410,11 @@ widenExpr' _ (PExpr_FieldShape (LLVMFieldShape p1)) (PExpr_FieldShape | Just Refl <- testEquality (exprLLVMTypeWidth p1) (exprLLVMTypeWidth p2) = PExpr_FieldShape <$> LLVMFieldShape <$> widenPerm knownRepr p1 p2 --- Array shapes can only be widened if they have the same length, stride, and --- fields whose ith fields have the same size for each i -widenExpr' _ (PExpr_ArrayShape len1 stride1 flds1) (PExpr_ArrayShape - len2 stride2 flds2) - | bvEq len1 len2 && stride1 == stride2 - , and (zipWith - (\(LLVMFieldShape p1) (LLVMFieldShape p2) -> - isJust $ testEquality (exprLLVMTypeWidth p1) (exprLLVMTypeWidth p2)) - flds1 flds2) = - PExpr_ArrayShape len1 stride1 <$> - zipWithM (\(LLVMFieldShape p1) (LLVMFieldShape p2) -> - case testEquality (exprLLVMTypeWidth p1) (exprLLVMTypeWidth p2) of - Just Refl -> LLVMFieldShape <$> widenPerm knownRepr p1 p2 - Nothing -> error "widenExpr: unreachable!") - flds1 flds2 +-- Array shapes can only be widened if they have the same length and stride +widenExpr' _ (PExpr_ArrayShape + len1 stride1 sh1) (PExpr_ArrayShape len2 stride2 sh2) + | bvEq len1 len2 && stride1 == stride2 = + PExpr_ArrayShape len1 stride1 <$> widenExpr knownRepr sh1 sh2 -- FIXME: there should be some check that the first shapes have the same length, -- though this is more complex if they might have free variables...? @@ -553,16 +551,23 @@ widenAtomicPerms' tp (Perm_LLVMArray ap1 : ps1) ps2 = substEqVars wnmap (llvmArrayLen ap1) == substEqVars wnmap (llvmArrayLen ap2) && llvmArrayStride ap1 == llvmArrayStride ap2 && - substEqVars wnmap (llvmArrayFields ap1) - == substEqVars wnmap (llvmArrayFields ap2) + -- FIXME: widen the rw modalities? + substEqVars wnmap (llvmArrayRW ap1) + == substEqVars wnmap (llvmArrayRW ap2) && + substEqVars wnmap (llvmArrayLifetime ap1) + == substEqVars wnmap (llvmArrayLifetime ap2) _ -> False) ps2 of Just i | Perm_LLVMArray ap2 <- ps2!!i -> -- NOTE: at this point, ap1 and ap2 are equal except for perhaps their - -- borrows, so we just filter out the borrows in ap1 that are also in ap2 - (Perm_LLVMArray (ap1 { llvmArrayBorrows = - filter (flip elem (llvmArrayBorrows ap2)) - (llvmArrayBorrows ap1) }) :) <$> + -- borrows and shapes, so we just filter out the borrows in ap1 that are + -- also in ap2 and widen the shapes + widenExpr knownRepr (llvmArrayCellShape ap1) (llvmArrayCellShape ap2) + >>= \sh -> + (Perm_LLVMArray (ap1 { llvmArrayCellShape = sh, + llvmArrayBorrows = + filter (flip elem (llvmArrayBorrows ap2)) + (llvmArrayBorrows ap1) }) :) <$> widenAtomicPerms tp ps1 (deleteNth i ps2) _ -> -- We did not find an appropriate array on the RHS, so drop this one @@ -959,6 +964,7 @@ widen dlevel env tops args (Some (ArgVarPerms void $ widenExprs all_args (RL.map PExpr_Var args_ns1) (RL.map PExpr_Var args_ns2) widenExtGhostVars vars1 vars1_ns vars2 vars2_ns + modifying wsNameMap wnMapDropUnvisiteds wnmap <- view wsNameMap <$> get traceM (\i -> pretty "Widening returning:" <> line <> diff --git a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v index 68af8d8877..7e15985125 100644 --- a/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v +++ b/saw-core-coq/coq/generated/CryptolToCoq/SAWCorePrelude.v @@ -925,8 +925,8 @@ Axiom at_gen_BVVec : forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCoreV Axiom gen_at_BVVec : forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), forall (a : Type), forall (x : BVVec n len a), SAWCoreScaffolding.Eq (BVVec n len a) (genBVVec n len a (atBVVec n len a x)) x . -Definition updBVVec : forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), forall (a : Type), BVVec n len a -> forall (ix : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), is_bvult n ix len -> a -> BVVec n len a := - fun (n : SAWCoreScaffolding.Nat) (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (a : Type) (v : SAWCoreVectorsAsCoqVectors.Vec (SAWCoreVectorsAsCoqVectors.bvToNat n len) a) (ix : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (pf : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreVectorsAsCoqVectors.bvult n ix len) SAWCoreScaffolding.true) (elem : a) => genBVVec n len a (fun (i : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (_1 : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreVectorsAsCoqVectors.bvult n i len) SAWCoreScaffolding.true) => if bvEq n i ix then elem else atBVVec n len a v ix pf). +Definition updBVVec : forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), forall (a : Type), BVVec n len a -> forall (ix : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), a -> BVVec n len a := + fun (n : SAWCoreScaffolding.Nat) (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (a : Type) (v : SAWCoreVectorsAsCoqVectors.Vec (SAWCoreVectorsAsCoqVectors.bvToNat n len) a) (ix : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (elem : a) => genBVVec n len a (fun (i : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (pf : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreVectorsAsCoqVectors.bvult n i len) SAWCoreScaffolding.true) => if bvEq n i ix then elem else atBVVec n len a v i pf). Definition adjustBVVec : forall (n : SAWCoreScaffolding.Nat), forall (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool), forall (a : Type), BVVec n len a -> (a -> a) -> SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool -> BVVec n len a := fun (n : SAWCoreScaffolding.Nat) (len : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (a : Type) (v : SAWCoreVectorsAsCoqVectors.Vec (SAWCoreVectorsAsCoqVectors.bvToNat n len) a) (f : a -> a) (ix : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) => genBVVec n len a (fun (i : SAWCoreVectorsAsCoqVectors.Vec n SAWCoreScaffolding.Bool) (pf : SAWCoreScaffolding.Eq SAWCoreScaffolding.Bool (SAWCoreVectorsAsCoqVectors.bvult n i len) SAWCoreScaffolding.true) => if bvEq n i ix then f (atBVVec n len a v i pf) else atBVVec n len a v i pf). diff --git a/saw-core/prelude/Prelude.sawcore b/saw-core/prelude/Prelude.sawcore index 6dd396f070..2df4e9fe22 100644 --- a/saw-core/prelude/Prelude.sawcore +++ b/saw-core/prelude/Prelude.sawcore @@ -1698,13 +1698,14 @@ axiom gen_at_BVVec : (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> (x : BVVec n len a) -> Eq (BVVec n len a) (genBVVec n len a (atBVVec n len a x)) x; --- Update the value at a specific index in a BVVec +-- Update the value at a specific index in a BVVec if it is in range, otherwise +-- do nothing updBVVec : (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) -> BVVec n len a -> (ix : Vec n Bool) -> - is_bvult n ix len -> a -> BVVec n len a; -updBVVec n len a v ix pf elem = - genBVVec n len a (\ (i:Vec n Bool) (_:is_bvult n i len) -> - ite a (bvEq n i ix) elem (atBVVec n len a v ix pf)); + a -> BVVec n len a; +updBVVec n len a v ix elem = + genBVVec n len a (\ (i:Vec n Bool) (pf:is_bvult n i len) -> + ite a (bvEq n i ix) elem (atBVVec n len a v i pf)); -- Adjust the value at a specific index in a BVVec by applying a function adjustBVVec : (n : Nat) -> (len : Vec n Bool) -> (a : sort 0) ->